Improve The Solitaire Simulator 2015

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