*cost*. The expression shown below produces an A* search. If instead one substitutes

*cost = sum . map dist . segments*, the procedure becomes a uniform-cost search. Using

*length*finds the path with fewest nodes, and simiarly

*dist [last ps, goal]*produces a greedy best-first algorithm.

{-# LANGUAGE PackageImports #-} import Graphics.UI.SDL.Primitives (line, filledCircle) import Graphics.UI.SDL as SDL import Control.Monad (mapM_, liftM, liftM2) import System.Random.Mersenne.Pure64 (pureMT, randomInt) import Data.List (unfoldr, groupBy, sortBy, maximumBy) import Data.Ord (comparing) import Data.Function (on) import "hashmap" Data.HashSet (fromList, toList, difference, intersection, empty, insert, delete, unions, member) main = withInit [InitVideo] $ do win <- setVideoMode xres yres 32 [Fullscreen] enableEvent SDLMouseMotion False fillRect win (Just $ Rect 0 0 xres yres) (Pixel 0) drawGraph win SDL.flip win loop loop = do delay 200 e <- pollEvent case e of KeyUp (Keysym SDLK_ESCAPE _ _) -> return () _ -> loop drawGraph w = do let route = search [[start]] empty drawLines w 0x0000FFFF (map toList graph) drawNodes w 0xFFFFFFFF nodes drawNodes w 0xFFFF00FF route drawLines w 0xFFFF00FF (segments route) drawNodes w 0x00FF00FF [start] drawNodes w 0xFF0000FF [goal] drawNodes w rgb = mapM_ draw where draw [x,y] = filledCircle w x y 4 (Pixel rgb) drawLines w rgb = mapM_ draw where draw [[a, b], [c, d]] = line w a b c d (Pixel rgb) -------------------------------------------------------------------------- search frontier explored | null frontier = [] | otherwise = if state == goal then path else search next (state `insert` explored) where state = last path path = head frontier next = tail frontier ++ actions path explored state actions path explored state = sort' . map nextstep $ toList locality where sort' = sortBy $ comparing cost cost ps = dist [last ps, goal] + sum (map dist $ segments ps) nextstep = (path ++) . return locality = let s = state `delete` unions (filter (member state) graph) in s `difference` (s `intersection` explored) graph = map fromList . concatMap nearby $ group pairs where group = groupBy ((==) `on` head) nearby = takeWhile ((< 280) . dist) . sortBy (comparing dist) nodes = take 64 . map cast $ zipWith pair (rand xres 0) (rand yres 1) where rand m = map (`mod` m) . unfoldr (liftM randomInt . Just) . pureMT -------------------------------------------------------------------------- [goal, start] = maximumBy (comparing dist) pairs pairs = filter (\[a,b] -> a /= b) $ liftM2 pair nodes nodes segments ps = zipWith pair ps (tail ps) dist [a,b] = sqrt $ (x'-x)^2 + (y'-y)^2 where ([x,y], [x',y']) = (cast a, cast b) pair a b = [a, b] cast [a,b] = [fromIntegral a, fromIntegral b] (xres, yres) = (1600, 900)