diff options
| -rw-r--r-- | solitairesimulator2015.hs | 154 |
1 files changed, 98 insertions, 56 deletions
diff --git a/solitairesimulator2015.hs b/solitairesimulator2015.hs index 76e686f..2a55969 100644 --- a/solitairesimulator2015.hs +++ b/solitairesimulator2015.hs @@ -43,6 +43,7 @@ import System.IO import Data.Char import Debug.Trace import Control.Monad (ap) +import Data.Maybe (mapMaybe, catMaybes) data Direction = North | East | South | West deriving (Eq, Show) @@ -55,6 +56,8 @@ type Pegs = [Peg] data Board = Board Pegs +data Move = Move Peg Direction + -- Board printing stuff showpeg :: Board -> Row -> Col -> String showpeg (Board pegs) r c = if (c, r) `elem` pegs then "o" else "." @@ -69,68 +72,107 @@ showrow b r | r <= 3 || r >= 7 = " " ++ foldr (++) "" (map (showpeg b r) [4,5 instance Show Board where show board = foldr (++) "" $ map (showrow board) [1..9] +instance Show Move where + show (Move peg dir) = "Move " ++ show peg ++ " " ++ show dir + + movepeg :: Peg -> Direction -> Peg movepeg (c, r) dir | dir == North = (c, r-1) | dir == East = (c+1, r) | dir == South = (c, r+1) | dir == West = (c-1, r) -nextpeg :: Board -> Peg -> Direction -> Maybe Peg -nextpeg (Board pegs) peg dir | dir == North && r == 1 = Nothing - | dir == North && r == 4 && (c < 4 || c > 6) = Nothing - | dir == East && c == 9 = Nothing - | dir == East && c == 6 && (r < 4 || r > 6) = Nothing - | dir == South && r == 9 = Nothing - | dir == South && r == 6 && (c < 4 || c > 6) = Nothing - | dir == West && c == 1 = Nothing - | dir == West && c == 4 && (r < 4 || r > 6) = Nothing - | otherwise = --trace ("PEG " ++ show peg ++ " " ++ show dir) - Just $ movepeg peg dir - where (c, r) = peg +nextpeg :: Board -> Move -> Maybe Peg +nextpeg (Board pegs) (Move peg dir) | dir == North && r == 1 = Nothing + | dir == North && r == 4 && (c < 4 || c > 6) = Nothing + | dir == East && c == 9 = Nothing + | dir == East && c == 6 && (r < 4 || r > 6) = Nothing + | dir == South && r == 9 = Nothing + | dir == South && r == 6 && (c < 4 || c > 6) = Nothing + | dir == West && c == 1 = Nothing + | dir == West && c == 4 && (r < 4 || r > 6) = Nothing + | otherwise = --trace ("PEG " ++ show peg ++ " " ++ show dir) + Just $ movepeg peg dir + where (c, r) = peg -- jump -jumppeg :: Board -> Peg -> Direction -> Maybe Board -jumppeg b peg dir | npeg == Nothing = --trace ("OOB " ++ show peg ++ " " ++ show dir) - Nothing - | npeg2 == Nothing = --trace ("OOB2" ++ show peg ++ " " ++ show dir) - Nothing - -- valid jump: next hole occupied, but the one after is free - | peg `elem` pegs && np `elem` pegs && not (np2 `elem` pegs) = --trace ("OK " ++ show peg ++ " " ++ show dir) - Just $ jumppeg_possible b peg dir - | otherwise = --trace ("Illegal " ++ show peg ++ " " ++ show dir) - Nothing - where npeg = nextpeg b peg dir - Just np = npeg - npeg2 = nextpeg b np dir - Just np2 = npeg2 - Board pegs = b - -jumppeg_possible :: Board -> Peg -> Direction -> Board -jumppeg_possible (Board pegs) peg dir = Board (removepeg ++ [npeg2]) - where removepeg = filter ((/=) peg) $ -- remove jumping peg from origin - filter ((/=) npeg) pegs -- remove peg being jumped over - npeg = movepeg peg dir - npeg2 = movepeg npeg dir - -testboard = Board [(4,1), (5,1), (4,2), (6,1)] - -data Move = Move Peg Direction Board -instance Show Move where - show (Move peg dir b) = "Move " ++ show peg ++ " " ++ show dir ++ " gives\n" ++ show b - -try_move :: Board -> Peg -> Direction -> Maybe Move -try_move b peg dir = fmap (Move peg dir) brd - where brd = jumppeg b peg dir - Just newboard = brd - -allmoves :: Board -> [Move] -allmoves board = [x | Just x <- maybeboards] - where all_dirs = [North, West, South, East] - Board pegs = board - maybeboards = [try_move board p d | p <- pegs, d <- all_dirs] - -pr board = putStrLn ("Welcome!\n From board\n" ++ show board ++ "\nIt is possible to do\n" ++ unlines (map show $ allmoves board)) - - -testmove = Move (0,0) North testboard +jumppeg :: Board -> Move -> Maybe Board +jumppeg b (Move peg dir) | npeg == Nothing = --trace ("OOB " ++ show peg ++ " " ++ show dir) + Nothing + | npeg2 == Nothing = --trace ("OOB2" ++ show peg ++ " " ++ show dir) + Nothing + -- valid jump: next hole occupied, but the one after is free + | peg `elem` pegs && np `elem` pegs && not (np2 `elem` pegs) = --trace ("OK " ++ show peg ++ " " ++ show dir) + Just $ jumppeg_possible b (Move peg dir) + | otherwise = --trace ("Illegal " ++ show peg ++ " " ++ show dir) + Nothing + where npeg = nextpeg b (Move peg dir) + Just np = npeg + npeg2 = nextpeg b (Move np dir) + Just np2 = npeg2 + Board pegs = b + +jumppeg_possible :: Board -> Move -> Board +jumppeg_possible (Board pegs) (Move peg dir) = Board (removepeg ++ [npeg2]) + where removepeg = filter ((/=) peg) $ -- remove jumping peg from origin + filter ((/=) npeg) pegs -- remove peg being jumped over + npeg = movepeg peg dir + npeg2 = movepeg npeg dir + +testboard = Board [(4,1),(5,1),(6,1), + (4,2),(5,2),(6,2), + (4,3),(5,3),(6,3), + (1,4),(2,4),(3,4),(4,4),(5,4),(6,4),(7,4),(8,4),(9,4), + (1,5),(2,5),(3,5),(4,5), (6,5),(7,5),(8,5),(9,5), + (1,6),(2,6),(3,6),(4,6), (6,6),(7,6),(8,6),(9,6), + (4,7),(5,7),(6,7), + (4,8),(5,8),(6,8), + (4,9),(5,9),(6,9)] + +lift_tuple (a, Just b) = Just (a, b) +lift_tuple (a, Nothing) = Nothing + +all_moves :: Board -> [(Move, Board)] +all_moves b = catMaybes $ map lift_tuple moves_boards + where Board pegs = b + allmoves = [Move p d | p <- pegs, d <- [North, West, East, South]] + maybeboards = map (jumppeg b) allmoves + moves_boards = zip allmoves maybeboards + + + +type RemainingPegs = Int + +data End = End String Board +instance Show End where + show (End s b) = "End: " ++ s ++ " Left " ++ show num_pegs -- ++ "\n" ++ show b + where Board pegs = b + num_pegs = length pegs + +solve_r :: Board -> String -> [End] +solve_r b s | null moves = [End (s ++ ".") b] + | otherwise = concat (map (uncurry solve_r) boards_strmoves ) + where Board pegs = b + (moves, boards) = unzip $ all_moves b + strmoves = map ((++) (s ++ " ")) (map show moves) :: [String] + boards_strmoves = zip boards strmoves :: [(Board, String)] + +pr board = putStrLn ("Welcome to Solitaire Simulator 2015 Deluxe Edition!\n From board\n" ++ show board ++ "\nIt is possible to do\n" ++ unlines (map show $ all_moves board)) + +perfect_end (End _ b) = length pegs == 1 && head pegs == (5,5) + where Board pegs = b + +good_end (End _ b) = length pegs == 1 + where Board pegs = b + +welcome board = putStrLn ("Welcome to Solitaire Simulator 2015 Deluxe Edition!\n Playing with\n" ++ show board) +main = do + welcome testboard + putStrLn "Perfect moves:" + putStrLn $ unlines $ map show perfect_ends + putStrLn "Only-one peg solutions:" + putStrLn $ unlines $ map show good_ends + where ends = solve_r testboard "" + good_ends = filter good_end ends + perfect_ends = filter perfect_end ends |