import StdEnv
-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.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 :== ' '
+Emp :== '.'
+Peg :== 'o'
-:: Coord :== (Int, Int)
-:: Position = Inv | Emp | Peg
-:: PegBoard :== {{Position}}
-:: Move :== (Coord, Direction)
-:: Direction = N | E | S | W
-:: Solver a :== RWST () [PegBoard] PegBoard Maybe a
+:: Direction :== Int
+N :== 0
+E :== 1
+S :== 2
+W :== 3
-european :: PegBoard
-european =
+:: Coord = {x :: !Int , y :: !Int}
+:: Move = {c :: !Coord, d :: !Direction}
+:: PegBoard :== {#{#Position}}
+
+english :: PegBoard
+english =
{{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
,{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'
-
-instance == Position where
- (==) Inv Inv = True
- (==) Emp Emp = True
- (==) Peg Peg = True
- (==) _ _ = 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 -> 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]
+french :: PegBoard
+french =
+ {{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
+ ,{Inv, Peg, Peg, Peg, Peg, Peg, Inv}
+ ,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
+ ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
+ ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
+ ,{Inv, Peg, Peg, Peg, Peg, Peg, Inv}
+ ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
+ }
-win :: (PegBoard -> Bool)
-win = (==) 1 o length o getCoords ((==)Peg)
+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}
+ ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg}
+ ,{Peg, Peg, Peg, Peg, Emp, Peg, Peg, Peg, Peg}
+ ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg}
+ ,{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}
+ }
-printPegBoard :: PegBoard -> String
-printPegBoard b = 'Text'.join "\n" ["\n":[{#toChar x\\x<-:r}\\r <-: b]]
+bell :: PegBoard
+bell =
+ {{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
+ ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
+ ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
+ ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg}
+ ,{Peg, Peg, Peg, Emp, Peg, Peg, Peg, Peg}
+ ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg}
+ ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
+ ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
+ }
-getMoves :: Solver [Move]
-getMoves = gets (\b->[(c,d)\\c<-getCoords ((==)Emp) b, d<-[N,E,S,W]])
+diamond :: PegBoard
+diamond =
+ {{Inv, Inv, Inv, Inv, Peg, Inv, Inv, Inv, Inv}
+ ,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
+ ,{Inv, Inv, Peg, Peg, Peg, Peg, Peg, Inv, Inv}
+ ,{Inv, Peg, Peg, Peg, Peg, Peg, Peg, Peg, Inv}
+ ,{Peg, Peg, Peg, Peg, Emp, Peg, Peg, Peg, Peg}
+ ,{Inv, Peg, Peg, Peg, Peg, Peg, Peg, Peg, Inv}
+ ,{Inv, Inv, Peg, Peg, Peg, Peg, Peg, Inv, Inv}
+ ,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
+ ,{Inv, Inv, Inv, Inv, Peg, Inv, Inv, Inv, Inv}
+ }
-solve :: PegBoard -> Maybe [PegBoard]
-solve b = snd <$> evalRWST (tell [b] >>| solver) () b
+solve :: !PegBoard -> Maybe [PegBoard]
+solve b
+ | 1 == length (getCoords Peg) = pure [b]
+ = (\xs->[b:xs]) <$> foldr (<|>) empty [move b m >>= solve\\m<-moves]
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
+ 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 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]
repositories / cleanpeg.git / blobdiff