Commit 7119cd3f authored by Job Cuppen's avatar Job Cuppen

all but eval for var works

parent b13befee
module ex13
import StdEnv, StdMaybe
import Data.Functor, Control.Applicative, Control.Monad
class type a | toString, TC a where
type :: a -> String
instance type Int where
type a = "int"
instance type Bool where
type a = "bool"
:: Expr = Expr
class expr v where
containersBelow :: (v Expr Int)
lit :: a -> v Expr a | type a
(<.) infix 4 :: (v Expr t) (v Expr t) -> v Expr Bool | <, type t
(>.) x y :== y <. x
(+.) infix 4 :: (v Expr t) (v Expr t) -> v Expr t | +, type t
:: Step init target = Step init target
:: High = High
:: Low = Low
:: Act = Act
class action v where
(:.) infixl 1 :: (v Act (Step a b)) (v Act (Step b c)) -> v Act (Step a c)
moveToShip :: v Act (Step High High)
moveToQuay :: v Act (Step High High)
moveUp :: v Act (Step Low High)
moveDown :: v Act (Step High Low)
lock :: v Act (Step Low Low)
unlock :: v Act (Step Low Low)
wait :: v Act (Step x x)
While :: (v Expr Bool) (v Act t) -> v Act ()
class var v where
(=.) infixr 2 :: (v Var t) (v Expr t) -> v Act (Step x y) | type t
int :: (v Expr t) ((v Var t) -> (v Act u)) -> v Act u | type t
var :: (v Var t) -> (v Expr t) | type t
loadShip =
While (containersBelow >. lit 0) (
moveDown:.
lock:.
moveUp:.
moveToShip:.
wait:.
moveDown:.
wait:.
unlock:.
moveUp:.
moveToQuay
)
loadShip2 =
int containersBelow \n.
While (var n >. lit 0) (
moveDown:.
lock:.
moveUp:.
moveToShip:.
wait:.
moveDown:.
wait:.
unlock:.
moveUp:.
moveToQuay:.
n =. var n +. lit -1
)
:: Show p t = Show (SHOW->(t, SHOW))
:: SHOW =
{fresh :: Int
,indent :: Int
,print :: [String]
}
s0 :: SHOW
s0 =
{fresh = 0
,indent = 0
,print = ["\n"]
}
c :: t -> Show p u | toString t
c a = Show \c.(undef, {c & print = [toString a:c.print]})
unShow :: (Show p t) -> (SHOW ->(t, SHOW))
unShow (Show t) = t
instance Functor (Show p) where
fmap f (Show e) = Show \s.let (a,t) = e s in (f a,t)
instance pure (Show p) where
pure a = Show \s.(a, s)
instance <*> (Show p) where
<*> f a = f >>= \g.a >>= \b.pure (g b)
instance Monad (Show p) where
bind (Show e) f = Show \s.let (a,t) = e s in unShow (f a) t
class tie v where
(>>-) infixl 1 :: (v p t) (t -> v q u) -> v r u
(>>!) infixl 1 :: (v p t) (v q u) -> v q u
(>>!) x y = x >>- \_.y
(<*.>) infixl 4 :: (v p (t->u)) (v q t) -> v r u | tie v & Monad (v q)
(<*.>) f a = f >>- \g.a >>= \b.pure (g b)
instance tie Show where
>>- (Show e) f = Show \s.let (a, t) = e s in unShow (f a) t
brac :: (Show p t) -> Show q s
brac e = c "(" >>! e >>! c ")"
fresh :: Show p Int
fresh = Show \c.(c.fresh, {c & fresh = inc c.fresh})
freshVar :: Show p String
freshVar = fmap (\n."v" +++ toString n) fresh
freshShow :: Show p (Show q t)
freshShow = fmap c freshVar
indent :: Show p Int
indent = Show \c.let n = inc c.indent in (n, {c & indent = n})
unindent :: Show p Int
unindent = Show \c.let n = max (dec c.indent) 0 in (n, {c & indent = n})
nl :: Show p t
nl = Show \c.(undef,{c & print = [toString ['\n':repeatn (2 * c.indent) ' ']:c.print]})
instance expr Show where
containersBelow = c "containersBelow"
lit a = c "lit " >>! c a
(<.) x y = brac (x >>! c " <. " >>! y)
(+.) x y = brac (x >>! c " +. " >>! y)
instance action Show where
(:.) s t = s >>! c ":." >>! nl <*.> t
moveToShip = c "moveToShip"
moveToQuay = c "moveToQuay"
moveUp = c "moveUp"
moveDown = c "moveDown"
lock = c "lock"
unlock = c "unlock"
wait = c "wait"
While b s = c "While " >>! b >>! c " ("
>>! indent >>! nl >>! s
>>! unindent >>! nl
>>! c ")" >>! nl
instance var Show where
(=.) v e = v >>! c " = " <*.> e
int a f = c "int " >>! freshShow >>= \v. v >>! c " = " >>! a >>! c ";" >>! nl >>! f v
var n = c "var " <*.> n
:: State =
{onShip :: [Container]
,onQuay :: [Container]
,craneOnQuay :: Bool
,craneUp :: Bool
,locked :: Maybe Container
}
:: Container :== String
initialState =
{onShip = []
,onQuay = ["apples", "beer", "camera"]
,craneOnQuay = True
,craneUp = True
,locked = Nothing
}
:: Result t = Res t | Err String
:: Eval p t = Eval (State -> (Result t, State))
instance Functor Result where
fmap f (Res t) = Res (f t)
fmap f (Err str) = Err str
instance Functor (Eval p) where
fmap f (Eval e) = Eval \s.let (a,st) = e s
in (fmap f a, st)
instance pure Result where
pure a = Res a
instance pure (Eval p) where
pure a = Eval \s.(pure a, s)
instance <*> (Eval p) where
<*> f a = f >>= \g.a >>= \b.pure (g b)
unEval :: (Eval p t) -> (State -> (Result t, State))
unEval (Eval t) = t
instance Monad (Eval p) where
bind (Eval e) f = Eval \s.case e s of
(Res a,t) = unEval (f a) t
(Err e,t) = (Err e,t)
instance tie Eval where
(>>-) (Eval e) f = Eval \s.case e s of
(Res a,t) = unEval (f a) t
(Err e,t) = (Err e,t)
concat :: [String] -> String
concat s = foldr (+++) "" s
instance expr Eval where
containersBelow = Eval \s->(pure (value s), s)
where
l list = length list
value s = if s.craneOnQuay (l s.onQuay) (l s.onShip)
lit a = pure a
(<.) x y = pure (<) <*.> x <*.> y
(+.) x y = pure (+) <*.> x <*.> y
instance action Eval where
(:.) (Eval x) (Eval y) = Eval \s. case x s of
(Res (Step a b),ss) -> case y ss of
(Res (Step b c), sss) -> (Res (Step a c), sss)
(Err e, g) -> (Err e, g)
(Err e, g) -> (Err e, g)
moveToShip = Eval \s -> if s.craneOnQuay
(Res (Step High High), {s & craneOnQuay = False})
(Err "ERROR5", s)
moveToQuay = Eval \s -> if s.craneOnQuay
(Err "ERROR4", s)
(Res (Step High High), {s & craneOnQuay = True})
moveUp = Eval \s -> (Res (Step Low High), {s & craneUp = True})
moveDown = Eval \s -> (Res (Step High Low), {s & craneUp = False})
lock = Eval \s -> if s.craneUp
(Err "ERROR3", s)
if (isJust s.locked)
(Err "ERROR2", s)
if s.craneOnQuay (lockResultQuay s) (lockResultShip s)
where
lockResultShip s = case s.onShip of
[x:xs] -> (Res (Step Low Low), {s & locked = Just x, onShip = xs})
[] -> (Err "No crates left on ship", s)
lockResultQuay s = case s.onQuay of
[x:xs] -> (Res (Step Low Low), {s & locked = Just x, onQuay = xs})
[] -> (Err "No crates left on quay", s)
unlock = Eval \s -> if s.craneUp
(Err "ERROR1", s)
case s.locked of
(Just a) -> if s.craneOnQuay (unlockResultQuay a s) (unlockResultShip a s)
(Nothing) -> (Err "Crane is empty!", s)
where
unlockResultShip a s = (Res (Step Low Low), {s & locked = Nothing, onShip = [a:s.onShip] })
unlockResultQuay a s = (Res (Step Low Low), {s & locked = Nothing, onQuay = [a:s.onQuay] })
wait = Eval \s -> (Res (Step undef undef), s)
While c a = Eval \s. case (unEval c) s of
(Res True, ss) -> case (unEval a) ss of
(Res _, s) -> let (Eval z) = While c a in z s
(Err e, g) -> (Err e, g)
(Res False, s) -> (Res (), s)
(Err e, g) -> (Err e, g)
instance var Eval where
(=.) a b = Eval \s -> (Err "ERROR()", s)
int a f = Eval \s -> (Err "ERROR()", s)
var n = Eval \s -> (Err "ERROR()", s)
:: Var = Var Id
:: Id :== Int
test = (lit 33)
test2 = containersBelow
test4 = moveToQuay:.moveToQuay
test5 = int (lit 3) \x.While(var x >. lit 2) (x =. (lit 2))
//Start = let (Show f) = loadShip in (concat o reverse) (snd (f s0)).print
Start = let (Show f) = loadShip2 in (concat o reverse) (snd (f s0)).print
//Start = let (Eval f) = test4 in (f initialState)
//Start = let (Eval f) = loadShip in (f initialState)
//Start = let (Eval f) = loadShip2 in (f initialState)
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment