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.List
  10 import Data.Monoid
  11 import Control.Monad
  12 import Control.Monad.RWST
  13 import Control.Applicative
  14 import Data.Maybe
  15 import Data.Functor
  16
  17 :: Position :== Char
  18 Inv :== ' '
  19 Emp :== '.'
  20 Peg :== 'o'
  21
  22 :: Direction :== Int
  23 N :== 0
  24 E :== 1
  25 S :== 2
  26 W :== 3
  27
  28 :: Coord = {x::Int, y::Int}
  29 :: Move = {c::Coord, d::Direction}
  30 :: PegBoard :== {#{#Position}}
  31
  32 :: Solver a :== RWST () [PegBoard] PegBoard Maybe a
  33
  34 english :: PegBoard
  35 english =
  36         {{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  37         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  38         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  39         ,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
  40         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  41         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  42         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  43         }
  44
  45 french :: PegBoard
  46 french =
  47         {{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  48         ,{Inv, Peg, Peg, Peg, Peg, Peg, Inv}
  49         ,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
  50         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  51         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  52         ,{Inv, Peg, Peg, Peg, Peg, Peg, Inv}
  53         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
  54         }
  55
  56 german :: PegBoard
  57 german =
  58         {{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  59         ,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  60         ,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  61         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  62         ,{Peg, Peg, Peg, Peg, Emp, Peg, Peg, Peg, Peg}
  63         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  64         ,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  65         ,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  66         ,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  67         }
  68
  69 bell :: PegBoard
  70 bell =
  71         {{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  72         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  73         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  74         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  75         ,{Peg, Peg, Peg, Emp, Peg, Peg, Peg, Peg}
  76         ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg, Peg}
  77         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  78         ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  79         }
  80
  81 diamond :: PegBoard
  82 diamond =
  83         {{Inv, Inv, Inv, Inv, Peg, Inv, Inv, Inv, Inv}
  84         ,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  85         ,{Inv, Inv, Peg, Peg, Peg, Peg, Peg, Inv, Inv}
  86         ,{Inv, Peg, Peg, Peg, Peg, Peg, Peg, Peg, Inv}
  87         ,{Peg, Peg, Peg, Peg, Emp, Peg, Peg, Peg, Peg}
  88         ,{Inv, Peg, Peg, Peg, Peg, Peg, Peg, Peg, Inv}
  89         ,{Inv, Inv, Peg, Peg, Peg, Peg, Peg, Inv, Inv}
  90         ,{Inv, Inv, Inv, Peg, Peg, Peg, Inv, Inv, Inv}
  91         ,{Inv, Inv, Inv, Inv, Peg, Inv, Inv, Inv, Inv}
  92         }
  93
  94 empty = RWST \_ _->Nothing
  95 (<|>) (RWST fa) (RWST fb) = RWST \r s->maybe (fb r s) Just (fa r s)
  96
  97 transform :: Coord Direction -> Coord
  98 transform c=:{x,y} d = case d of
  99         N = {c&y=y+1}; S = {c&y=y-1}; W = {c&x=x+1}; E = {c&x=x-1}
 100
 101 getPos :: Coord -> Solver Position
 102 getPos {x,y} = get >>= \b->if (valid b) empty (pure b.[y].[x])
 103 where
 104         valid b = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] == Inv
 105
 106 move :: Move -> Solver ()
 107 move {c=c=:{x=tx,y=ty}, d}
 108 # sc=:{x=sx,y=sy} = transform c d
 109 # fc=:{x=fx,y=fy} = transform sc d
 110 = get >>= \b->liftM3 tuple3 (getPos fc) (getPos sc) (getPos c) >>= \f->case f of
 111         (Peg, Peg, Emp)
 112                 # b = {{{c\\c<-:r}\\r<-:b} & [fy,fx]=Emp, [sy,sx]=Emp, [ty,tx]=Peg}
 113                 = tell [b] >>| put b
 114         _ = empty
 115
 116 getCoords :: (Char -> Bool) PegBoard -> [Coord]
 117 getCoords f b = [{x=x,y=y}\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]
 118
 119 win :: (PegBoard -> Bool)
 120 win = (==) 1 o length o getCoords ((==)Peg)
 121
 122 printPegBoard :: PegBoard -> String
 123 printPegBoard b = 'Text'.join "\n" $ ["\n":[r\\r <-: b]] ++ ["\n"]
 124
 125 moves :: Solver [Move]
 126 moves = gets $ \b->[{c=c,d=d}\\c<-getCoords ((==)Emp) b, d<-[N,E,S,W]]
 127
 128 solve :: PegBoard -> Maybe [PegBoard]
 129 solve b = snd <$> evalRWST (tell [b] >>| solver) () b
 130 where
 131         solver = get >>= \board->if (win board)
 132                 (get >>= tell o pure)
 133                 (moves >>= foldr (<|>) empty o map (\m->move m >>| solver))
 134
 135 Start = [map printPegBoard <$> solve b\\b<-[english,german,french,bell, diamond]]