Fifteen.hs

{-# LANGUAGE NoMonoLocalBinds, NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts, TypeApplications #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE Strict, DataKinds, LambdaCase #-}
{-# LANGUAGE TupleSections #-}
import Data.Word
import Data.Bits
import Data.Maybe
import Control.Effects.State
import Data.IntSet (IntSet)
import qualified Data.IntSet as Set
import Data.List.Split
import Data.List
import Data.Hashable
import GHC.Generics
import Data.PQueue.Prio.Min (MinPQueue)
import qualified Data.PQueue.Prio.Min as PQ
import qualified Data.Map as Map
import Data.Ord

data Board = Board
    { board :: {-# UNPACK #-} !Word64
    , slotX :: {-# UNPACK #-} !Word8
    , slotY :: {-# UNPACK #-} !Word8 }
    deriving (Eq, Ord, Read, Generic, Hashable)

fromNumberList :: Bits a => [a] -> a
fromNumberList l = foldl1 (.|.) $ zipWith shiftL l (reverse [0, 4..60])

solvedBoardData :: Word64
solvedBoardData = fromNumberList ([1..15] ++ [0])

getValue :: Word8 -> Word8 -> Word64 -> Word8
getValue x y b = fromIntegral $ (b `shiftR` fromIntegral (60 - (y * 4 + x) * 4)) .&. 15

setValue :: Word8 -> Word8 -> Word8 -> Word64 -> Word64
setValue x y v b = (complement (place 15) .&. b) .|.  place (fromIntegral v)
    where
    place = (`shiftL` fromIntegral (60 - (y * 4 + x) * 4))

moveTile :: Word8 -> Word8 -> Word8 -> Word8 -> Word64 -> Word64
moveTile x1 y1 x2 y2 b = setValue x2 y2 (getValue x1 y1 b) (setValue x1 y1 0 b)

data Move = L | R | U | D
    deriving (Eq, Ord, Show)

move :: Move -> Board -> Maybe Board
move L (Board b x y)
    | x == 3 = Nothing
    | otherwise = Just (Board (moveTile (x + 1) y x y b) (x + 1) y)
move R (Board b x y)
    | x == 0 = Nothing
    | otherwise = Just (Board (moveTile (x - 1) y x y b) (x - 1) y)
move U (Board b x y)
    | y == 3 = Nothing
    | otherwise = Just (Board (moveTile x (y + 1) x y b) x (y + 1))
move D (Board b x y)
    | y == 0 = Nothing
    | otherwise = Just (Board (moveTile x (y - 1) x y b) x (y - 1))

neighbors :: Board -> [(Board, Move)]
neighbors b = mapMaybe (\m -> (, m) <$> move m b) [L, R, U, D]

boardValue :: Board -> Int
boardValue =
    sum
    . zipWith (\(x, y) (a, b) -> abs (x - a) + abs (y - b)) coords
    . map (correct Map.!)
    . toList
    where
    coords = [(x, y) | y <- [0..3], x <- [0..3]]
    correct = Map.fromList $ zip ([1..15] ++ [0]) coords

type Visited = IntSet
type Q = MinPQueue Int (Board, [Move])

step :: MonadEffects '[State Visited, State Q] m => (Board, [Move]) -> m ()
step (b, ms) = do
    vis <- getState
    if Set.member (fromIntegral $ board b) vis then return ()
    else do
        setState (Set.insert (fromIntegral $ board b) vis)
        mapM_ (\(n, m) ->
            modifyState (PQ.insert (boardValue n + length ms + 1) (n, m : ms)))
            (neighbors b)

solve :: Board -> IO [Move]
solve init' = implementStateViaStateT @Q (PQ.singleton (boardValue init') (init', []))
    $ implementStateViaStateT @Visited Set.empty go
    where
    go = PQ.minView <$> getState @Q >>= \case
        Nothing -> error "No solution"
        Just ((b, ms), q) -> do
            setState q
            if board b == solvedBoardData then return ms
            else do
                step (b, ms)
                go

i :: Word64
i = fromNumberList [15, 14, 1, 6, 9, 11, 4, 12, 0, 10, 7, 3, 13, 8, 5, 2]

ib :: Board
ib = Board i 0 2

main :: IO ()
main = print =<< solve ib

toList :: Board -> [Word8]
toList (Board b _ _) = [getValue x y b | y <- [0..3], x <- [0..3]]

instance Show Board where
    show b = unlines $ map (intercalate "\t" . map show) $ chunksOf 4 (toList b)