peg.icl

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