10

[clean-tests.git] / afp / a10 / a10.icl

diff --git a/afp/a10/a10.icl b/afp/a10/a10.icl
index c561796..9f4a7a5 100644 (file)
--- a/afp/a10/a10.icl
+++ b/afp/a10/a10.icl
@@ -14,11 +14,11 @@ bm = {t = id, f = id, t2 = id, f2 = id}
 :: Action b a
        = MoveToShip (BM b High) (BM a High)
        | MoveToQuay (BM b High) (BM a High)
-       | MoveUp (BM b Low) (BM a High)
-       | MoveDown (BM b High) (BM a Low)
-       | Lock (BM b Low) (BM a Low)
-       | Unlock (BM b Low) (BM a Low)
-       | Wait (BM b a)
+       | MoveUp     (BM b Low)  (BM a High)
+       | MoveDown   (BM b High) (BM a Low)
+       | Lock       (BM b Low)  (BM a Low)
+       | Unlock     (BM b Low)  (BM a Low)
+       | Wait       (BM b a)
        | E.i: (:.) infixl 1 (Action b i) (Action i a)
        | WhileContainerBelow (BM b a) (Action a a)
 :: High = High
@@ -50,41 +50,48 @@ state0 =
        }
 
 // ================
-:: Sem a = Sem ((MaybeErrorString State) -> MaybeErrorString State)
-
-
 eval :: (Action i f) State -> MaybeErrorString State
-eval (MoveToShip b1 b2) s = pure {s & craneOnQuay = False}
-eval (MoveToQuay b1 b2) s = pure {s & craneOnQuay = True}
-eval (MoveUp b1 b2)     s = pure {s & craneUp = True}
-eval (MoveDown b1 b2)   s = pure {s & craneUp = False}
-eval (Lock b1 b2) s=:{locked=Nothing}
-       | s.craneOnQuay =  
-                       =
-eval (Lock b1 b2) s=:{locked=Nothing} = Error ("Cannot lock new container, craner contains " + container)
-eval (Lock b1 b2) s=:{locked=(Just _)} = Error ("Cannot lock new container, craner contains " + container)
-       Nothing
-               | s.craneOnQuay
+eval (MoveToShip _ _) s = pure {s & craneOnQuay = False}
+eval (MoveToQuay _ _) s = pure {s & craneOnQuay = True}
+eval (MoveUp _ _)     s = pure {s & craneUp = True}
+eval (MoveDown _ _)   s = pure {s & craneUp = False}
+eval (Lock _ _)       s=:{locked=Nothing}
+       | s.craneOnQuay
                = case s.onQuay of
                        [c:r] = pure {s & onQuay = r, locked = Just c}
                        []    = Error "Cannot lock container on empty quay"
                = case s.onShip of
                        [c:r] = pure {s & onShip = r, locked = Just c}
                        []    = Error "Cannot lock container on empty ship"
-       Just container
-               = Error ("Cannot lock new container, craner contains " + container)
-eval (Unlock b1 b2)     s =case s.locked of
-       Just container | s.craneOnQuay
-                = Result {s & onQuay = [container:s.onQuay], locked = Nothing}
-                        = Result {s & onShip = [container:s.onShip], locked = Nothing}
-                       Nothing = Error "Cannot unlock container, craner contains nothing"
-               Wait bm = Result s
-               a :. b  = eval b (eval a r)
-               WhileContainerBelow bm action
-                       | s.craneOnQuay && not (isEmpty s.onQuay) ||
-                         not s.craneOnQuay && not (isEmpty s.onShip)
-                       = eval (action :. WhileContainerBelow bm action) r
-                       = r
-*/
+eval (Lock _ _)       s=:{locked=(Just c)}
+       = Error ("Cannot lock new container, craner contains " +++ c)
+eval (Unlock _ _)     s=:{locked=(Just c)}
+       | s.craneOnQuay = pure {s & onQuay = [c:s.onQuay], locked = Nothing}
+                       = pure {s & onShip = [c:s.onShip], locked = Nothing}
+eval (Unlock b1 b2)   s=:{locked=Nothing}
+       = Error "Cannot unlock container, crane contains nothing"
+eval (Wait _)       s = Ok s
+eval (a :. b)       s = eval a s >>= eval b
+eval (WhileContainerBelow _ action) s
+       | s.craneOnQuay && not (isEmpty s.onQuay) || not s.craneOnQuay && not (isEmpty s.onShip)
+               = eval (action :. whileContainerBelow action) s
+       = pure s
+
+Start = loadShip
+p1 = moveToShip :. moveDown
+
+//p2 = moveToShip :. wait :. lock // the required type error
 
-Start = 42
+loadShip =
+       whileContainerBelow (
+               moveDown:.
+               lock:.
+               moveUp:.
+               moveToShip:.
+               wait:.
+               moveDown:.
+               wait:.
+               unlock:.
+               moveUp:.
+               moveToQuay 
+       )