import qualified SOEGraphics as G

-- ------ Depth First Search ------
type Graph n = [(n, [n])]

mkGraph :: Eq n => [(n, n)] -> Graph n
mkGraph [] = []
mkGraph ((n1, n2) : ns) = addEdge (n1, n2) (mkGraph ns)
	where addEdge (x, y) [] = [(x, [y])]
	      addEdge (x, y) ((z, zs) : ws) =
				if (x==z) then ((z, y:zs) : ws)
				else ((z, zs) : (addEdge (x, y) ws))

adjacent :: Eq n => Graph n -> n -> [n]
adjacent [] x = error "node does not exist"
adjacent ((x, xs) : ys) z = if (x==z) then xs else adjacent ys z

nodes :: Eq n => Graph n -> [n]
nodes [] = []
nodes ((x, xs) : ys) = x : (nodes ys)

edges :: Eq n => Graph n -> [(n, n)]
edges [] = []
edges (y : ys) = (myEdges y) ++ (edges ys)
	where myEdges (n, []) = []
	      myEdges (n, x:xs) = (n, x) : (myEdges (n, xs))

depthFirstSearch :: Eq n => (n -> [n]) -> (n -> Bool) -> n -> [n]
depthFirstSearch succNodes goalTest startNode
    = dfs succNodes goalTest [startNode] []
    where dfs :: Eq n => (n -> [n]) -> (n -> Bool) -> [n] -> [n] -> [n]
          dfs _ _ [] _ = []
          dfs succ goal (node : ns) path
            | goal node = node : path
            | otherwise = let answer = (dfs succ goal (succ node) (node:path))
                           in if answer == []
                              then (dfs succ goal ns path)
                              else answer
-- We take the advantage of the fact
-- that our search space forms a tree,
-- which saves us the trouble from maintaining a "visited nodes" list.

-- ------ Game: Frogs and Toads ------
-- game configurations: # of frogs
nFrogs :: Int
nFrogs = 1
nToads :: Int
nToads = 1
nBoard :: Int
nBoard = nFrogs + nToads + 1

-- represent frogs/toads as integers
frog :: Int
frog = 1
toad :: Int
toad = -1
space :: Int
space = 0

-- build infinite streams of frogs & toads
frogs :: [Int]
frogs = 1 : frogs
toads :: [Int]
toads = (0-1) : toads

-- representation of node
type Node = [Int]

-- get the nth element of a list
nth :: Int -> [a] -> a
nth 0 (h : _) = h
nth n (_ : t) = nth (n-1) t

-- get the position of the vacant square in a board
getSpace :: Node -> Int
getSpace (h : t)
       | (h==space) = 0
       | (h/=space) = 1+(getSpace t)

-- change the value of a square in a board
assign :: Int -> Node -> Int -> Node
assign 0 (h : t) i = (i : t)
assign n (h : t) i = h : (assign (n-1) t i)

-- exchange the values of two squares in a board
exchange :: Int -> Int -> Node -> Node
exchange l r n = assign r (assign l n nr) nl
   where nl = nth l n
         nr = nth r n

-- start node
start :: Node
start = (take nFrogs frogs) ++ [space] ++ (take nToads toads)

-- goal node
goal :: Node
goal = (take nToads toads) ++ [space] ++ (take nFrogs frogs)

-- generate possible moves
succs :: Node -> [Node]
succs nd = concat [nFrogSlide, nFrogJump, nToadSlide, nToadJump]
       where pos = getSpace nd
             nFrogSlide = if (pos >= 1) && (nth (pos-1) nd == frog)
                          then [exchange (pos-1) pos nd] else []
             nFrogJump  = if (pos >= 2) && (nth (pos-2) nd == frog)
                                        && (nth (pos-1) nd == toad)
                          then [exchange (pos-2) pos nd] else []
             nToadSlide = if (pos < nBoard-1) && (nth (pos+1) nd == toad)
                          then [exchange pos (pos+1) nd] else []
             nToadJump  = if (pos < nBoard-2) && (nth (pos+1) nd == frog)
                                              && (nth (pos+2) nd == toad)
                          then [exchange pos (pos+2) nd] else []

-- find the solution
solution :: [Node]
solution = reverse (depthFirstSearch succs (==goal) start)

-- ------ SOEGraphics Demonstration ------
-- pixels per square
pps = 30 :: Int
halfpps = 15 :: Int

-- rendering a square
renderSquare :: G.Window -> Int -> G.Color -> IO ()
renderSquare w i c = do G.drawInWindow w
                          (G.withColor c (G.polygon (tail shape)))
                        G.drawInWindow w
                          (G.withColor G.White (G.polyline shape))
    where adjust i (x, y) = ((i+1)*pps+x, pps+y)
          shape = map (adjust i) [(0,0), (pps,0), (pps,pps), (0,pps), (0,0)]

-- rendering a node
renderNode :: G.Window -> Int -> Node -> IO ()
renderNode w _ []      = return ()
renderNode w i (h : t) = do renderSquare w i c
                            renderNode w (i+1) t
    where c = if h==frog then G.Green
              else if h==toad then G.Blue
              else G.White

-- rendering an indicator which shows what the next move is
renderIndicator :: G.Window -> Node -> [Node] -> G.Color -> IO ()
renderIndicator w n1 [] c      = return ()
renderIndicator w n1 (n2 : _) c = do G.drawInWindow w
                                       (G.withColor c (G.polyline shape))
    where diff = zipWith (==) n1 n2
          getFalsePos [] count = []
          getFalsePos (h : t) count = if h then getFalsePos t (count+1)
                                      else count : (getFalsePos t (count+1))
          adjust x = ((x+1)*pps+halfpps, 2*pps+halfpps)
          ends = getFalsePos diff 0
          shape' = map adjust ends
          end1 = head ends
          end2 = head (reverse ends)
          adjustend e = ((e+1)*pps+halfpps, 2*pps)
          shape = (adjustend end1) : shape' ++ [adjustend end2]

-- rendering moves
renderMoves :: G.Window -> [Node] -> IO ()
renderMoves w []      = do G.closeWindow w
renderMoves w (h : t) = do (renderNode w 0 h)
                           renderIndicator w h t G.Red
                           k <- G.getKey w
                           renderIndicator w h t G.Black
                           renderMoves w t

-- game show
gameShow :: IO ()
gameShow = G.runGraphics $
           do w <- G.openWindow "Frogs and Toads" ((nBoard+2)*pps, 3*pps)
              renderMoves w solution