From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 13 Feb 2019 14:29:05 +0000 (+0100)
Subject: cleanup
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=refs%2Fheads%2Fmaster;p=cleanpeg.git

cleanup
---

diff --git a/peg.icl b/peg.icl
index 07129a0..60389a9 100644
--- a/peg.icl
+++ b/peg.icl
@@ -2,16 +2,12 @@ module peg
 
 import StdEnv
 
-import Text
-import Data.Func
-import Data.Tuple
-import Data.List
-import Data.Monoid
-import Control.Monad => qualified join
-import Control.Monad.RWST
 import Control.Applicative
-import Data.Maybe
+import Control.Monad
+import Data.Func
 import Data.Functor
+import Data.Maybe
+import Data.Monoid
 
 :: Position :== Char
 Inv :== ' '
@@ -28,7 +24,7 @@ W :== 3
 :: Move      =  {c :: !Coord, d :: !Direction}
 :: PegBoard :== {#{#Position}}
 
-english :: *PegBoard
+english :: PegBoard
 english =
 	{{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
 	,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
@@ -39,7 +35,7 @@ english =
 	,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
 	}
 
-french :: *PegBoard
+french :: PegBoard
 french =
 	{{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
 	,{Inv, Peg, Peg, Peg, Peg, Peg, Inv}
@@ -50,7 +46,7 @@ french =
 	,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
 	}
 
-german :: *PegBoard
+german :: PegBoard
 german =
 	{{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
 	,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
@@ -88,42 +84,40 @@ diamond =
 	,{Inv, Inv, Inv, Inv, Peg, Inv, Inv, Inv, Inv}
 	}
 
-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 :: !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
-= 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]
-
-printPegBoard :: !PegBoard -> String
-printPegBoard b = join "\n" (["\n":[r\\r <-: b]] ++ ["\n"])
-
 solve :: !PegBoard -> Maybe [PegBoard]
 solve b
-	| 1 == length (getCoords ((==)Peg) b) = pure [b]
+	| 1 == length (getCoords Peg) = pure [b]
 	= (\xs->[b:xs]) <$> foldr (<|>) empty [move b m >>= solve\\m<-moves]
 where
-	moves = [{c=c,d=d}\\c<-getCoords ((==)Emp) b, d<-[N,E,S,W]]
+	moves :: [Move]
+	moves = [{c=c,d=d}\\c<-getCoords Emp, d<-[N,E,S,W]]
+
+	getCoords :: Char -> [Coord]
+	getCoords f = [{x=x,y=y}\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f == c]
 
-//Start = [map printPegBoard <$> solve b\\b<-[english,german,french,bell, diamond]]
-Start = map printPegBoard <$> solve english
+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
+	= getPos fc >>= \pa->if` (pa<>Peg) empty
+	$ getPos sc >>= \pb->if` (pb<>Peg) empty
+	$ getPos cc >>= \pc->if` (pc<>Emp) empty
+	$ Just {{{c\\c<-:r}\\r<-:b} & [fy,fx]=Emp, [sy,sx]=Emp, [ty,tx]=Peg}
+where
+	getPos :: !Coord -> Maybe Position
+	getPos {x,y}
+		| y < 0 || x < 0 || y >= size b || x >= size b.[y] || b.[y,x] == Inv
+			= Nothing
+		= Just (b.[y,x])
+
+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}
+
+Start = [map printPegBoard <$> solve b\\b<-[english,german,french,bell,diamond]]
+where
+	printPegBoard :: !PegBoard -> String
+	printPegBoard b = foldr (+++) "\n" [r+++"\n"\\r<-:b]