cleanup

[cleanpeg.git] / peg.icl

diff --git a/peg.icl b/peg.icl
index 8efcd4b..60389a9 100644 (file)
--- a/peg.icl
+++ b/peg.icl
@@ -2,17 +2,12 @@ module peg
 
 import StdEnv
 
-from Text import class Text, instance Text String
-import qualified Text
-from Data.Func import $
-import Data.Tuple
-import Data.List
-import Data.Monoid
-import Control.Monad
-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 :== ' '
@@ -25,14 +20,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 =
        {{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
        ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
        ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
@@ -43,7 +36,7 @@ english =
        }
 
 french :: PegBoard
-french = 
+french =
        {{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
        ,{Inv, Peg, Peg, Peg, Peg, Peg, Inv}
        ,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
@@ -54,7 +47,7 @@ french =
        }
 
 german :: PegBoard
-german = 
+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 +84,40 @@ 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)
+solve :: !PegBoard -> Maybe [PegBoard]
+solve b
+       | 1 == length (getCoords Peg) = pure [b]
+       = (\xs->[b:xs]) <$> foldr (<|>) empty [move b m >>= solve\\m<-moves]
+where
+       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]
+
+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 :: !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])
-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
-# 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]
-getCoords f b = [{x=x,y=y}\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]
+       N = {c & y=y+1}
+       S = {c & y=y-1}
+       W = {c & x=x+1}
+       E = {c & x=x-1}
 
-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]]
-
-solve :: PegBoard -> Maybe [PegBoard]
-solve b = snd <$> evalRWST (tell [b] >>| solver) () b
+Start = [map printPegBoard <$> solve b\\b<-[english,german,french,bell,diamond]]
 where
-       solver = get >>= \board->if (win board)
-               (get >>= tell o pure)
-               (moves >>= foldr (<|>) empty o map (\m->move m >>| solver))
-
-Start = [map printPegBoard <$> solve b\\b<-[english,german,french,bell, diamond]]
+       printPegBoard :: !PegBoard -> String
+       printPegBoard b = foldr (+++) "\n" [r+++"\n"\\r<-:b]