Initial commit

diff --git a/.gitignore b/.gitignore
new file mode 100644 (file)
index 0000000..be5442f
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+Clean System Files
+peg

diff --git a/Makefile b/Makefile
new file mode 100644 (file)
index 0000000..9966f02
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,37 @@
+CLEAN_HOME?=/opt/clean
+CLM:=clm
+
+override CLMFLAGS+=-dynamics -h 200M -nt
+GCCVERSIONGTEQ6:=$(shell expr `gcc -dumpversion | cut -f1 -d.` \>= 6)
+ifeq "$(GCCVERSIONGTEQ6)" "1"
+       override CLMFLAGS+=-l -no-pie
+endif
+
+ITASKS:=~/projects/iTasks-SDK/Libraries
+
+#      -I ~/projects/iTasks-SDK/Libraries
+CLMLIBS:=\
+       -I $(CLEAN_HOME)/lib/Platform\
+       -I $(CLEAN_HOME)/lib/Platform/Deprecated/StdLib\
+       -I $(ITASKS)\
+       -I $(CLEAN_HOME)/lib/GraphCopy\
+       -I $(CLEAN_HOME)/lib/Sapl\
+       -I $(CLEAN_HOME)/lib/StdEnv\
+       -I $(CLEAN_HOME)/lib/Generics\
+       -I $(CLEAN_HOME)/lib/Dynamics\
+       -I $(CLEAN_HOME)/lib/TCPIP\
+       -I ./CleanSerial
+
+BINARIES:=peg
+
+all: $(BINARIES)
+
+%: %.icl $(wildcard */*.[id]cl *.[id]cl)
+       $(CLM) $(CLMLIBS) $(CLMFLAGS) $(basename $<) -o $@
+
+clean-%:
+       $(RM) -r $(addprefix $(@:clean-%=%),-data -www) $(@:clean-%=%)
+
+clean: $(addprefix clean-,$(BINARIES))
+       find . -type d -name 'Clean System Files' -print0 | xargs -r0 $(RM) -r
+       make -C CleanSerial clean

diff --git a/peg.icl b/peg.icl
new file mode 100644 (file)
index 0000000..bbe537d
--- /dev/null
+++ b/peg.icl
@@ -0,0 +1,81 @@
+module peg
+
+import StdEnv
+
+from Text import class Text, instance Text String
+import qualified Text
+from Data.Func import $
+import Data.Tuple
+import Control.Monad
+import Control.Monad.State
+import Control.Applicative
+import Data.Maybe
+import Data.Functor
+
+:: Coord :== (Int, Int)
+:: Position = Inv | Emp | Peg
+:: PegBoard :== {#{Position}}
+:: Move :== (Coord, Direction)
+:: Direction = N | E | S | W
+
+european :: PegBoard
+european = 
+       {{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
+       ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
+       ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
+       ,{Peg, Peg, Peg, Emp, Peg, Peg, Peg}
+       ,{Peg, Peg, Peg, Peg, Peg, Peg, Peg}
+       ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
+       ,{Inv, Inv, Peg, Peg, Peg, Inv, Inv}
+       }
+
+instance toChar Position where
+       toChar p = case p of Inv = ' '; Emp = '.'; Peg = 'o'
+
+instance == Position where
+       (==) Inv Inv = True
+       (==) Emp Emp = True
+       (==) Peg Peg = True
+       (==) _ _ = False
+
+transform :: Coord Direction -> Coord
+transform (x, y) d = case d of
+       N = (x, y-1)
+       S = (x, y+1)    
+       W = (x-1, y)
+       E = (x+1, y)
+
+getPos :: Coord -> StateT PegBoard Maybe Position
+getPos c=:(x, y) = getState >>= \b->if (valid b c)
+               fail (pure b.[y].[x])
+
+valid :: PegBoard Coord -> Bool
+valid b (x, y) = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] == Inv
+
+fail :: StateT PegBoard Maybe a
+fail = StateT \s->Nothing
+
+applyMove :: Move PegBoard -> Maybe PegBoard
+applyMove (c=:(fx, fy), d) b = Nothing
+//# sc=:(sx, sy) = transform c d
+//# tc=:(tx, ty) = transform sc d
+//= liftM3 tuple3 (getPos c b) (getPos sc b) (getPos tc b)
+//     >>= \f->case f of
+//             (Peg, Peg, Emp) = Nothing//Just {b & [fx,fy]=Emp, [sx,sy]=Emp, [tx,ty]=Peg}
+//             _ = Nothing
+
+getCoords :: (Position -> Bool) PegBoard -> [Coord]
+getCoords f b = [(x, y)\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]
+
+win :: (PegBoard -> Bool)
+win = isEmpty o getCoords ((<>)Peg)
+
+printPegBoard :: PegBoard -> String
+printPegBoard b = 'Text'.join "\n" [{#toChar x\\x<-:r}\\r <-: b]
+
+Start =
+       ( getCoords ((==)Emp) european
+       , win european
+       , printPegBoard <$> applyMove ((3,2), S) european
+       )
+//Start = printPegBoard european