box.hs

{-# LANGUAGE NamedFieldPuns #-}
import Data.List ((\\))

type Grid = [[Char]]
third_d :: Int -> Int -> Int
third_d x y = head $ [1..3] \\ [x,y]

data Op = L | R | U | D deriving (Show)

data State = State {
  x :: Int,
  y :: Int,
  x_d :: Int,
  y_d :: Int,
  history :: [Op]
} deriving (Show)

instance Eq State where
  State{x=x1,y=y1,x_d=x_d1,y_d=y_d1} == State{x=x2,y=y2,x_d=x_d2,y_d=y_d2} =
    and [
      x1 == x2,
      y1 == y2,
      x_d1 == x_d2,
      y_d1 == y_d2
    ]

is_goal :: State -> Bool
is_goal s = s == State { x=9, y=8, x_d=2, y_d=3, history = []}

solve :: State -> [State]
solve origin = solve' [] [origin]
  where
    solve' :: [State] -> [State] -> [State]
    solve' _ []  = []
    solve' visited frontier
      | any is_goal frontier = filter is_goal frontier
      | otherwise =
        let
          frontier' = concatMap evolve frontier \\ visited
          visited' = frontier' ++ visited
        in
          solve' visited' frontier'

    evolve :: State -> [State]
    evolve s = filter is_valid $ map (move s) $ [L, R, U, D]

    move :: State -> Op -> State
    move State{x,y,x_d,y_d,history} L= State{
      x = x - (third_d x_d y_d),
      y = y,
      x_d = third_d x_d y_d,
      y_d = y_d,
      history = L:history
    }
    move State{x,y,x_d,y_d,history} R= State{
      x = x+x_d,
      y = y,
      x_d = third_d x_d y_d,
      y_d = y_d,
      history = R:history
    }
    move State{x,y,x_d,y_d,history} U = State{
      x = x,
      y = y - (third_d x_d y_d),
      x_d = x_d,
      y_d = third_d x_d y_d,
      history = U:history
    }
       move State{x,y,x_d,y_d,history} D= State{
      x = x,
      y = y+y_d,
      x_d = x_d,
      y_d = third_d x_d y_d,
      history = D:history
    }

is_valid :: State -> Bool
is_valid State{x, y, x_d, y_d} = and
  [is_free (i, j) | i <- [x..x+x_d-1], j <- [y..y+y_d-1]]

is_free :: (Int, Int) -> Bool
is_free (x,y) = True
  && x >= 1
  && x <= 10
  && y >= 1 && y <= 10
  && grid !! (y-1) !! (x-1) == '.'

grid :: Grid
grid =
  [
  "..........",
  "......0...",
  "..........",
  "..0.......",
  "........0.",
  ".....0....",
  "..........",
  "...0...0..",
  "..........",
  ".........."
  ]

init_state = State { x=1, y=1, x_d=2, y_d=3, history=[] }

main :: IO ()
main = do
  print . solve $ init_state
  print . length . history . head . solve $ init_state

-- $ runghc box.hs
-- [State {x = 9, y = 8, x_d = 2, y_d = 3, history = [D,R,R,D,D,L,U,R,U,U,R,R,D,D,D,L,L,U,L,L,D,L,U,R,R,D,R,R]}]
-- 28