Add Solitaire Simulator 2015

1 files changed, 136 insertions, 0 deletions

diff --git a/solitairesimulator2015.hs b/solitairesimulator2015.hs
new file mode 100644
index 0000000..76e686f
--- /dev/null
+++ b/solitairesimulator2015.hs
@@ -0,0 +1,136 @@
+-- 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)
+
+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
+
+-- 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]
+
+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
+
+
+-- 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