From 441dae3df76bf0f9c80a36f9649dda0826bc1e22 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 13 Feb 2019 14:51:42 +0100
Subject: [PATCH] Make things a lot quicker

---
 Makefile  |  7 +----
 README.md |  3 +-
 peg.icl   | 88 ++++++++++++++++++++++++++-----------------------------
 3 files changed, 44 insertions(+), 54 deletions(-)

diff --git a/Makefile b/Makefile
index ee49bc5..a6869ee 100644
--- a/Makefile
+++ b/Makefile
@@ -2,14 +2,9 @@ BINARIES:=peg
 
 CLEAN_HOME?=/opt/clean
 
-CLMLIBS:=$(addprefix -I $(CLEAN_HOME)/lib/,Platform Generics Dynamics StdEnv)
+CLMLIBS:=-IL Platform
 CLM:=clm
 
-override CLMFLAGS+=-nt
-ifeq "$(shell expr `gcc -dumpversion | cut -f1 -d.` \>= 6)" "1"
-	override CLMFLAGS+=-l -no-pie
-endif
-
 all: $(BINARIES)
 
 %: %.icl $(wildcard *.[id]cl)
diff --git a/README.md b/README.md
index 0c2847b..faabf38 100644
--- a/README.md
+++ b/README.md
@@ -1,9 +1,10 @@
 # Peg solitaire solver
 
-Solves it in a minute.
+Solves it in a couple of seconds.
 
 ## Todo
 - iTasks interface
+- unique arrays
 
 ## Author
 Mart Lubbers
diff --git a/peg.icl b/peg.icl
index 8efcd4b..07129a0 100644
--- a/peg.icl
+++ b/peg.icl
@@ -2,13 +2,12 @@ module peg
 
 import StdEnv
 
-from Text import class Text, instance Text String
-import qualified Text
-from Data.Func import $
+import Text
+import Data.Func
 import Data.Tuple
 import Data.List
 import Data.Monoid
-import Control.Monad
+import Control.Monad => qualified join
 import Control.Monad.RWST
 import Control.Applicative
 import Data.Maybe
@@ -25,14 +24,12 @@ E :== 1
 S :== 2
 W :== 3
 
-:: Coord = {x::Int, y::Int}
-:: Move = {c::Coord, d::Direction}
+:: Coord     =  {x :: !Int  , y :: !Int}
+:: Move      =  {c :: !Coord, d :: !Direction}
 :: PegBoard :== {#{#Position}}
 
-:: Solver a :== RWST () [PegBoard] PegBoard Maybe a
-
-english :: PegBoard
-english = 
+english :: *PegBoard
+english =
 	{{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
 	,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
 	,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
@@ -42,8 +39,8 @@ english =
 	,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
 	}
 
-french :: PegBoard
-french = 
+french :: *PegBoard
+french =
 	{{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
 	,{Inv, Peg, Peg, Peg, Peg, Peg, Inv}
 	,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
@@ -53,8 +50,8 @@ french =
 	,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
 	}
 
-german :: PegBoard
-german = 
+german :: *PegBoard
+german =
 	{{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
 	,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
 	,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
@@ -91,45 +88,42 @@ diamond =
 	,{Inv, Inv, Inv, Inv, Peg, Inv, Inv, Inv, Inv}
 	}
 
-empty = RWST \_ _->Nothing
-(<|>) (RWST fa) (RWST fb) = RWST \r s->maybe (fb r s) Just (fa r s)
-
-transform :: Coord Direction -> Coord
-transform c=:{x,y} d = case d of
-	N = {c&y=y+1}; S = {c&y=y-1}; W = {c&x=x+1}; E = {c&x=x-1}
-
-getPos :: Coord -> Solver Position
-getPos {x,y} = get >>= \b->if (valid b) empty (pure b.[y].[x])
+getPos :: !Coord !.PegBoard -> Maybe Position
+getPos {x,y} b = if (valid b) Nothing (Just (b.[y].[x]))
 where 
 	valid b = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] == Inv
 
-move :: Move -> Solver ()
-move {c=c=:{x=tx,y=ty}, d}
-# sc=:{x=sx,y=sy} = transform c d
+move :: !PegBoard !Move -> Maybe PegBoard
+move b {c=cc=:{x=tx,y=ty}, d}
+# sc=:{x=sx,y=sy} = transform cc d
 # fc=:{x=fx,y=fy} = transform sc d
-= get >>= \b->liftM3 tuple3 (getPos fc) (getPos sc) (getPos c) >>= \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 :: (Char -> Bool) PegBoard -> [Coord]
+= case getPos fc b of
+	Just Peg = case getPos sc b of
+		Just Peg = case getPos cc b of
+			Just Emp = Just {{{c\\c<-:r}\\r<-:b} & [fy,fx]=Emp, [sy,sx]=Emp, [ty,tx]=Peg}
+			_ = Nothing
+		_ = Nothing
+	_ = Nothing
+where
+	transform :: !Coord !Direction -> Coord
+	transform c=:{x,y} d = case d of
+		N = {c & y=y+1}
+		S = {c & y=y-1}
+		W = {c & x=x+1}
+		E = {c & x=x-1}
+
+getCoords :: (Char -> Bool) !PegBoard -> [Coord]
 getCoords f b = [{x=x,y=y}\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]
 
-win :: (PegBoard -> Bool)
-win = (==) 1 o length o getCoords ((==)Peg)
-
-printPegBoard :: PegBoard -> String
-printPegBoard b = 'Text'.join "\n" $ ["\n":[r\\r <-: b]] ++ ["\n"]
-
-moves :: Solver [Move]
-moves = gets $ \b->[{c=c,d=d}\\c<-getCoords ((==)Emp) b, d<-[N,E,S,W]]
+printPegBoard :: !PegBoard -> String
+printPegBoard b = join "\n" (["\n":[r\\r <-: b]] ++ ["\n"])
 
-solve :: PegBoard -> Maybe [PegBoard]
-solve b = snd <$> evalRWST (tell [b] >>| solver) () b
+solve :: !PegBoard -> Maybe [PegBoard]
+solve b
+	| 1 == length (getCoords ((==)Peg) b) = pure [b]
+	= (\xs->[b:xs]) <$> foldr (<|>) empty [move b m >>= solve\\m<-moves]
 where
-	solver = get >>= \board->if (win board)
-		(get >>= tell o pure)
-		(moves >>= foldr (<|>) empty o map (\m->move m >>| solver))
+	moves = [{c=c,d=d}\\c<-getCoords ((==)Emp) b, d<-[N,E,S,W]]
 
-Start = [map printPegBoard <$> solve b\\b<-[english,german,french,bell, diamond]]
+//Start = [map printPegBoard <$> solve b\\b<-[english,german,french,bell, diamond]]
+Start = map printPegBoard <$> solve english
-- 
2.20.1