afp/a10/a10.icl

   1 module a10
   2
   3 import StdEnv
   4
   5 import Data.Functor
   6 import Control.Applicative
   7 import Control.Monad
   8 import Data.Maybe
   9 import Data.Error
  10
  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}
  13
  14 :: Action b a
  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)
  21         | Wait (BM b a)
  22         | E.i: (:.) infixl 1 (Action b i) (Action i a)
  23         | WhileContainerBelow (BM b a) (Action a a)
  24 :: High = High
  25 :: Low = Low
  26
  27 moveToShip = MoveToShip bm bm
  28 moveToQuay = MoveToQuay bm bm
  29 moveUp     = MoveUp     bm bm
  30 moveDown   = MoveDown   bm bm
  31 lock       = Lock       bm bm
  32 unlock     = Unlock     bm bm
  33 wait       = Wait       bm
  34 whileContainerBelow = WhileContainerBelow bm
  35
  36 :: State =
  37         { onShip      :: [String]
  38         , onQuay      :: [String]
  39         , craneUp     :: Bool
  40         , craneOnQuay :: Bool
  41         , locked      :: Maybe String
  42         }
  43
  44 state0 =
  45         { onShip = []
  46         , onQuay = ["apples","beer","camera's"]
  47         , craneUp = True
  48         , craneOnQuay = True
  49         , locked = Nothing
  50         }
  51
  52 // ================
  53 :: Sem a = Sem ((MaybeErrorString State) -> MaybeErrorString State)
  54
  55
  56 eval :: (Action i f) State -> MaybeErrorString State
  57 eval (MoveToShip b1 b2) s = pure {s & craneOnQuay = False}
  58 eval (MoveToQuay b1 b2) s = pure {s & craneOnQuay = True}
  59 eval (MoveUp b1 b2)     s = pure {s & craneUp = True}
  60 eval (MoveDown b1 b2)   s = pure {s & craneUp = False}
  61 eval (Lock b1 b2) s=:{locked=Nothing}
  62         | s.craneOnQuay =
  63                         =
  64 eval (Lock b1 b2) s=:{locked=Nothing} = Error ("Cannot lock new container, craner contains " + container)
  65 eval (Lock b1 b2) s=:{locked=(Just _)} = Error ("Cannot lock new container, craner contains " + container)
  66         Nothing
  67                 | s.craneOnQuay
  68                 = case s.onQuay of
  69                         [c:r] = pure {s & onQuay = r, locked = Just c}
  70                         []    = Error "Cannot lock container on empty quay"
  71                 = case s.onShip of
  72                         [c:r] = pure {s & onShip = r, locked = Just c}
  73                         []    = Error "Cannot lock container on empty ship"
  74         Just container
  75                 = Error ("Cannot lock new container, craner contains " + container)
  76 eval (Unlock b1 b2)     s =case s.locked of
  77         Just container | s.craneOnQuay
  78                  = Result {s & onQuay = [container:s.onQuay], locked = Nothing}
  79                          = Result {s & onShip = [container:s.onShip], locked = Nothing}
  80                         Nothing = Error "Cannot unlock container, craner contains nothing"
  81                 Wait bm = Result s
  82                 a :. b  = eval b (eval a r)
  83                 WhileContainerBelow bm action
  84                         | s.craneOnQuay && not (isEmpty s.onQuay) ||
  85                           not s.craneOnQuay && not (isEmpty s.onShip)
  86                         = eval (action :. WhileContainerBelow bm action) r
  87                         = r
  88 */
  89
  90 Start = 42