peg.icl

   1 module peg
   2
   3 import StdEnv
   4
   5 from Text import class Text, instance Text String
   6 import qualified Text
   7 from Data.Func import $
   8 import Data.Tuple
   9 import Data.Monoid
  10 import Control.Monad
  11 import Control.Monad.RWST
  12 import Control.Applicative
  13 import Data.Maybe
  14 import Data.Functor
  15
  16 :: Coord :== (Int, Int)
  17 :: Position = Inv | Emp | Peg
  18 :: PegBoard :== {{Position}}
  19 :: Move :== (Coord, Direction)
  20 :: Direction = N | E | S | W
  21 :: Solver a :== RWST () [PegBoard] PegBoard Maybe a
  22
  23 european :: PegBoard
  24 european =
  25         {{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  26         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  27         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  28         ,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
  29         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  30         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  31         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  32         }
  33
  34 empty = RWST $ \_ _->Nothing
  35 (<|>) (RWST fa) (RWST fb) = RWST $ \r s->case fa r s of
  36         Nothing = fb r s
  37         x = x
  38
  39 instance toChar Position where
  40         toChar p = case p of Inv = ' '; Emp = '.'; Peg = 'o'
  41
  42 instance == Position where
  43         (==) Inv Inv = True
  44         (==) Emp Emp = True
  45         (==) Peg Peg = True
  46         (==) _ _ = False
  47
  48 transform :: Coord Direction -> Coord
  49 transform (x, y) d = case d of N = (x, y+1); S = (x, y-1); W = (x+1, y); E = (x-1, y)
  50
  51 getPos :: Coord -> Solver Position
  52 getPos c=:(x, y) = get >>= \b->if (valid b) empty (pure b.[y].[x])
  53 where
  54         valid b = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] == Inv
  55
  56 applyMove :: Move -> Solver ()
  57 applyMove (tc=:(tx, ty), d)
  58 # sc=:(sx, sy) = transform tc d
  59 # fc=:(fx, fy) = transform sc d
  60 = get >>= \b->liftM3 tuple3 (getPos fc) (getPos sc) (getPos tc) >>= \f->case f of
  61         (Peg, Peg, Emp)
  62                 # b = {{{c\\c<-:r}\\r<-:b} & [fy,fx]=Emp, [sy,sx]=Emp, [ty,tx]=Peg}
  63                 = tell [b] >>| put b
  64         _ = empty
  65
  66 getCoords :: (Position -> Bool) PegBoard -> [Coord]
  67 getCoords f b = [(x, y)\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]
  68
  69 win :: (PegBoard -> Bool)
  70 win = (==) 1 o length o getCoords ((==)Peg)
  71
  72 printPegBoard :: PegBoard -> String
  73 printPegBoard b = 'Text'.join "\n" ["\n":[{#toChar x\\x<-:r}\\r <-: b]]
  74
  75 getMoves :: Solver [Move]
  76 getMoves = gets (\b->[(c,d)\\c<-getCoords ((==)Emp) b, d<-[N,E,S,W]])
  77
  78 solve :: PegBoard -> Maybe [PegBoard]
  79 solve b = snd <$> evalRWST (tell [b] >>| solver) () b
  80 where
  81         solver = get >>= \board->case win board of
  82                 True = get >>= \b->tell [b]
  83                 False = getMoves
  84                         >>= foldr (<|>) empty o map (\m->applyMove m >>| solver)
  85
  86 Start = 'Text'.join "\n" o map printPegBoard <$> solve european