From 7b1dfd4032f4436e930a1c774e16eb1b31763034 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Thu, 22 Jun 2017 20:16:22 +0200 Subject: [PATCH] solution --- README.md | 3 +++ peg.icl | 75 +++++++++++++++++++++++++++++-------------------------- 2 files changed, 43 insertions(+), 35 deletions(-) create mode 100644 README.md diff --git a/README.md b/README.md new file mode 100644 index 0000000..dae1155 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# Peg solitaire solver + +Time to solve: 1m2.852s diff --git a/peg.icl b/peg.icl index bbe537d..ed1a964 100644 --- a/peg.icl +++ b/peg.icl @@ -6,17 +6,19 @@ from Text import class Text, instance Text String import qualified Text from Data.Func import $ import Data.Tuple +import Data.Monoid import Control.Monad -import Control.Monad.State +import Control.Monad.RWST import Control.Applicative import Data.Maybe import Data.Functor :: Coord :== (Int, Int) :: Position = Inv | Emp | Peg -:: PegBoard :== {#{Position}} +:: PegBoard :== {{Position}} :: Move :== (Coord, Direction) :: Direction = N | E | S | W +:: Solver a :== RWST () [PegBoard] PegBoard Maybe a european :: PegBoard european = @@ -29,6 +31,11 @@ european = ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv} } +empty = RWST $ \_ _->Nothing +(<|>) (RWST fa) (RWST fb) = RWST $ \r s->case fa r s of + Nothing = fb r s + x = x + instance toChar Position where toChar p = case p of Inv = ' '; Emp = '.'; Peg = 'o' @@ -39,43 +46,41 @@ instance == Position where (==) _ _ = False transform :: Coord Direction -> Coord -transform (x, y) d = case d of - N = (x, y-1) - S = (x, y+1) - W = (x-1, y) - E = (x+1, y) - -getPos :: Coord -> StateT PegBoard Maybe Position -getPos c=:(x, y) = getState >>= \b->if (valid b c) - fail (pure b.[y].[x]) - -valid :: PegBoard Coord -> Bool -valid b (x, y) = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] == Inv - -fail :: StateT PegBoard Maybe a -fail = StateT \s->Nothing - -applyMove :: Move PegBoard -> Maybe PegBoard -applyMove (c=:(fx, fy), d) b = Nothing -//# sc=:(sx, sy) = transform c d -//# tc=:(tx, ty) = transform sc d -//= liftM3 tuple3 (getPos c b) (getPos sc b) (getPos tc b) -// >>= \f->case f of -// (Peg, Peg, Emp) = Nothing//Just {b & [fx,fy]=Emp, [sx,sy]=Emp, [tx,ty]=Peg} -// _ = Nothing +transform (x, y) d = case d of N = (x, y+1); S = (x, y-1); W = (x+1, y); E = (x-1, y) + +getPos :: Coord -> Solver Position +getPos c=:(x, y) = get >>= \b->if (valid b) empty (pure b.[y].[x]) +where + valid b = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] == Inv + +applyMove :: Move -> Solver () +applyMove (tc=:(tx, ty), d) +# sc=:(sx, sy) = transform tc d +# fc=:(fx, fy) = transform sc d += get >>= \b->liftM3 tuple3 (getPos fc) (getPos sc) (getPos tc) >>= \f->case f of + (Peg, Peg, Emp) + # b = {{{c\\c<-:r}\\r<-:b} & [fy,fx]=Emp, [sy,sx]=Emp, [ty,tx]=Peg} + = tell [b] >>| put b + _ = empty getCoords :: (Position -> Bool) PegBoard -> [Coord] getCoords f b = [(x, y)\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c] win :: (PegBoard -> Bool) -win = isEmpty o getCoords ((<>)Peg) +win = (==) 1 o length o getCoords ((==)Peg) printPegBoard :: PegBoard -> String -printPegBoard b = 'Text'.join "\n" [{#toChar x\\x<-:r}\\r <-: b] - -Start = - ( getCoords ((==)Emp) european - , win european - , printPegBoard <$> applyMove ((3,2), S) european - ) -//Start = printPegBoard european +printPegBoard b = 'Text'.join "\n" ["\n":[{#toChar x\\x<-:r}\\r <-: b]] + +getMoves :: Solver [Move] +getMoves = gets (\b->[(c,d)\\c<-getCoords ((==)Emp) b, d<-[N,E,S,W]]) + +solve :: PegBoard -> Maybe [PegBoard] +solve b = snd <$> evalRWST (tell [b] >>| solver) () b +where + solver = get >>= \board->case win board of + True = get >>= \b->tell [b] + False = getMoves + >>= foldr (<|>) empty o map (\m->applyMove m >>| solver) + +Start = 'Text'.join "\n" o map printPegBoard <$> solve european -- 2.20.1