import qualified Text
from Data.Func import $
import Data.Tuple
+import Data.List
+import Data.Functor
import Data.Monoid
import Control.Monad
import Control.Monad.RWST
,{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
+empty = RWST \_ _->Nothing
+(<|>) (RWST fa) (RWST fb) = RWST \r s->maybe (fb r s) Just (fa r s)
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])
+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
+ 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)
+move :: Move -> Solver ()
+move (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
getCoords f b = [(x, y)\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]
win :: (PegBoard -> Bool)
-win = (==) 1 o length o getCoords ((==)Peg)
+win = (==) 1 o length o getCoords (\c->c=:Peg)
printPegBoard :: PegBoard -> String
-printPegBoard b = 'Text'.join "\n" ["\n":[{#toChar x\\x<-:r}\\r <-: b]]
+printPegBoard b = 'Text'.join "\n" [{#toChar x\\x<-:r}\\r <-: b]
-getMoves :: Solver [Move]
-getMoves = gets (\b->[(c,d)\\c<-getCoords ((==)Emp) b, d<-[N,E,S,W]])
+moves :: Solver [Move]
+moves = gets $ \b->[(c,d)\\c<-getCoords (\c->c=:Emp) b, d<-[N,E,S,W]]
solve :: PegBoard -> Maybe [PegBoard]
solve b = snd <$> evalRWST (tell [b] >>| solver) () b
where
- solver = get >>= \board->case win board of
- True = get >>= \b->tell [b]
- False = getMoves
- >>= foldr (<|>) empty o map (\m->applyMove m >>| solver)
+ solver = get >>= \board->if (win board)
+ (get >>= tell o pure)
+ (moves >>= foldr (<|>) empty o map (\m->move m >>| solver))
Start = 'Text'.join "\n" o map printPegBoard <$> solve european