6 import Control.Applicative
11 :: BM a b = {t :: a->b, f :: b->a, t2 :: A.c t:(t c a)->t c b, f2 :: A.c t:(t b c)->t a c}
12 bm = {t = id, f = id, t2 = id, f2 = id}
15 = MoveToShip (BM b High) (BM a High)
16 | MoveToQuay (BM b High) (BM a High)
17 | MoveUp (BM b Low) (BM a High)
18 | MoveDown (BM b High) (BM a Low)
19 | Lock (BM b Low) (BM a Low)
20 | Unlock (BM b Low) (BM a Low)
22 | E.i: (:.) infixl 1 (Action b i) (Action i a)
23 | WhileContainerBelow (BM b a) (Action a a)
27 moveToShip = MoveToShip bm bm
28 moveToQuay = MoveToQuay bm bm
30 moveDown = MoveDown bm bm
34 whileContainerBelow = WhileContainerBelow bm
41 , locked :: Maybe String
46 , onQuay = ["apples","beer","camera's"]
53 eval :: (Action i f) State -> MaybeErrorString State
54 eval (MoveToShip _ _) s = pure {s & craneOnQuay = False}
55 eval (MoveToQuay _ _) s = pure {s & craneOnQuay = True}
56 eval (MoveUp _ _) s = pure {s & craneUp = True}
57 eval (MoveDown _ _) s = pure {s & craneUp = False}
58 eval (Lock _ _) s=:{locked=Nothing}
61 [c:r] = pure {s & onQuay = r, locked = Just c}
62 [] = Error "Cannot lock container on empty quay"
64 [c:r] = pure {s & onShip = r, locked = Just c}
65 [] = Error "Cannot lock container on empty ship"
66 eval (Lock _ _) s=:{locked=(Just c)}
67 = Error ("Cannot lock new container, craner contains " +++ c)
68 eval (Unlock _ _) s=:{locked=(Just c)}
69 | s.craneOnQuay = pure {s & onQuay = [c:s.onQuay], locked = Nothing}
70 = pure {s & onShip = [c:s.onShip], locked = Nothing}
71 eval (Unlock b1 b2) s=:{locked=Nothing}
72 = Error "Cannot unlock container, crane contains nothing"
73 eval (Wait _) s = Ok s
74 eval (a :. b) s = eval a s >>= eval b
75 eval (WhileContainerBelow _ action) s
76 | s.craneOnQuay && not (isEmpty s.onQuay) || not s.craneOnQuay && not (isEmpty s.onShip)
77 = eval (action :. whileContainerBelow action) s
81 p1 = moveToShip :. moveDown
83 //p2 = moveToShip :. wait :. lock // the required type error