Commit b13befee authored by Job Cuppen's avatar Job Cuppen

all

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