Commit 50c4f265 by Job Cuppen

### extra safety for moveship/quay

parent f4bfe004
 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
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