peg.icl

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