-- Solitaire Simulator 2015 -- ************************ -- -- Start position: -- -- 123 456 789 -- -- 1 ooo -- 2 ooo -- 3 ooo -- 4 ooo ooo ooo -- 5 ooo o.o ooo -- 6 ooo ooo ooo -- 7 ooo -- 8 ooo -- 9 ooo -- -- Written as an excuse to learn some more Haskell -- -- {{{ The MIT License (MIT) -- -- Copyright (c) 2015 Matthias P. Braendli -- -- Permission is hereby granted, free of charge, to any person obtaining a copy -- of this software and associated documentation files (the "Software"), to deal -- in the Software without restriction, including without limitation the rights -- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -- copies of the Software, and to permit persons to whom the Software is -- furnished to do so, subject to the following conditions: -- -- The above copyright notice and this permission notice shall be included in all -- copies or substantial portions of the Software. -- -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. }}} 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) type Row = Int type Col = Int type Peg = (Col, Row) -- A board is defined by what holes are occupied by pegs. 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 "." showrow :: Board -> Row -> String showrow b r | r <= 3 || r >= 7 = " " ++ foldr (++) "" (map (showpeg b r) [4,5,6]) ++ "\n" | otherwise = foldr (++) "" ( map (showpeg b r) [1,2,3] ++ [" "] ++ map (showpeg b r) [4,5,6] ++ [" "] ++ map (showpeg b r) [7,8,9] ++ ["\n"] ) 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 -> 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 -> 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 -> [Move] -> [End] solve_r b m | null moves = [End (show m) b] | otherwise = concat (map (uncurry solve_r) boards_moves ) where Board pegs = b (moves, boards) = unzip $ all_moves b moves_append = map (flip (:) $ m) moves :: [[Move]] boards_moves = zip boards moves_append :: [(Board, [Move])] 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