diff --git a/AStar.hs b/AStar.hs new file mode 100644 index 0000000..7f5ba2c --- /dev/null +++ b/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] \ No newline at end of file diff --git a/KnightsTravails.hs b/KnightsTravails.hs new file mode 100644 index 0000000..11f7271 --- /dev/null +++ b/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 +-} + +{-# 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" \ No newline at end of file