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