# Difference between revisions of "Haskell Quiz/Astar/Solution Dolio"

(sharpen cat) |
(Fixed a problem in link that caused a massive slowdown.) |
||

Line 55: | Line 55: | ||

link (Branch k a Nil m) r = Branch k a r m |
link (Branch k a Nil m) r = Branch k a r m |
||

− | link (Branch k a ll lr) r = Branch k a (union |
+ | link (Branch k a ll lr) r = Branch k a Nil (union (union r ll) lr) |

</haskell> |
</haskell> |
||

## Revision as of 14:26, 24 December 2008

A* requires keeping a priority queue of places to visit. This can be done with a simple sorted list, but I decided to make a PriorityQueue data type for use in the algorithm instead. The implementation uses lazy pairing heaps from Chris Okasaki's **Purely Functional Data Structures**.

```
module PriorityQueue (
PriorityQueue,
empty,
singleton,
fromList,
null,
deleteFindMin,
deleteMin,
findMin,
insert,
union
) where
import Prelude hiding (null)
data Ord k => PriorityQueue k a = Nil | Branch k a (PriorityQueue k a) (PriorityQueue k a)
empty :: Ord k => PriorityQueue k a
empty = Nil
singleton :: Ord k => k -> a -> PriorityQueue k a
singleton k a = Branch k a Nil Nil
fromList :: Ord k => [(k,a)] -> PriorityQueue k a
fromList = foldr (\(k,a) q -> singleton k a `union` q) empty
null :: Ord k => PriorityQueue k a -> Bool
null Nil = True
null _ = False
deleteFindMin :: Ord k => PriorityQueue k a -> ((k,a), PriorityQueue k a)
deleteFindMin Nil = error "Empty heap."
deleteFindMin (Branch k a l r) = ((k,a), union l r)
deleteMin :: Ord k => PriorityQueue k a -> PriorityQueue k a
deleteMin h = snd (deleteFindMin h)
findMin :: Ord k => PriorityQueue k a -> (k, a)
findMin h = fst (deleteFindMin h)
insert :: Ord k => k -> a -> PriorityQueue k a -> PriorityQueue k a
insert k a h = union (singleton k a) h
union :: Ord k => PriorityQueue k a -> PriorityQueue k a -> PriorityQueue k a
union l Nil = l
union Nil r = r
union l@(Branch kl _ _ _) r@(Branch kr _ _ _)
| kl <= kr = link l r
| otherwise = link r l
link (Branch k a Nil m) r = Branch k a r m
link (Branch k a ll lr) r = Branch k a Nil (union (union r ll) lr)
```

Not all the functions from data structures in the standard library (Data.Map, Data.Set, etc.) are provided; I only wrote those that are needed for the algorithm. However, this could be extended easily.

The rest is just a general A* function, which takes a starting place, and functions for successors, testing for completion, cost of a place, and heuristic estimation from a place to the end, returning the path taken (a list from end to start). The rest of the code deals with the specifics of the ASCII map:

```
{-# OPTIONS_GHC -fglasgow-exts #-}
module Main where
import Control.Monad (guard, liftM2)
import Control.Monad.Instances
import Data.List (findIndex)
import qualified Data.Set as S
import qualified Data.Map as M
import qualified PriorityQueue as Q
type Point = (Int, Int)
type Map = [[Char]]
find :: Char -> Map -> Point
find c m = find' 0 m
where find' _ [] = error "Can't find tile."
find' y (h:t)
| Just x <- findIndex (==c) h = (y, x)
| otherwise = find' (y+1) t
heuristic :: Point -> Point -> Int
heuristic (x, y) (u, v) = abs (x - u) `max` abs (y - v)
successor :: Map -> Point -> [Point]
successor m (x,y) = do u <- [x + 1, x, x - 1]
v <- [y + 1, y, y - 1]
guard (0 <= u && u < length m)
guard (0 <= v && v < length (head m))
guard (u /= x || y /= v)
guard (m !! u !! v /= '~')
return (u, v)
astar start succ end cost heur
= astar' (S.singleton start) (Q.singleton (heur start) [start])
where
astar' seen q
| Q.null q = error "No Solution."
| end n = next
| otherwise = astar' seen' q'
where
((c,next), dq) = Q.deleteFindMin q
n = head next
succs = filter (`S.notMember` seen) $ succ n
costs = map ((+ c) . (subtract $ heur n) . liftM2 (+) cost heur) succs
q' = dq `Q.union` Q.fromList (zip costs (map (:next) succs))
seen' = seen `S.union` S.fromList succs
path :: [[Char]] -> [Point] -> [[Char]]
path m l = iterY m l 0
where iterY [] _ _ = []
iterY (h:t) l n = iterX h l n 0 : iterY t l (n+1)
iterX [] _ _ _ = []
iterX (h:t) l n m = (if (n,m) `elem` l then '#' else h) : iterX t l n (m+1)
doit s = unlines . path m $ astar start succ (== end) cost h
where m = lines s
start = find '@' m
end = find 'X' m
succ = successor m
h = heuristic end
cost (x, y) = costsM M.! (m !! x !! y)
costsM = M.fromList [('@',1),('x',1),('X',1),('.',1),('*',2),('^',3)]
main = interact doit
```