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 Control.Monad
  10 import Control.Monad.State
  11 import Control.Applicative
  12 import Data.Maybe
  13 import Data.Functor
  14
  15 :: Coord :== (Int, Int)
  16 :: Position = Inv | Emp | Peg
  17 :: PegBoard :== {#{Position}}
  18 :: Move :== (Coord, Direction)
  19 :: Direction = N | E | S | W
  20
  21 european :: PegBoard
  22 european =
  23         {{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  24         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  25         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  26         ,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
  27         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  28         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  29         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  30         }
  31
  32 instance toChar Position where
  33         toChar p = case p of Inv = ' '; Emp = '.'; Peg = 'o'
  34
  35 instance == Position where
  36         (==) Inv Inv = True
  37         (==) Emp Emp = True
  38         (==) Peg Peg = True
  39         (==) _ _ = False
  40
  41 transform :: Coord Direction -> Coord
  42 transform (x, y) d = case d of
  43         N = (x, y-1)
  44         S = (x, y+1)
  45         W = (x-1, y)
  46         E = (x+1, y)
  47
  48 getPos :: Coord -> StateT PegBoard Maybe Position
  49 getPos c=:(x, y) = getState >>= \b->if (valid b c)
  50                 fail (pure b.[y].[x])
  51
  52 valid :: PegBoard Coord -> Bool
  53 valid b (x, y) = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] == Inv
  54
  55 fail :: StateT PegBoard Maybe a
  56 fail = StateT \s->Nothing
  57
  58 applyMove :: Move PegBoard -> Maybe PegBoard
  59 applyMove (c=:(fx, fy), d) b = Nothing
  60 //# sc=:(sx, sy) = transform c d
  61 //# tc=:(tx, ty) = transform sc d
  62 //= liftM3 tuple3 (getPos c b) (getPos sc b) (getPos tc b)
  63 //      >>= \f->case f of
  64 //              (Peg, Peg, Emp) = Nothing//Just {b & [fx,fy]=Emp, [sx,sy]=Emp, [tx,ty]=Peg}
  65 //              _ = Nothing
  66
  67 getCoords :: (Position -> Bool) PegBoard -> [Coord]
  68 getCoords f b = [(x, y)\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]
  69
  70 win :: (PegBoard -> Bool)
  71 win = isEmpty o getCoords ((<>)Peg)
  72
  73 printPegBoard :: PegBoard -> String
  74 printPegBoard b = 'Text'.join "\n" [{#toChar x\\x<-:r}\\r <-: b]
  75
  76 Start =
  77         ( getCoords ((==)Emp) european
  78         , win european
  79         , printPegBoard <$> applyMove ((3,2), S) european
  80         )
  81 //Start = printPegBoard european