all but eval for var works

week13_job/ex13.icl

+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