From 7b1dfd4032f4436e930a1c774e16eb1b31763034 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
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