Commit 50c4f265 authored by Job Cuppen's avatar 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