View source for Haskell Quiz/Knight's Travails/Solution LukePlant

[[Category:Haskell Quiz solutions|Knight's Travails]]
[[Category:Code]]

<haskell>
{-
Solution to "Knight's travails"

by Luke Plant, http://lukeplant.me.uk/

Confession: I got quite a bit of help from the Ruby solutions.
Notes: 1) I'm a total Haskell newbie, this could probably be lots better
       2) It can be used as a complete command line program, otherwise
          the main entry point is 'solve'

Interesting extras:
   Unique positions on board paired with the maximum number of jumps it 
   takes to go from that position to any position on the board:

   [(Pos x y, length $ allNeighbours [Pos x y] []) | x <- [0..3], y <- [0..x]]

-}

import Control.Monad (guard)
import Data.List (nub)
import System.Environment (getArgs)
import System.Exit (exitFailure)

-- Pretty printing:
data Position = Pos Int Int deriving (Eq)

instance Show Position where
    show (Pos x y) = toEnum (x + fromEnum 'a') :
                     toEnum (y + fromEnum '1') : []
    showList ps = \x -> "[" ++ (unwords $ map show ps) ++ "]" ++ x

parsePosition s = 
    case s of (x:y:[]) -> let x' = fromEnum x - fromEnum 'a'
                              y' = fromEnum y - fromEnum '1'
                              ans = Pos x' y'
                          in if validPosition ans
                             then ans
                             else invalid s
              otherwise -> invalid s
  where invalid s = error ("'" ++ s ++ "' is not a valid position.")
                                
-- Position is index from 0 to 7 on the board
validPosition (Pos x y) = let inrange z = 0 <= z && z < 8
                          in inrange x && inrange y

-- Calculate the Knight neighbours of a position, avoiding forbidden squares
knightjumps = [(-2,-1),(-2,1),(-1,-2),(-1,2),(1,-2),(1,2),(2,-1),(2,1)] 

neighbours (Pos x y) forbidden = do
  (dx, dy) <- knightjumps
  let newpos = Pos (x + dx) (y + dy)
  guard (newpos `notElem` forbidden && validPosition newpos)
  return newpos

isNeighbour (Pos x1 y1) (Pos x2 y2) = (x1 - x2, y1 - y2) `elem` knightjumps

-- All the neighbours of given start positions, returned
-- as a list of lists -- first item is nearest set of neighbours etc.
allNeighbours :: [Position] -> [Position] -> [[Position]]
allNeighbours startps forbidden = 
    let newps = nub $ concatMap (\p -> neighbours p forbidden) startps
    in if newps == []
       then []
       else [newps] ++ allNeighbours newps (startps ++ forbidden)

-- Search through the neighbours we have found,
-- and if we find our target, calculate (any) path back to first item
routeToPosition :: [[Position]] -> Position -> Maybe [Position]
routeToPosition ps item = routeToPosition' ps item []

-- helper which carries inverted list of 'used' [Position] 
-- so we can go back and find the route:
routeToPosition' [] _ _             = Nothing
routeToPosition' (ps:pss) item used = 
    if item `elem` ps
    then Just $ (reverse $ item : searchForPath used item)
    else routeToPosition' pss item (ps:used) -- invert the 'used' list as we go
  where
    searchForPath [] _ = []
    searchForPath (ps:pss) item = 
        let parent = head $ filter (isNeighbour item) ps
        in parent : searchForPath pss parent

solve :: Position -> Position -> [Position] -> Maybe [Position]
solve start end forbidden = let all = allNeighbours [start] forbidden
                            in routeToPosition all end

-- Main input and output
usage = "Usage: knight_travails startpos endpos [forbidden positions]"

main = do
  args <- getArgs
  if length args < 2
     then do putStrLn ("Insufficient arguments.\n\n" ++ usage)
             exitFailure
     else let start = parsePosition (args!!0)
              end   = parsePosition (args!!1)
              forbidden = map parsePosition (drop 2 args)
              solution = solve start end forbidden
          in case solution of
               Nothing -> do { putStrLn "No solutions"}
               Just ps -> do { print ps } 

</haskell>