{-
compile with:
$ stack install vector
$ stack install PSQueue
$ stack install monad-par
$ stack --resolver lts-22.33 ghc -- --make -Wall -O mazeSolver.hs -threaded -rtsopts

run with:
./mazeSolver <mazefile> <depth> [-show] +RTS -N<depth>

My project is a parallel implementation of A* that uses the algorithm to solve mazes.
As input, it takes the path to a "maze file" which contains an ASCII representation of a maze.
A maze is a 2-dimensional grid of tiles, where each tile can be one of the following:
- ”s“ denotes a start tile that may be part of a maze solution
- “g” denotes a goal tile that may be part of a maze solution
- “ “ denotes an empty tile that may be part of a maze solution
- “X” denotes a wall tile that may not be part of a maze solution

A maze must contain exactly one start tile and one goal tile. Paths cannot go diagonally between
tiles, and all empty tiles must be reachable from all other empty tiles (i.e., there are no
"islands"). For example, the following 4x4 grid is a valid maze:
s  X
 X X
X   
g X 

My project reads in the maze file, constructs an in-memory representation of a maze, and runs the
parallelized A* algorithm on the maze. The output from the program is a path from the
start tile to the goal tile (with the path represented as an array of coordinates), or a message
indicating that no solution path exists. You can use the "-show" flag to have the program print
out the maze with the path annotated on it. For my A* heuristic function, I use the distance
between a given tile and the goal tile, computed using the X and Y positions of tiles in the maze.

Parallelism strategies attempted:
"Checkpoint partitioning": This is a strategy I came up with that I decided to use in my final
version of the project. This involves finding <depth - 1> "checkpoints" in a line between the
start and goal tiles, then running A* on each closest pair of points to get partial paths, before
finally stitching the paths together and smoothing out any redundant "bumps" in the path. This is
the fastest approach I tried, but can lead to a slightly less optimal path. I found that the percent
increase in path length was relatively small compared to the percentage speedup when running
in parallel.

"Multiple starts": Expand outward from the start node until you find <depth> nodes from
which to do a search to the goal node. Take the resulting shortest path. I found that this was not
much faster than a serial A* on most mazes, since the nodes I searched from were not far apart from
each other and ended up doing almost the same work as a serial A* per thread.

For references used, see the "References" section in the report.
-}

import System.Environment
import System.Exit
import Data.Vector as Vec (Vector, foldr, fromList, (!))
import Data.PSQueue as PSQueue
import qualified Data.Map as Dict
import Data.Maybe
import Data.Set as Set (fromList, member)
import Control.Parallel.Strategies

data TileType = Step | Start | Goal | Wall
instance Show TileType where
  show Step  = " "
  show Start = "s"
  show Goal  = "g"
  show Wall  = "X"
instance Eq TileType where
  Step == Step   = True
  Start == Start = True
  Goal == Goal   = True
  Wall == Wall   = True
  _ == _         = False

data Node = Node
    { ttype :: TileType
    , x     :: Int
    , y     :: Int
    }
instance Eq Node where
  n1 == n2 = (((x n1) == (x n2)) && ((y n1) == (y n2)))
instance Ord Node where
  compare n1 n2 =
    compare ((show (x n1)) ++ "x" ++ (show (y n1))) ((show (x n2)) ++ "x" ++ (show (y n2)))
instance Show Node where
  show n = show (ttype n)

data Maze = Maze
    { rows  :: Vector (Vector Node)
    , xlen  :: Int
    , ylen  :: Int
    , start :: (Int, Int)
    , goal  :: (Int, Int)
    }

-- uncomment lines from this function to print out the actual maze (without a path).
instance Show Maze where
  show m = do
    let line1 = (show (xlen m)) ++ "x" ++ (show (ylen m)) ++ "\n"
    let line2 = "start: " ++ show (start m) ++ "\ngoal:  " ++ show (goal m)
    --let linen = Vec.foldr (\a b -> "\n" ++ (Vec.foldr (\c d -> (show c) ++ d) [] a) ++ b) "" (rows m)
    line1 ++ line2 -- ++ linen

showPath :: Maze -> [(Int, Int)] -> Bool -> [Char]
showPath _ [] _ = "No path exists"
showPath m path show_maze =
  "Path (length " ++ (show (length path)) ++ "): " ++ (show path) ++ "\n" ++
    (case show_maze of
       True -> solution
       _ -> "")
  where
    solution = Vec.foldr (\a b -> "\n" ++ (Vec.foldr (\c d -> (showWithPath c) ++ d) [] a) ++ b) "" (rows m)
    pathset = Set.fromList path
    showWithPath node =
      case (ttype node) of
        Step -> case (Set.member (x node, y node) pathset) of
                  True -> "."
                  _ -> show node
        _ -> show node

