import Data.Array(Array, (!), (//)) import qualified Data.Array as A import Data.List(intercalate, find, delete, mapAccumL, nub, sortBy) import Data.Map(Map) import qualified Data.Map as M import Data.Sequence(Seq, (|>), Seq((:|>))) import qualified Data.Sequence as Seq import Data.Maybe(fromJust) data Color = Brn | Gry | Ora | Pnk | Grn | LGn | DGn | LBl | DBl | Red | Yel | Pur | E00 -- Represents empty. I know this is a violation of type principles but -- it really makes it a lot simpler to deal with deriving (Eq, Ord, Show) -- First @Int@ is the number of stacks and second is the height of each stack data Board = Board { nStacks :: Int, stackSize :: Int, board :: Array (Int, Int) Color } deriving (Eq, Ord) newBoard :: Int -> Int -> [Color] -> Board newBoard nStacks stackSize = validate . Board nStacks stackSize . A.listArray bounds where bounds = ((0, 0), (nStacks - 1, stackSize - 1)) validate b | valid b = b | otherwise = error "Invalid board definition" cells :: Board -> [[Color]] cells (Board ns ss a) = map (\sI -> map (\cI -> a ! (sI, cI)) $ width ss) $ width ns -- Using this idiom all the time so thought it would be better to reuse width :: Int -> [Int] width x = [0..x-1] valid :: Board -> Bool valid b@(Board ns ss a) = and $ map validStack (width ns) where validStack sI = all (== E00) $ dropWhile (/= E00) cs where cs = map (\cI -> a ! (sI, cI)) (width ss) -- Gets the color at the top of a stack top :: Board -> Int -> Color top b = fst . pop b -- Removes a color from top of a stack pop :: Board -> Int -> (Color, Board) pop b@(Board _ ss a) sI = fmap update . maybe (get 0) id $ find ((/= E00) . fst) cs where get cI = (a ! (sI, cI), cI) width = [ss-1,ss-2..1] -- goes backwards of course cs = map get width update cI = b { board = a // [ ((sI, cI), E00) ] } -- Pushes a color on top of a stack. You'll get an out of range exception if you -- try to push on to a stack that is already full push :: Board -> Int -> Color -> Board push b@(Board _ _ a) sI c = f . maybe 0 (+1) $ highest b sI where f cI = b { board = a // [ ((sI, cI), c) ] } -- Gets the cell index of the highest color in a stack highest :: Board -> Int -> Maybe Int highest (Board _ ss a) sI = fmap snd . find ((/= E00) . fst) $ map get [ss-1,ss-2..0] where get cI = (a ! (sI, cI), cI) -- Whether a stack is empty empty :: Board -> Int -> Bool empty b sI = top b sI == E00 -- Whether a stack is full full :: Board -> Int -> Bool full (Board _ ss a) sI = a ! (sI, ss - 1) /= E00 chunksOf :: Int -> [a] -> [[a]] chunksOf _ [] = [] chunksOf n xs = chunk : chunksOf n rest where (chunk, rest) = splitAt n xs instance Show Board where show (Board ns ss arr) = concat ["newBoard ", show ns, " ", show ss, " [\n ", stksS, " ]"] where stks = chunksOf ss (A.elems arr) stksS = intercalate ",\n " $ map (intercalate ", " . map show) stks type Move = (Int, Int) legalMoves :: Board -> [Move] legalMoves b@(Board ns _ _) = [ (src, dest) | src <- width ns, dest <- width ns, src /= dest, not $ empty b src, not $ full b dest, top b src == top b dest || empty b dest ] -- Make a move on the board. Assumes the move is legal move :: Board -> Move -> Board move b (src, dest) = push b' dest c where (c, b') = pop b src -- Normal victory occurs when each stack is either completely empty or -- completely filled with balls of only 1 color. There's also a looser -- definition of victory where stacks don't have to be full but just either -- empty or contain only one color besides any emptiness. The looser definition -- can be required if initial board states don't have balls filled up to the -- tops of the stacks but the normal one restricts to boards that look a lot -- more finished wonNormal, wonLoose :: Board -> Bool wonNormal = all ok . cells where ok (c:cs) = all (== c) cs wonLoose = all ok . cells where ok (c:cs) = all (== c) $ filter (/= E00) cs -- The gist of the solver is as follows: -- With a game: -- Won?: -- Return moves taken to get there -- Can't move? || Seen this board configuration before?: -- Previous board state available?: -- Go back to previous game state -- Use a different move -- Otherwise: -- Couldn't solve -- Otherwise: -- Make the first legal move unless told to use a different one -- This is a brute force unintelligent solving algorithm but should also be -- very reliable type Stack a = [a] data Project = Project { history :: Stack Board, movesTaken :: Seq Move, unusedMoves :: Map Board (Stack Move) } deriving Show solve :: Board -> Either Project (Seq Move, Board) solve = f . initProject where f pj = case step pj of Right True -> Right $ (movesTaken pj, head $ history pj) Right False -> Left pj Left pj' -> f pj' initProject :: Board -> Project initProject b = Project [b] Seq.empty $ M.singleton b (legalMoves b) step :: Project -> Either Project Bool step (Project (b:prev) msT uums) | wonNormal b = Right True | wrongTurn && null prev = Right False | wrongTurn = Left $ Project prev (seqPop msT) uums | otherwise = let (m', uums') = mapPop b uums b' = move b m' f Nothing = Just . delete (swap m') . rejectReversal . reject (dumbMove b') $ legalMoves b' f x = x in Left $ Project (b':b:prev) (msT |> m') (M.alter f b' uums') where wrongTurn = maybe False null $ M.lookup b uums seqPop seq = Seq.take (Seq.length seq - 1) seq swap (a,b) = (b,a) rejectReversal moves = case msT of _ :|> move -> delete (swap move) moves _ -> moves mapPop :: Ord k => k -> Map k [a] -> (a, Map k [a]) mapPop k m = case M.lookup k m of Just (a:as) -> (a, M.insert k as m) -- acts as update despite "insert" _ -> error "Couldn't pop from map :'(" reject p = filter (not . p) -- put it in the prelude already -- This is a really important optimization that you don't want to be without dumbMove :: Board -> Move -> Bool dumbMove (Board ns ss a) (src, dest) = -- Moves from a stack of only one color where there's more balls than the dest length (nub $ cells src) == 1 && length (cells src) > length (cells dest) where cells sI = reject (== E00) . map (\cI -> a ! (sI, cI)) $ width ss -- Not using this: seems to degrade results and performance. Perhaps because of -- how long the sort itself takes moveSort :: Board -> [Move] -> [Move] moveSort b = sortBy f where f (src1,dest1) (src2,dest2) = h src2 `compare` h src1 h = maybe 0 id . highest b -- Might revive something like this later: {- dumbMove :: Board -> Move -> Bool dumbMove (Board _ 4 a) (src, dest) = or [ "a " --> " ", "aa " --> "a ", "aa " --> " ", "aaa " --> "a ", "aaa " --> " ", match src "aaaa" ] where srcPatt --> destPatt = match src srcPatt && match dest destPatt match sI patt = and . snd . mapAccumL f M.empty $ zip patt cells where cells = map (\cI -> a ! (sI, cI)) (width 4) f m (' ', color) = (m, color == E00) f m (char, E00) = (m, False) f m (char, color) = case M.lookup char m of Nothing -> (M.insert char color m, True) -- creates bind Just bind -> (m, bind == color) -- uses bind dumbMove _ _ = False -- only supporting dumb identification for stack sizes of 4 -} -- For debugging: stepN :: Int -> Board -> Either Project Bool stepN n = f n . Left . initProject where f 0 x = x f n x = case x of Left proj -> f (n - 1) (step proj) x -> x main = do let (Right (solution, _)) = solve special1 print $ length solution print $ fmap (\(a,b) -> (a+1,b+1)) solution -- Test Boards ----------------------------------------------------------------- -- Visually the bottom of a stack appears on the left as it is numerically lower -- in the array index lvl7 = newBoard 7 4 [ Ora, Red, Ora, LGn, Ora, Red, DBl, DBl, Ora, DBl, Pnk, Pnk, DBl, Red, Pnk, LGn, Pnk, LGn, Red, LGn, E00, E00, E00, E00, E00, E00, E00, E00] special1 = newBoard 14 5 [ Brn, DGn, DBl, DBl, LGn, LBl, Ora, Pnk, LGn, Brn, DGn, Pur, Brn, Yel, Red, DBl, Red, Ora, Pur, Grn, Yel, Brn, Ora, LGn, Brn, Gry, Gry, Pur, Red, DBl, Ora, DGn, Pnk, Pur, LGn, Red, LGn, Pnk, LBl, LBl, Red, Ora, Grn, DBl, Pur, Gry, Grn, Pnk, LBl, Grn, LBl, DGn, Yel, Grn, Gry, Yel, Gry, Pnk, Yel, DGn, E00, E00, E00, E00, E00, E00, E00, E00, E00, E00 ] bSimp1 = newBoard 2 2 [ Red, E00, Red, E00 ] bSimp2 = newBoard 3 3 [ Red, E00, E00, Red, E00, E00, Red, E00, E00 ] bSimp3 = newBoard 4 4 [ Red, E00, E00, E00, Red, E00, E00, E00, Red, E00, E00, E00, Red, E00, E00, E00 ] bSimp4 = newBoard 3 3 [ Yel, Yel, Red, Red, Red, Yel, E00, E00, E00 ] bSimp5 = newBoard 3 4 [ Yel, Yel, Red, Red, Red, Red, Yel, Yel, E00, E00, E00, E00 ] bSimp6 = newBoard 4 4 [ Yel, Yel, Red, Pur, Yel, Yel, Red, Pur, Pur, Pur, Red, Red, E00, E00, E00, E00 ] bUnsolv1 = newBoard 4 4 [ Yel, Yel, Red, Pur, Yel, Yel, Red, Pur, Pur, Pur, Red, Red, E00, E00, E00, E00 ]