-:: Coord = {x::Int, y::Int}
-:: Move = {c::Coord, d::Direction}
+:: Coord = {x :: !Int , y :: !Int}
+:: Move = {c :: !Coord, d :: !Direction}
{{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}
,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
}
,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
}
{{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
,{Inv, Peg, Peg, Peg, Peg, Peg, Inv}
,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
{{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
,{Inv, Peg, Peg, Peg, Peg, Peg, Inv}
,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
}
,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
}
{{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}
{{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}
,{Inv, Inv, Inv, Inv, Peg, Inv, Inv, Inv, Inv}
}
,{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]))
-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
-= 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]
-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]
- 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