all

week12_job/12.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 i j x y
+	= MoveToShip (BM a High) (BM b High) (BM i j) 								 (BM x Quay) (BM y Ship)	// move the crane to the ship
+  | MoveToQuay (BM a High) (BM b High) (BM i j) 								 (BM x Ship) (BM y Quay)	// move the crane to the quay
+  | MoveUp		 (BM a Low)	 (BM b High) (BM i j)									 (BM x y)   							// moves the crane up
+  | MoveDown	 (BM a High) (BM b Low)	 (BM i j)									 (BM x y)									// moves the crane down
+  | Lock			 (BM a Low)  (BM b Low)	 (BM i Empty) (BM j Full)  (BM x y)   							// locks the top container of the stack under the crane
+	| Unlock		 (BM a Low)  (BM b Low)	 (BM i Full)  (BM j Empty) (BM x y)   							// unlocks the container the crane is carrying, put it on the stack
+	| Wait			 (BM a b) 	             (BM i j) 	               (BM x y)									// do nothing
+	| E.c k z:(:.) infixl 1 (Action a c i k x z) (Action c b k j z y)	 											// sequence of two actions
+	| WhileContainerBelow (Action High High Empty Empty Quay Quay) 													// repeat action while there is a container at current position
+
+:: High = High
+:: Low  = Low
+
+:: Quay = Quay
+:: Ship = Ship
+
+:: Full = Full
+:: Empty = Empty
+
+:: Result r = Res r | Err String
+
+:: 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
+	}
+
+moveDown :: Action High Low i i x x
+moveDown = MoveDown bm bm bm bm 
+
+moveUp :: Action Low High i i x x
+moveUp = MoveUp bm bm bm bm
+
+moveToShip :: Action High High i i Quay Ship
+moveToShip = MoveToShip bm bm bm bm bm 
+
+moveToQuay :: Action High High i i Ship Quay
+moveToQuay = MoveToQuay bm bm bm bm bm
+
+lock :: Action Low Low Empty Full x x
+lock = Lock bm bm bm bm bm
+
+test :: Action High High Empty Full Quay Quay
+test = moveUp :. lock
+
+wait :: Action a a i i x x
+wait = Wait bm bm bm
+
+unlock :: Action Low Low Full Empty x x
+unlock = Unlock bm bm bm bm bm
+
+whileContainerBelow :: (Action High High Empty Empty Quay Quay) -> Action High High Empty Empty Quay Quay
+whileContainerBelow a = WhileContainerBelow a
+
+loadShip :: Action High High Empty Empty Quay Quay
+loadShip = whileContainerBelow (
+	moveDown:. 
+	lock:.
+	moveUp:.
+	moveToShip:.
+	wait:.
+	moveDown:.
+	wait:.
+	unlock:. 
+	moveUp:.
+	moveToQuay
+	)
+
+highError :: String -> Result State
+highError str = Err ("Can not do '" +++ str +++ "', crane is high!")
+
+eval :: (Action a b i j x y) State -> Result State
+eval (MoveUp _ _ _ _) st 				= Res {st & craneUp = True}
+eval (MoveDown _ _ _ _) st 	  	= Res {st & craneUp = False}
+eval (Unlock _ _ _ _ _) st = if st.craneUp
+	(highError "Unlock")
+	case st.locked of
+		(Just a)  -> if st.craneOnQuay (unlockResultQuay a) (unlockResultShip a)
+		(Nothing) -> (Err "Crane is empty!")
+	where
+		unlockResultShip a = Res {st & locked = Nothing, onShip = [a:st.onShip] }
+		unlockResultQuay a = Res {st & locked = Nothing, onQuay = [a:st.onQuay] }
+eval (Lock _ _ _ _ _) st = if st.craneUp
+	(highError "Lock")
+	if (isJust st.locked)
+		(Err "Crane is full!")
+		if st.craneOnQuay lockResultQuay lockResultShip
+	where
+		lockResultShip = case st.onShip of
+			[x:xs] -> (Res {st & locked = Just x, onShip = xs}) 
+			[]     -> (Err "No crates left on ship")
+		lockResultQuay = case st.onQuay of
+			[x:xs] -> (Res {st & locked = Just x, onQuay = xs })
+			[]     -> (Err "No crates left on quay")
+eval (MoveToShip _ _ _ _ _) st  	= if (not st.craneOnQuay)
+	(Err "Can not move to Ship already on Ship")
+	(Res {st & craneOnQuay = False })
+eval (MoveToQuay _ _ _ _ _) st  	= if st.craneOnQuay
+	(Err "Can not move to Quay already on Quay")
+	(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 (containerBelow st) iteration (Res st)
+	where 
+		iteration 		= case eval a st of 
+			(Res st1)	-> eval (WhileContainerBelow a) st1
+			(Err str) -> Err str
+
+isNotEmpty = (not o isEmpty)
+
+containerBelow :: State -> Bool
+containerBelow s = if s.craneOnQuay 
+	(isNotEmpty s.onQuay)
+	(isNotEmpty s.onShip)
+
+print :: (Action a b i j 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 = optimize (wait:.moveUp)
+Start = eval loadShip initialState
+//Start = print loadShip

week12_job/ex12.icl

@@ -4,26 +4,26 @@ import StdEnv, StdMaybe, StdDebug
 import Data.Functor, Control.Applicative, Control.Monad
 
 ::BM a b =
-	{t::a -> b
-	,f::b -> a
+	{t:: a -> b
+	,f:: b -> a
 	}
 
 bm :: BM a a
 bm = 
-	{f = id
-	,t = id
+	{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
+:: Action a b i j x y
+	= MoveToShip (BM a High) (BM b High) (BM i j) 								 (BM x Quay) (BM y Ship)	// move the crane to the ship
+  | MoveToQuay (BM a High) (BM b High) (BM i j) 								 (BM x Ship) (BM y Quay)	// move the crane to the quay
+  | MoveUp		 (BM a Low)	 (BM b High) (BM i j)									 (BM x y)   							// moves the crane up
+  | MoveDown	 (BM a High) (BM b Low)	 (BM i j)									 (BM x y)									// moves the crane down
+  | Lock			 (BM a Low)  (BM b Low)	 (BM i Empty) (BM j Full)  (BM x y)   							// locks the top container of the stack under the crane
+	| Unlock		 (BM a Low)  (BM b Low)	 (BM i Full)  (BM j Empty) (BM x y)   							// unlocks the container the crane is carrying, put it on the stack
+	| Wait			 (BM a b) 	             (BM i j) 	               (BM x y)									// do nothing
+	| E.c k z:(:.) infixl 1 (Action a c i k x z) (Action c b k j z y)	 											// sequence of two actions
+	| WhileContainerBelow (Action High High Empty Empty Quay Quay) 													// repeat action while there is a container at current position
 
 :: High = High
 :: Low  = Low
@@ -31,12 +31,16 @@ bm =
 :: Quay = Quay
 :: Ship = Ship
 
+:: Full = Full
+:: Empty = Empty
+
 :: Result r = Res r | Err String
 
 :: State = 
 	{onShip      :: [Container]
 	,onQuay      :: [Container]
 	,craneOnQuay :: Bool
+	,craneUp		 :: Bool
 	,locked 		 :: Maybe Container
 	}
 
@@ -46,34 +50,35 @@ initialState =
 	{onShip 		 = []
 	,onQuay 		 = ["apples", "beer", "camera"]
 	,craneOnQuay = True
+	,craneUp 		 = True
 	,locked 		 = Nothing
 	}
 
-moveDown :: Action High Low x x
-moveDown = MoveDown bm bm bm bm
+moveDown :: Action High Low i i x x
+moveDown = MoveDown bm bm bm bm 
 
-moveUp :: Action Low High x x
+moveUp :: Action Low High i i x x
 moveUp = MoveUp bm bm bm bm
 
-moveToShip :: Action High High Quay Ship
-moveToShip = MoveToShip bm bm bm bm
+moveToShip :: Action High High i i Quay Ship
+moveToShip = MoveToShip bm bm bm bm bm 
 
-moveToQuay :: Action High High Ship Quay
-moveToQuay = MoveToQuay bm bm bm bm 
+moveToQuay :: Action High High i i Ship Quay
+moveToQuay = MoveToQuay bm bm bm bm bm
 
-lock :: Action Low Low x x
-lock = Lock bm bm bm bm 
+lock :: Action Low Low Empty Full x x
+lock = Lock bm bm bm bm bm
 
-wait :: Action a a x x
-wait = Wait bm bm bm bm 
+wait :: Action a a i i x x
+wait = Wait bm bm bm
 
-unlock :: Action Low Low x x
-unlock = Unlock bm bm bm bm
+unlock :: Action Low Low Full Empty x x
+unlock = Unlock bm bm bm bm bm
 
-whileContainerBelow :: (Action High High Quay Quay) -> Action High High Quay Quay
+whileContainerBelow :: (Action High High Empty Empty Quay Quay) -> Action High High Empty Empty Quay Quay
 whileContainerBelow a = WhileContainerBelow a
 
-loadShip :: Action High High Quay Quay
+loadShip :: Action High High Empty Empty Quay Quay
 loadShip = whileContainerBelow (
 	moveDown:. 
 	lock:.
@@ -87,40 +92,66 @@ loadShip = whileContainerBelow (
 	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)
+highError :: String -> Result State
+highError str = Err ("Can not do '" +++ str +++ "', crane is high!")
+
+eval :: (Action a b i j x y) State -> Result State
+eval (MoveUp _ _ _ _) st 				= Res {st & craneUp = True}
+eval (MoveDown _ _ _ _) st 	  	= Res {st & craneUp = False}
+eval (Unlock _ _ _ _ _) st = if st.craneUp
+	(highError "Unlock")
+	case st.locked of
+		(Just a)  -> if st.craneOnQuay (unlockResultQuay a) (unlockResultShip a)
+		(Nothing) -> (Err "Crane is empty!")
+	where
+		unlockResultShip a = Res {st & locked = Nothing, onShip = [a:st.onShip] }
+		unlockResultQuay a = Res {st & locked = Nothing, onQuay = [a:st.onQuay] }
+eval (Lock _ _ _ _ _) st = if st.craneUp
+	(highError "Lock")
+	if (isJust st.locked)
+		(Err "Crane is full!")
+		if st.craneOnQuay lockResultQuay lockResultShip
+	where
+		lockResultShip = case st.onShip of
+			[x:xs] -> (Res {st & locked = Just x, onShip = xs}) 
+			[]     -> (Err "No crates left on ship")
+		lockResultQuay = case st.onQuay of
+			[x:xs] -> (Res {st & locked = Just x, onQuay = xs })
+			[]     -> (Err "No crates left on quay")
+eval (MoveToShip _ _ _ _ _) st  	= if (not st.craneOnQuay)
+	(Err "Can not move to Ship already on Ship")
+	(Res {st & craneOnQuay = False })
+eval (MoveToQuay _ _ _ _ _) st  	= if st.craneOnQuay
+	(Err "Can not move to Quay already on Quay")
+	(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 (containerBelow st) iteration (Res st)
 	where 
-		quayNotEmpty = length st.onQuay > 0
-		iteration = case eval a st of 
+		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"]
+isNotEmpty = (not o isEmpty)
+
+containerBelow :: State -> Bool
+containerBelow s = if s.craneOnQuay 
+	(isNotEmpty s.onQuay)
+	(isNotEmpty s.onShip)
+
+print :: (Action a b i j 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 = optimize (wait:.moveUp)
+Start = eval lock initialState
 //Start = print loadShip