Added solution to rubyquiz 27

AStar.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module AStar where
+
+import qualified Data.PQueue.Prio.Min as PQ
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Data.List (foldl')
+import Data.Maybe (fromJust)
+
+-- A node in the search
+class (Ord a, Ord b, Num b, Bounded b) => SearchNode a b where
+  -- get the next search node and the cost to reach to it from the current node
+  nextNode ::  a -> [(a, b)]
+
+-- A* algorithm: Find a path from initial node to goal node using a heuristic function.
+-- Returns Nothing if no path found. Else returns Just (path cost, path).
+astar :: SearchNode a b => a ->  a -> (a -> a -> b) -> Maybe (b, [a])
+astar initNode goalNode hueristic =
+  astar' (PQ.singleton (hueristic initNode goalNode) (initNode, 0))
+         S.empty (M.singleton initNode 0) M.empty
+  where
+    -- pq: open set, seen: closed set, tracks: tracks of states
+    astar' pq seen gscore tracks
+      -- If open set is empty then search has failed. Return Nothing
+      | PQ.null pq = Nothing
+      -- If goal node reached then construct the path from the tracks and node
+      | node == goalNode = Just (gcost, findPath tracks node)
+      -- If node has already been seen then discard it and continue
+      | S.member node seen = astar' pq' seen gscore tracks
+      -- Else expand the node and continue
+      | otherwise = astar' pq'' seen' gscore' tracks'
+      where
+        -- Find the node with min f-cost
+        (node, gcost) = snd . PQ.findMin $ pq
+
+        -- Delete the node from open set
+        pq' = PQ.deleteMin pq
+
+        -- Add the node to the closed set
+        seen' =  S.insert node seen
+
+        -- Find the successors (with their g and h costs) of the node
+        -- which have not been seen yet
+        successors = filter (\(s, g, _) ->
+                                not (S.member s seen') &&
+                                  g < M.findWithDefault maxBound s gscore)
+                     $ successorsAndCosts node gcost
+
+        -- Insert the successors in the open set
+        pq'' = foldl' (\q (s, g, h) -> PQ.insert (g + h) (s, g) q) pq' successors
+
+        gscore' = foldl' (\m (s, g, _) -> M.insert s g m) gscore successors
+
+        -- Insert the tracks of the successors
+        tracks' = foldl' (\m (s, _, _) -> M.insert s node m) tracks successors
+
+    -- Finds the successors of a given node and their costs
+    successorsAndCosts node gcost =
+      map (\(s, g) -> (s, gcost + g, hueristic s goalNode)) . nextNode $ node
+
+    -- Constructs the path from the tracks and last node
+    findPath tracks node =
+      if M.member node tracks
+      then findPath tracks (fromJust . M.lookup node $ tracks) ++ [node]
+      else [node]

KnightsTravails.hs

@@ -0,0 +1,95 @@
+{-
+  A solution to rubyquiz 27 (http://rubyquiz.com/quiz27.html).
+
+  Given a standard 8 x 8 chessboard where each position is indicated in algebraic
+  notation (with the lower left corner being a1), design a script that accepts
+  two or more arguments.
+
+  The first argument indicates the starting position of the knight. The second
+  argument indicates the ending position of the knight. Any additional arguments
+  indicate positions that are forbidden to the knight.
+
+  Return an array indicating the shortest path that the knight must travel to
+  get to the end position without landing on one of the forbidden squares.
+  If there is no valid path to the destination return nil.
+
+  Usage: ./KnightsTravails start_pos target_pos [blocked_pos]*
+
+  Copyright 2012 Abhinav Sarkar <abhinav@abhinavsarkar.net>
+-}
+
+{-# LANGUAGE MultiParamTypeClasses, RecordWildCards #-}
+
+module KnightsTravails where
+
+import qualified Data.Set as S
+import AStar
+import Data.List (elemIndex)
+import Data.Maybe (fromJust)
+import Control.Arrow (second)
+import System.Environment (getArgs)
+
+-- A square on the chess board
+type Square = (Int, Int)
+
+-- A chess board with the knight's current position and a set of blocked squares
+data Board = Board { knightPos :: Square, blockedSquares :: S.Set Square }
+             deriving (Ord, Eq)
+
+-- Converts a string in chess notation to a square. eg. a1 -> (1,1)
+fromNotation :: String -> Square
+fromNotation (x : y) = (fromJust (x `elemIndex` ['a'..'h']) + 1, read y)
+
+-- Converts a square to a string in chess notation. eg. (1,1) -> a1
+toNotation :: Square -> String
+toNotation (x, y) = ((['a'..'h'] !! (x - 1)) : "") ++ show y
+
+-- Checks if a string is a valid chess notation
+isValidNotation notation =
+  and [length notation == 2,
+       head notation `elem` ['a'..'h'],
+       last notation `elem` ['1'..'8']]
+
+-- Makes Board an instance of SearchNode for astar to work
+instance SearchNode Board Int where
+  -- Finds the next possible board configurations for one knight's move.
+  -- Move cost is one.
+  nextNode board@(Board {..}) =
+    zip
+      (map (\pos -> board { knightPos = pos })
+       . filter isValidMove
+       . map (\(x, y) -> (fst knightPos + x, snd knightPos + y))
+       $ moves)
+      (repeat 1)
+    where
+      moves = [(1,2), (1,-2), (-1,2), (-1,-2), (2,1), (2,-1), (-2,1), (-2,-1)]
+      isValidMove (x, y) =
+        and [x > 0, x < 9, y > 0, y < 9, not $ (x, y) `S.member` blockedSquares]
+
+knightAstar heuristic blockedSquares start target =
+  fmap (second (map knightPos))
+  $ astar (Board start blockedSquares) (Board target blockedSquares) heuristic
+
+-- Finds a path from a start square to an end square using BFS
+bfsSearch :: S.Set Square -> Square -> Square -> Maybe (Int, [Square])
+bfsSearch = knightAstar (\_ _ -> 0)
+
+-- Finds a path from a start square to an end square using AStar with
+-- half of the max of coordinate deltas as the heuristic
+astarSearch :: S.Set Square -> Square -> Square -> Maybe (Int, [Square])
+astarSearch =
+  knightAstar (\(Board (x1,y1) _) (Board (x2,y2) _) ->
+                  max (abs (x1-x2)) (abs (y1-y2)) `div` 2)
+
+main = do
+  args <- getArgs
+  if length args < 2
+  then error "Usage: ./KnightsTravails start_pos target_pos [blocked_pos]*"
+  else if any (not . isValidNotation) args
+       then error "Invalid board position"
+       else let
+         (start : target : blocked) = args
+       in case astarSearch (S.fromList . map fromNotation $ blocked)
+                           (fromNotation start) (fromNotation target) of
+          Just (_, path) -> putStrLn . unwords . map toNotation $ path
+          Nothing -> putStrLn "No path found"