extra safety for moveship/quay

week12_job/ex12.icl

+module ex12
+
+import StdEnv, StdMaybe, StdDebug
+import Data.Functor, Control.Applicative, Control.Monad
+
+::BM a b =
+	{t::a -> b
+	,f::b -> a
+	}
+
+bm :: BM a a
+bm = 
+	{f = id
+	,t = id
+	}
+
+:: Action a b x y
+	= MoveToShip (BM a High) (BM b High) (BM x Quay) (BM y Ship)	// move the crane to the ship
+  | MoveToQuay (BM a High) (BM b High) (BM x Ship) (BM y Quay)	// move the crane to the quay
+  | MoveUp		 (BM a Low)	 (BM b High) (BM x y)    (BM x y)			// moves the crane up
+  | MoveDown	 (BM a High) (BM b Low)	 (BM x y)    (BM x y)												// moves the crane down
+  | Lock			 (BM a Low)  (BM b Low)	 (BM x y)    (BM x y)												// locks the top container of the stack under the crane
+	| Unlock		 (BM a Low)  (BM b Low)	 (BM x y)    (BM x y)												// unlocks the container the crane is carrying, put it on the stack
+	| Wait			 (BM a b) 	 (BM a b)	   (BM x y)    (BM x y)			  						// do nothing
+	| E.c.z:(:.) infixl 1 (Action a c x z) (Action c b z y)									// sequence of two actions
+	| WhileContainerBelow (Action High High Quay Quay) 										  // repeat action while there is a container at current position
+
+:: High = High
+:: Low  = Low
+
+:: Quay = Quay
+:: Ship = Ship
+
+:: Result r = Res r | Err String
+
+:: State = 
+	{onShip      :: [Container]
+	,onQuay      :: [Container]
+	,craneOnQuay :: Bool
+	,locked 		 :: Maybe Container
+	}
+
+:: Container :== String
+
+initialState =
+	{onShip 		 = []
+	,onQuay 		 = ["apples", "beer", "camera"]
+	,craneOnQuay = True
+	,locked 		 = Nothing
+	}
+
+moveDown :: Action High Low x x
+moveDown = MoveDown bm bm bm bm
+
+moveUp :: Action Low High x x
+moveUp = MoveUp bm bm bm bm
+
+moveToShip :: Action High High Quay Ship
+moveToShip = MoveToShip bm bm bm bm
+
+moveToQuay :: Action High High Ship Quay
+moveToQuay = MoveToQuay bm bm bm bm 
+
+lock :: Action Low Low x x
+lock = Lock bm bm bm bm 
+
+wait :: Action a a x x
+wait = Wait bm bm bm bm 
+
+unlock :: Action Low Low x x
+unlock = Unlock bm bm bm bm
+
+whileContainerBelow :: (Action High High Quay Quay) -> Action High High Quay Quay
+whileContainerBelow a = WhileContainerBelow a
+
+loadShip :: Action High High Quay Quay
+loadShip = whileContainerBelow (
+	moveDown:. 
+	lock:.
+	moveUp:.
+	moveToShip:.
+	wait:.
+	moveDown:.
+	wait:.
+	unlock:. 
+	moveUp:.
+	moveToQuay
+	)
+
+eval :: (Action a b x y) State -> Result State
+eval (MoveUp _ _ _ _) st 			= Res st
+eval (MoveDown _ _ _ _) st 	  = Res st
+eval (Unlock _ _ _ _) 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 (Lock _ _ _ _) 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 (MoveToShip _ _ _ _) st  = Res {st & craneOnQuay = False } 
+eval (MoveToQuay _ _ _ _) st  = Res {st & craneOnQuay = True } 
+eval (Wait _ _ _ _) st 			  = Res st
+eval (:. a b) st = 
+	case eval a st of
+		Res st1 -> eval b st1
+		Err str -> Err str
+eval (WhileContainerBelow a) st = if quayNotEmpty iteration (Res st)
+	where 
+		quayNotEmpty = length st.onQuay > 0
+		iteration = case eval a st of 
+			(Res st1)	-> eval (WhileContainerBelow a) st1
+			(Err str) -> Err str
+
+print :: (Action a b x y) -> [String]
+print (MoveToShip _ _ _ _) 		= ["moveToShip"]
+print (MoveToQuay _ _ _ _) 		= ["moveToQuay"]
+print (MoveUp _ _ _ _) 				= ["moveUp"]
+print (MoveDown _ _ _ _) 			= ["moveDown"]
+print (Lock _ _ _ _) 					= ["lock"]
+print (Unlock _ _ _ _) 				= ["unlock"]
+print (Wait _ _ _ _) 					= ["wait"]
+print (:. a b) 								= print a ++ [":.":"\n": print b ]
+print (WhileContainerBelow a) = ["whileContainerBelow":"(":"\n": (print a ++ [")"])]
+
+//Start = loadShip
+Start = eval loadShip initialState
+//Start = print loadShip