Merge branch 'master' of git.martlubbers.net:clean-tests

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

diff --git a/afp/a10/a10.icl b/afp/a10/a10.icl
index fabad8c..1da0267 100644 (file)
--- a/afp/a10/a10.icl
+++ b/afp/a10/a10.icl
@@ -7,6 +7,7 @@ import Control.Applicative
 import Control.Monad
 import Data.Maybe
 import Data.Error
+import Text => qualified join
 
 :: 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}
 bm = {t = id, f = id, t2 = id, f2 = id}
@@ -14,11 +15,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
@@ -70,8 +71,8 @@ eval (Unlock _ _)     s=:{locked=(Just c)}
                        = 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 (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
@@ -85,3 +86,49 @@ opt (a :. b) = opt a :. opt b
 opt x = x
 
 Start = opt (moveToShip :. wait :. moveDown)
+//print :: (Action i f) [String] -> [String]
+//print (MoveToShip _ _) s = ["Move to ship":s]
+//print (MoveToQuay _ _) s = ["Move to quay":s]
+//print (MoveUp _ _)     s = ["Move up":s]
+//print (MoveDown _ _)   s = ["Move down":s]
+//print (Lock _ _)       s = ["Lock":s]
+//print (Unlock _ _)     s = ["Unlock":s]
+//print (Wait _)         s = ["Wait":s]
+//print (a :. b)         s = print a ["\n":print b s]
+//print (WhileContainerBelow _ a) s
+//     = ["While container below (":indent ["\n":print a [")":s]]]
+//where
+//     indent s = map (\s->if (s.[0] == '\n') (s +++ "\t") s)
+//
+
+print :: (Action i f) String [String] -> [String]
+print (MoveToShip _ _) i s = [i,"Move to ship":s]
+print (MoveToQuay _ _) i s = [i,"Move to quay":s]
+print (MoveUp _ _)     i s = [i,"Move up":s]
+print (MoveDown _ _)   i s = [i,"Move down":s]
+print (Lock _ _)       i s = [i,"Lock":s]
+print (Unlock _ _)     i s = [i,"Unlock":s]
+print (Wait _)         i s = [i,"Wait":s]
+print (a :. b)         i s = print a i ["\n":print b i s]
+print (WhileContainerBelow _ a) i s
+       = [i,"While container below (\n":print a ("\t"+++i) ["\n",i,")":s]]
+
+Start = print loadShip "" []
+
+p1 = moveToShip :. moveDown
+
+//p2 = moveToShip :. wait :. lock // the required type error
+
+loadShip =
+       whileContainerBelow (
+               moveDown:.
+               lock:.
+               moveUp:.
+               moveToShip:.
+               wait:.
+               moveDown:.
+               wait:.
+               unlock:.
+               moveUp:.
+               moveToQuay
+       ) :. wait