From d571ba5387d71ca0e1055ceb09a78b2b030e29c4 Mon Sep 17 00:00:00 2001 From: "Matthias P. Braendli" Date: Sun, 8 Feb 2015 22:26:15 +0100 Subject: Add Solitaire Simulator 2015 --- solitairesimulator2015.hs | 136 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 136 insertions(+) create mode 100644 solitairesimulator2015.hs 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 -- cgit v1.2.3