w12 including printing

week12-reg/week12reg.icl

+module week12reg
+
+import StdEnv, StdMaybe
+
+
+
+::BM a b = {t::a -> b,f::b -> a} //bimap
+
+bm :: BM a a
+bm = {f = id, t = id}
+
+
+:: Action a b
+  = Lock (BM a Low) (BM b Low)
+  | Unlock (BM a Low) (BM b Low)
+  | MoveToShip (BM a High) (BM b High)
+  | MoveToKey (BM a High) (BM b High)
+  | MoveUp (BM a Low) (BM b High)
+  | MoveDown (BM a High) (BM b Low)
+  | E.c:(:.) infixl 1 (Action a c) (Action c b)
+  | Wait (BM a b) (BM a b)
+  | WhileContainerBelow (Action High High)
+
+:: High = High
+:: Low = Low
+
+lock = Lock bm bm
+unlock = Unlock bm bm
+up = MoveUp bm bm
+down = MoveDown bm bm
+wait :: Action a a
+wait = Wait bm bm
+moveToQuay = MoveToKey bm bm
+moveToShip = MoveToShip bm bm
+whileContainerBelow :: (Action High High) -> (Action High High)
+whileContainerBelow a = WhileContainerBelow a
+
+
+t1 :: Action High High
+t1 = whileContainerBelow (down :. lock :. up :. down :. unlock :. up) //lock :. up
+//t1 :: Action High High
+//t1 = down :. lock :. up :. down :. unlock :. up
+:: Res r e = Error e | Result r
+
+:: State = 
+	{ onShip :: [Container]
+	, onQuay:: [Container]
+	, craneUp :: Bool
+	, craneOnQuay :: Bool
+	, locked :: Maybe Container
+	}
+:: Container :== String
+
+initialState =
+	{ onShip = []
+	, onQuay = ["apples","beer","camera’s"]
+	, craneUp = True
+	, craneOnQuay = True
+	, locked = Nothing 
+	}
+
+/*
+eval (Lock {f} {t}) st 
+	| st.craneOnQuay   = Res {st & locked = Just (hd st.onQuay), onQuay = tl st.onQuay } 
+	| otherwise        = Res {st & locked = Just (hd st.onShip), onShip = tl st.onShip }
+
+eval (Unlock {f} {t}) st
+	| st.craneOnQuay    = Res {st & locked = Nothing, onQuay = [fromJust st.locked:st.onQuay] }
+	| otherwise         = Res {st & locked = Nothing, onShip = [fromJust st.locked:st.onShip] }
+*/
+eval :: (Action a b) State -> (Res State String)
+eval (MoveUp {f} {t}) s = Result {s & craneUp = True} 
+eval (MoveDown {f} {t}) s = Result {s & craneUp = False}
+eval (Lock {f} {t}) s = if s.craneOnQuay 
+						case s.onQuay of
+							[x:xs] -> case s.locked of  
+								Just(c) = Error "Cannot lock container, crane occupied"
+								Nothing = Result {s & onQuay = xs, locked = (Just x) }
+							[] -> Error "Cannot lock container, none on quay"
+						case s.onShip of
+							[x:xs] -> case s.locked of  
+								Just(c) = Error "Cannot lock container, crane occupied"
+								Nothing = Result {s & onShip = xs, locked = (Just x) }
+							[] -> Error "Cannot lock container, none on ship"
+						//(Error "Cannot lock container, crane not on quay") // should never happen
+eval (Unlock {f} {t}) s = if s.craneOnQuay 
+//							(Error "Cannot unlock container, crane not on ship")
+							case s.locked of
+								Just c -> Result {s & onQuay = [c:s.onQuay], locked = Nothing }
+								Nothing -> Error "Cannot unlock container, no container on crane"
+							case s.locked of
+								Just c -> Result {s & onShip = [c:s.onShip], locked = Nothing }
+								Nothing -> Error "Cannot unlock container, no container on crane"
+
+eval (MoveToShip {f} {t}) s = if s.craneOnQuay
+								(Result {s & craneOnQuay = False})
+								(Error "Cannot move to ship, crane is already on ship")
+eval (MoveToKey {f} {t}) s = if s.craneOnQuay
+								(Error "Cannot move to quay, crane is already on quay")
+								(Result {s & craneOnQuay = True})
+eval (Wait {f} {t}) s = Result s
+
+eval (:. a b) s = case (eval a s) of
+					Result s -> (eval b s)
+					e -> e
+
+eval (WhileContainerBelow a) s = if (containerBelow s) 
+
+								case (eval a s) of
+									(Result s2) -> (eval (WhileContainerBelow a) s2)
+									e -> e
+								
+								(Result s)
+
+
+containerBelow :: State -> Bool
+containerBelow s = case s.locked of
+					(Just s) = True
+					Nothing = if s.craneOnQuay 
+								(length s.onQuay > 0)
+								(length s.onShip > 0)
+
+/*  = Lock (BM a Low) (BM b Low)
+  | Unlock (BM a Low) (BM b Low)
+  | MoveToShip (BM a High) (BM b High)
+  | MoveToKey (BM a High) (BM b High)
+  | MoveUp (BM a Low) (BM b High)
+  | MoveDown (BM a High) (BM b Low)
+  | E.c:(:.) infixl 1 (Action a c) (Action c b)
+  | Wait (BM a b) (BM a b)
+  | WhileContainerBelow (Action High High)
+*/
+//asd//(Result s)
+
+
+
+print :: (Action a b) -> [String]
+print (MoveToShip {f} {t}) = ["moveToShip"]
+print (MoveToKey {f} {t}) = ["moveToQuay"]
+print (MoveUp {f} {t}) = ["moveUp"]
+print (MoveDown {f} {t}) = ["moveDown"]
+print (Lock {f} {t}) = ["lock"]
+print (Unlock {f} {t}) = ["unlock"]
+print (Wait {f} {t}) = ["wait"]
+print (:. a b) = print a ++ [":.":"\n": print b ]
+print (WhileContainerBelow a) = ["whileContainerBelow":"(":"\n": (print a ++ [")"])]
+
+t2 :: Action Low Low
+t2 = lock :. up :. down :. unlock
+
+Start = print loadShip //eval loadShip initialState
+
+loadShip = whileContainerBelow (
+	down:. 
+	lock:. 
+	up:. 
+	moveToShip:. 
+	wait:. 
+	down:. 
+	wait:. 
+	unlock:. 
+	up:. 
+	moveToQuay 
+	)
+
+//Start = loadShip //t1
+//Start = g2 (G id)
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+