-- heuristic for A*: coordinate distance to the goal node
h :: Maze -> (Int, Int) -> Double
h m (x', y') = do
  let xdiff = (x' - (fst (goal m)))
  let ydiff = (y' - (snd (goal m)))
  let x2 = xdiff * xdiff
  let y2 = ydiff * ydiff
  sqrt ((fromIntegral x2) + (fromIntegral y2))

-- deletes adjacent duplicates from a list
dedup :: Eq a => [a] -> [a]
dedup (x:y:zs) =
  if (x == y)
    then dedup (y:zs)
    else x:(dedup (y:zs))
dedup xs = xs

-- given a list, deletes all elements between nonadjacent duplicates in the list.
-- for example, smooth [1, 2, 3, 4, 5, 2, 3] == [1, 2, 3].
-- this is used to improve paths returned by the parallel A*.
smooth :: Ord a => [a] -> [a]
smooth as = smoothHelper Dict.empty (0 :: Int) as []
  where
    smoothHelper _ _ [] q = map (\(a, _) -> a) (reverse q)
    smoothHelper dict i (x:xs) q =
      if (Dict.member x dict)
        then do
          let from = fromJust (Dict.lookup x dict)
          smoothHelper dict (i + 1) xs (filter (\(_, b) -> b <= from) q)
        else smoothHelper (Dict.insert x i dict) (i + 1) xs ((x, i):q)

-- generate <depth> pairs of start and goal nodes to use for parallelizing the algorithm.
checkPoints :: Maze -> Int -> Node -> Node -> [(Node, Node)]
checkPoints m depth start goal = do
  let x1 = x start
  let x2 = x goal
  let y1 = y start
  let y2 = y goal
  let xdiff = abs (x1 - x2)
  let ydiff = abs (y1 - y2)
  let xdiv = div xdiff depth
  let ydiv = div ydiff depth

  let xop = if (x1 < x2) then (+) else (-)
  let yop = if (y1 < y2) then (+) else (-)
  let candidatePoints = [n | i <- [1..(depth - 1)], let x = x1 `xop` (xdiv * i), let y = y1 `yop` (ydiv * i), let n = findNodeByIndex m (x, y)]
  let middle = dedup (take (depth - 1) (map (\a -> nearestPoint [a]) candidatePoints))
  zip (start:middle) (middle ++ [goal])
  where
    nearestPoint (n:ns) =
      if ((ttype n) == Wall)
        then nearestPoint (ns ++ (allNeighborsOf m n))
        else n
    nearestPoint [] = goal

-- verifies that a path is legal (i.e., that all adjacent steps are one step apart),
-- and that it ends with the goal
verifyPath :: [(Int, Int)] -> Node -> Bool
verifyPath [] _ = False
verifyPath xs goal = (not (Prelude.null xs)) && (snd (Prelude.foldr areNeighbors ((-1, -1), True) xs)) && ((last xs) == (x goal, y goal))
  where
    areNeighbors a (b1, b2) = (a, b2 && (isNeighborOf a b1))
    isNeighborOf (a1, a2) (b1, b2) =
      if ((a1, a2) == (-1, -1))
        then True
        else if ((b1, b2) == (-1, -1))
          then True
          else elem (a1, a2) [(b1, b2 - 1), (b1, b2 + 1), (b1 - 1, b2), (b1 + 1, b2)]

-- launch a* in parallel to find a path from the start to goal
aStarPar :: Maze -> Int -> [(Int, Int)]
aStarPar m depth =
  if (depth <= 1)
    then aStar m startN goalN
    else do
      let path = smooth (concat ((parHelper (checkPoints m depth startN goalN)) `using` parList rseq))
      if (verifyPath path goalN)
        then path
        else []
  where
    startN = findNodeByIndex m (start m)
    goalN = findNodeByIndex m (goal m)
    parHelper ns = [x | (sn, gn) <- ns, let x = aStar m sn gn]

-- given a maze, a start node, and a goal node, use A* to find the shortest path
aStar :: Maze -> Node -> Node -> [(Int, Int)]
aStar m startN goalN = do
  let oset = PSQueue.singleton startN (h m (x startN, y startN))
  let prev = Dict.empty -- maps Nodes to previous Nodes in best path
  let gmap = Dict.singleton startN (0 :: Int) -- maps Nodes to Ints
  step oset prev gmap
  where
    step openset prev gmap = do
      let (nbinding, openset') = fromJust (minView openset)
      let n = key nbinding
      if (n == goalN)
        then reverse ((x n, y n):(rebuildPath prev n))
        else do
          let neighbors = neighborsOf m n
          let (openset'', prev', gmap') = updateStructures openset' prev gmap n neighbors
          if (PSQueue.null openset'')
            then []
            else step openset'' prev' gmap'

    rebuildPath prev n = if (n == startN) -- returns [(Int, Int)]
      then []
      else do
        let laststep = fromJust (Dict.lookup n prev)
        (x laststep, y laststep):(rebuildPath prev laststep)

    updateStructures openset prev gmap _ [] =
      (openset, prev, gmap)
    updateStructures openset prev gmap cur (n:ns) = do
      let tmpscore = fromJust (Dict.lookup cur gmap) + 1 :: Int
      if (tmpscore < (Dict.findWithDefault 999999 n gmap)) -- reasonable max heuristic value
        then do
          let prev' = Dict.insert n cur prev
          let gmap' = Dict.insert n tmpscore gmap
          let openset' = case (PSQueue.lookup n openset) of
                Nothing -> PSQueue.insert n ((fromIntegral tmpscore) + (h m (x n, y n))) openset
                _ -> openset
          updateStructures openset' prev' gmap' cur ns
        else
          updateStructures openset prev gmap cur ns

findNodeByIndex :: Maze -> (Int, Int) -> Node
findNodeByIndex m (x, y) = ((rows m)!y)!x

neighborsOf :: Maze -> Node -> [Node]
neighborsOf m n = do
  let xv = x n
  let yv = y n
  let coords = Prelude.filter filterCoords [(xv+1, yv), (xv, yv+1), (xv-1, yv), (xv, yv-1)]
  filter (\a -> (ttype a) /= Wall) (map (\a -> findNodeByIndex m a) coords)
  where
    filterCoords (a, b) = (a >= 0) && (a < xlenv) && (b >= 0) && (b < ylenv)
    xlenv = xlen m
    ylenv = ylen m

allNeighborsOf :: Maze -> Node -> [Node]
allNeighborsOf m n = do
  let xv = x n
  let yv = y n
  let coords = Prelude.filter filterCoords [(xv+1, yv), (xv, yv+1), (xv-1, yv), (xv, yv-1)]
  map (\a -> findNodeByIndex m a) coords
  where
    filterCoords (a, b) = (a >= 0) && (a < xlenv) && (b >= 0) && (b < ylenv)
    xlenv = xlen m
    ylenv = ylen m

-- returns the indices in the 2D array of nodes with a given TileType. Used to find
-- the start and goal nodes.
findIndexByType :: [[Node]] -> TileType -> (Int, Int)
findIndexByType [] _ = (-1, -1)
findIndexByType (r:rs) tt = do
  case (Prelude.filter (\n -> (ttype n) == tt) r) of
    [n] -> (x n, y n)
    _ -> findIndexByType rs tt

-- takes in a row of characters, an xlen, a ylen, and returns the maze.
-- would it be worth parallelizing this for big mazes?
buildMaze :: [[Char]] -> Int -> Int -> Maze
buildMaze mlines ylen xlen = do
  let rows = toRows (zip mlines [0..])
  let start = findIndexByType rows Start
  let goal = findIndexByType rows Goal
  let vecs = Vec.fromList (map (\a -> Vec.fromList a) rows) -- make [[Node]] into a 2D vector
  Maze { rows = vecs, xlen = xlen, ylen = ylen, start = start, goal = goal }
    where toRows [] = [] -- this returns [[Node]]
          toRows ((l, y):ls) = (map toNode charsWithIndex) : (toRows ls)
            where charsWithIndex = map (\(a, b) -> (a, b, y)) (zip l [0..])
          toNode (n, x, y) = do
            let ttype = case n of
                  ' ' -> Step
                  's' -> Start
                  'g' -> Goal
                  'X' -> Wall
                  _   -> Step -- Shouldn't happen in a valid maze
            Node { ttype = ttype, x = x, y = y }

main :: IO ()
main = do
  args <- getArgs
  case args of
    (filename:depth:xs) -> do
      contents <- readFile filename
      let mlines = lines contents
      let ylen = length mlines
      if (ylen == 0)
        then die ("Maze is invalid: height is 0")
        else return ()
      let xlen = length (head mlines)
      if (xlen == 0)
        then die ("Maze is invalid: length is 0")
        else return ()
      if not (Prelude.foldr (\a b -> b && ((length a) == xlen)) True mlines)
        then die ("Maze is invalid: row lengths vary")
        else return ()
      let ndepth = read depth
      let maze = buildMaze mlines ylen xlen
      let path = aStarPar maze ndepth
      let show_maze = case xs of
            ("-show":[]) -> True
            _ -> False
      putStrLn ((show maze) ++ "\n\n" ++ (showPath maze path show_maze))
    _ -> do
      prog <- getProgName
      die ("Usage: " ++ prog ++ " <maze-filename> <depth> [-show] +RTS -N<depth>")
