+++ /dev/null
-module a10
-
-import StdEnv
-
-import Data.Functor
-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}
-
-:: 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)
- | E.i: (:.) infixl 1 (Action b i) (Action i a)
- | WhileContainerBelow (BM b a) (Action a a)
-:: High = High
-:: Low = Low
-
-moveToShip = MoveToShip bm bm
-moveToQuay = MoveToQuay bm bm
-moveUp = MoveUp bm bm
-moveDown = MoveDown bm bm
-lock = Lock bm bm
-unlock = Unlock bm bm
-wait = Wait bm
-whileContainerBelow = WhileContainerBelow bm
-
-:: State =
- { onShip :: [String]
- , onQuay :: [String]
- , craneUp :: Bool
- , craneOnQuay :: Bool
- , locked :: Maybe String
- }
-
-state0 =
- { onShip = []
- , onQuay = ["apples","beer","camera's"]
- , craneUp = True
- , craneOnQuay = True
- , locked = Nothing
- }
-
-// ================
-eval :: (Action i f) State -> MaybeErrorString State
-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"
-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
-
-//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
repositories / clean-tests.git / blobdiff