repositories
/
cleanpeg.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
971712b
)
optimalisation
author
Mart Lubbers
<mart@martlubbers.net>
Thu, 22 Jun 2017 19:19:08 +0000
(21:19 +0200)
committer
Mart Lubbers
<mart@martlubbers.net>
Thu, 22 Jun 2017 19:19:08 +0000
(21:19 +0200)
Makefile
patch
|
blob
|
history
peg.icl
patch
|
blob
|
history
diff --git
a/Makefile
b/Makefile
index
1ca48ae
..
ee49bc5
100644
(file)
--- a/
Makefile
+++ b/
Makefile
@@
-6,7
+6,7
@@
CLMLIBS:=$(addprefix -I $(CLEAN_HOME)/lib/,Platform Generics Dynamics StdEnv)
CLM:=clm
override CLMFLAGS+=-nt
CLM:=clm
override CLMFLAGS+=-nt
-ifeq "$(shell expr `gcc -dumpversion | cut -f1 -d.` \>= 6)" "1"
;
+ifeq "$(shell expr `gcc -dumpversion | cut -f1 -d.` \>= 6)" "1"
override CLMFLAGS+=-l -no-pie
endif
override CLMFLAGS+=-l -no-pie
endif
diff --git
a/peg.icl
b/peg.icl
index
0e784c2
..
2519f69
100644
(file)
--- a/
peg.icl
+++ b/
peg.icl
@@
-7,7
+7,6
@@
import qualified Text
from Data.Func import $
import Data.Tuple
import Data.List
from Data.Func import $
import Data.Tuple
import Data.List
-import Data.Functor
import Data.Monoid
import Control.Monad
import Control.Monad.RWST
import Data.Monoid
import Control.Monad
import Control.Monad.RWST
@@
-15,11
+14,21
@@
import Control.Applicative
import Data.Maybe
import Data.Functor
import Data.Maybe
import Data.Functor
-:: Coord :== (Int, Int)
-:: Position = Inv | Emp | Peg
-:: PegBoard :== {{Position}}
-:: Move :== (Coord, Direction)
-:: Direction = N | E | S | W
+:: Position :== Char
+Inv :== ' '
+Emp :== '.'
+Peg :== 'o'
+
+:: Direction :== Int
+N :== 0
+E :== 1
+S :== 2
+W :== 3
+
+:: Coord = {x::Int, y::Int}
+:: Move = {c::Coord, d::Direction}
+:: PegBoard :== {{#Position}}
+
:: Solver a :== RWST () [PegBoard] PegBoard Maybe a
european :: PegBoard
:: Solver a :== RWST () [PegBoard] PegBoard Maybe a
european :: PegBoard
@@
-36,38
+45,36
@@
european =
empty = RWST \_ _->Nothing
(<|>) (RWST fa) (RWST fb) = RWST \r s->maybe (fb r s) Just (fa r s)
empty = RWST \_ _->Nothing
(<|>) (RWST fa) (RWST fb) = RWST \r s->maybe (fb r s) Just (fa r s)
-instance toChar Position where
- toChar p = case p of Inv = ' '; Emp = '.'; Peg = 'o'
-
transform :: Coord Direction -> Coord
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)
+transform c=:{x,y} d = case d of
+ N = {c&y=y+1}; S = {c&y=y-1}; W = {c&x=x+1}; E = {c&x=x-1}
getPos :: Coord -> Solver Position
getPos :: Coord -> Solver Position
-getPos
(x, y)
= get >>= \b->if (valid b) empty (pure b.[y].[x])
+getPos
{x,y}
= get >>= \b->if (valid b) empty (pure b.[y].[x])
where
where
- valid b = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] =
:
Inv
+ valid b = y<0 || x<0 || y >= size b || x >= size b.[0] || b.[y].[x] =
=
Inv
move :: Move -> Solver ()
move :: Move -> Solver ()
-move
(tc=:(tx, ty), d)
-# sc=:
(sx, sy) = transform t
c d
-# fc=:
(fx, fy)
= transform sc d
-= get >>= \b->liftM3 tuple3 (getPos fc) (getPos sc) (getPos
t
c) >>= \f->case f of
+move
{c=c=:{x=tx,y=ty}, d}
+# sc=:
{x=sx,y=sy} = transform
c d
+# fc=:
{x=fx,y=fy}
= transform sc d
+= get >>= \b->liftM3 tuple3 (getPos fc) (getPos sc) (getPos c) >>= \f->case f of
(Peg, Peg, Emp)
# b = {{{c\\c<-:r}\\r<-:b} & [fy,fx]=Emp, [sy,sx]=Emp, [ty,tx]=Peg}
= tell [b] >>| put b
_ = empty
(Peg, Peg, Emp)
# b = {{{c\\c<-:r}\\r<-:b} & [fy,fx]=Emp, [sy,sx]=Emp, [ty,tx]=Peg}
= tell [b] >>| put b
_ = empty
-getCoords :: (
Position
-> Bool) PegBoard -> [Coord]
-getCoords f b = [
(x, y)
\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]
+getCoords :: (
Char
-> Bool) PegBoard -> [Coord]
+getCoords f b = [
{x=x,y=y}
\\r<-:b & y<-[0..] , c<-:r & x<-[0..] | f c]
win :: (PegBoard -> Bool)
win :: (PegBoard -> Bool)
-win = (==) 1 o length o getCoords (
\c->c=:
Peg)
+win = (==) 1 o length o getCoords (
(==)
Peg)
printPegBoard :: PegBoard -> String
printPegBoard :: PegBoard -> String
-printPegBoard b = 'Text'.join "\n" [
{#toChar x\\x<-:r}
\\r <-: b]
+printPegBoard b = 'Text'.join "\n" [
r
\\r <-: b]
moves :: Solver [Move]
moves :: Solver [Move]
-moves = gets $ \b->[
(c,d)\\c<-getCoords (\c->c=:
Emp) b, d<-[N,E,S,W]]
+moves = gets $ \b->[
{c=c,d=d}\\c<-getCoords ((==)
Emp) b, d<-[N,E,S,W]]
solve :: PegBoard -> Maybe [PegBoard]
solve b = snd <$> evalRWST (tell [b] >>| solver) () b
solve :: PegBoard -> Maybe [PegBoard]
solve b = snd <$> evalRWST (tell [b] >>| solver) () b