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 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}
  59         | s.craneOnQuay
  60                 = case s.onQuay of
  61                         [c:r] = pure {s & onQuay = r, locked = Just c}
  62                         []    = Error "Cannot lock container on empty quay"
  63                 = case s.onShip of
  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
  78         = pure s
  79
  80 Start = loadShip
  81 p1 = moveToShip :. moveDown
  82
  83 //p2 = moveToShip :. wait :. lock // the required type error
  84
  85 loadShip =
  86         whileContainerBelow (
  87                 moveDown:.
  88                 lock:.
  89                 moveUp:.
  90                 moveToShip:.
  91                 wait:.
  92                 moveDown:.
  93                 wait:.
  94                 unlock:.
  95                 moveUp:.
  96                 moveToQuay
  97         )