NPuzzle.hs

{-
module level doc here
-}
module Main ( main )
where

import qualified Data.Map as Map
import Data.List
import Data.Maybe
import System.Random (RandomGen, getStdGen)
import System.Random.Shuffle (shuffle')
import qualified Graphics.Gloss as G
import Debug.Trace (trace)

{-# ANN module "HLint: ignore Use camelCase" #-}

-- = Synonims

-- | Size of the board
type Size = Int

type Position = (Int, Int)

-- | 'Node' represents a board state. @Position@ is the position of the blank,
-- and @Map.Map Position Int@ is a mapping from the board position to the number
-- on the position.
type Node = (Position, Map.Map Position Int)

-- | 'Path' represents a path to a 'Node'. We typically pattern match against
-- a 'Path' like this:
-- > (node:parent)
type Path = [Node]


-- = Helper functions

-- | Returns the blank's position.
get_blank :: Node -> Position
get_blank = fst

-- | Manhattan distance between two 'Position's.
manhattan_distance :: Position -> Position -> Int
manhattan_distance (i,j) (k,l) = abs (i - k) + abs (j - l)

-- | Returns adjacent positions.
adjacent :: Size -> Position -> [Position]
adjacent n (i,j) = filter valid_pos
                    [(i+1, j+1), (i+1, j-1), (i-1, j+1), (i-1, j-1)]
    where
        valid_coor m = m >= 1 && m <= n
        valid_pos (k,l) = valid_coor k && valid_coor l

-- | Computes the new 'Node' from the current 'Node' if the blank moves to
-- 'Position' @new_blank@.
next_node :: Node           -- ^ Current node
            -> Position     -- ^ Position blank will be moved to
            -> Node         -- ^ Resulting node
next_node node new_blank = (new_blank, new_mapping)
    where
        (old_blank, old_mapping) = node
        Just number_to_move = Map.lookup new_blank old_mapping
        new_mapping = Map.insert old_blank number_to_move $
                        Map.delete new_blank old_mapping


-- = Main functions

-- | Find the optimal sequence of moves to solve the puzzle.
solve :: Size
        -> Node     -- ^ Initial state
        -> Path     -- ^ Optimal path to the goal state
solve size state = solve' size [] [[state]]

-- | Handles A* informed search. If there is a solution among @new_nodes@,
-- returns that solution.
-- Otherwise add @new_nodes@ to the @frontier@ and continue search.
solve' :: Size
        -> [Path]   -- ^ Frontier
        -> [Path]   -- ^ Paths to nodes resulting from the last expansion
        -> Path     -- ^ Optimal path to the goal state
solve' size frontier new_nodes = fromMaybe
                        (solve'' size frontier')
                        (find isSolution new_nodes)
    where
        isSolution path = evaluate_h size path == 0
        frontier' = new_nodes ++ frontier

-- | Handles A* informed search. Expands the node with the smallest evaluation
-- and adds nodes resulting from
-- that expansion to the @frontier@.
solve'' :: Size
        -> [Path]   -- ^ Frontier
        -> Path     -- ^ Optimal path to the goal state
solve'' size frontier = trace (show new_nodes) $ solve' size frontier' new_nodes
    where
        compare_evaluations path1 path2 = evaluate size path1 `compare`
                                            evaluate size path2
        (to_expand:frontier') = sortBy compare_evaluations frontier
        new_nodes = expand size to_expand

-- | Evaluate the node. Evaluation @f(n)@ of the node @n@ is @g(n) * h(n)@,
-- where @g(n)@ is the length of the path from the initial node to the node @n@
-- and @h(n)@ is the Manhattan distance between the node @n@ and the goal node.
-- Note: our evaluation is consistent and was obtained by relaxing the problem.
evaluate :: Size
            -> Path     -- ^ Path pointing to the node
            -> Int      -- ^ Evaluation is an integer
evaluate _ [] = error "Calling 'evaluate' with an empty 'Path'"
evaluate n path = evaluate_g path + evaluate_h n path

evaluate_h :: Size
            -> Path     -- ^ Path pointing to the node
            -> Int      -- ^ Evaluation is an integer
evaluate_h _ [] = error "Calling 'evaluate' with an empty 'Path'"
evaluate_h n (node:_) =  manhattan_distance blank blank_goal +
                            (sum . map manhattan_for_i . Map.toList $ mapping)
    where
        (blank, mapping) = node
        manhattan_for_i (pos, i) = manhattan_distance pos (goal_position i)
        goal_position i = (i `quot` n, i `mod` n)
        blank_goal = (n, n)

-- | Evaluate g
evaluate_g :: Path -> Int
evaluate_g = length

{-# ANN expand "HLint: ignore Use map once" #-}
-- | Expand the node pointed to by 'Path'.
expand :: Size
        -> Path     -- ^ Path to the node to be expanded.
        -> [Path]   -- ^ Paths to nodes resulting from the expansion.
expand _ [] = error "Calling 'expand' with an empty 'Path'"
expand n (node:parent) = map (:node:parent) . filter (`notElem` parent)
                            . map (next_node node) . adjacent n $ get_blank node


-- = Generate initial node

-- | Generates a random initial state on a board of size n.
make_start_state :: (RandomGen g) => g -> Size -> Node
make_start_state gen n = (blank, mapping')
    where
        largest_number = n * n - 1
        shuffled_number_list = shuffle' [0..largest_number] (n * n) gen
        positions = [ (i,j) | i <- [1..n], j <- [1..n] ]
        mapping = Map.fromList $ zip positions shuffled_number_list
        Just blank = lookup_by_val mapping positions 0
        mapping' = Map.delete blank mapping

-- | Returns the key mapped to the value @val@.
lookup_by_val :: (Ord k, Eq a)
                => Map.Map k a      -- ^ map
                -> [k]              -- ^ list of the map's keys
                -> a                -- ^ value searched for
                -> Maybe k          -- ^ key mapped to the value
lookup_by_val _ [] _ = Nothing
lookup_by_val mapping (k:ks) val = if Map.lookup k mapping == Just val
                                    then Just k
                                    else lookup_by_val mapping ks val


-- = main

main :: IO ()
main = do
    gen <- getStdGen
    let
        size = 3
        start_state = make_start_state gen size
        solution = reverse $ solve size start_state
        -- solution = reverse $ take 60 $ solve 2 start_state
        -- solution = [start_state]
        d = G.InWindow "Game of Life" (1000, 1000) (10, 10)
        bg = G.makeColorI 35 35 35 255
        next_frame _ _ path = if length path == 1 then path else tail path
    G.simulate d bg 2 solution to_picture next_frame
    return ()

to_picture :: Path -> G.Picture
to_picture [] = undefined
to_picture (state:_) = G.color G.white $ G.translate (-275.0) (-275.0)
                        $ G.pictures $ map number_to_pic (Map.toList mapping)
    where
        mapping = snd state
        number_to_pic ((i,j), num) = G.translate
                                        (fromIntegral (150 * i))
                                        (fromIntegral (150 * j))
                                    $ G.scale 1 1
                                    $ G.text (show num)


-- There is someting wrong with the program logic; time to learn Haskell
-- testing and debugging

-- = Test values

--s :: Node
--s = ((2,3), Map.fromList
--        [ ((1,2), 3)
--        , ((1,2), 7)
--        , ((1,3), 5)
--        , ((2,1), 4)
--        , ((2,2), 1)
--        , ((3,1), 6)
--        , ((3,2), 2)
--        , ((3,3), 0) ] )