--- /dev/null
+module a10
+
+import StdEnv
+
+import Data.Functor
+import Control.Applicative
+import Control.Monad => qualified join
+import Control.Monad.Trans
+import Control.Monad.State
+import Data.Maybe
+import Data.Error
+import Data.Either
+import Data.Func
+import Text
+
+:: Step pre post = Step
+:: High = High
+:: Low = Low
+
+class action v
+where
+ moveToShip :: v (Step High High)
+ moveToQuay :: v (Step High High)
+ moveUp :: v (Step Low High)
+ moveDown :: v (Step High Low)
+ lock :: v (Step Low Low)
+ unlock :: v (Step Low Low)
+ wait :: v (Step a a)
+ (:.) infixl 1 :: (v (Step a b)) (v (Step b c)) -> v (Step a c)
+ While :: (v Bool) (v (Step a a)) -> v (Step a a)
+
+class expr v
+where
+ containersBelow :: v Int
+ lit :: t -> v t | toString t
+ (<.) infix 4 :: (v t) (v t) -> (v Bool) | Ord t
+ (>.) infix 4 :: (v t) (v t) -> (v Bool) | Ord t
+ (+.) infix 4 :: (v t) (v t) -> (v t) | + t
+
+:: Var a = Var Int
+class var v
+where
+ def :: (v t) ((v (Var t)) -> (v (Step a b))) -> v (Step a b) | TC t
+ var :: (v (Var t)) -> v t | TC t
+ (=.) infixr 2 :: (v (Var t)) (v t) -> v (Step a a) | TC t
+
+//Printing
+:: Printer a = P (Int Int [String] -> [String])
+runPrinter (P a) = a 0 0
+
+word :: String -> Printer a
+word s = P \v i c->[createArray i '\t',s:c]
+
+instance action Printer
+where
+ moveToShip = word "moveToShip"
+ moveToQuay = word "moveToQuay"
+ moveUp = word "moveUp"
+ moveDown = word "moveDown"
+ lock = word "lock"
+ unlock = word "unlock"
+ wait = word "wait"
+ (:.) (P a) (P b) = P \v i c->a v i [":.\n":b v i c]
+ While (P b) (P a) = P \v i c->["while (":b v 0 [")\n":a v (i+1) ["\n)":c]]]
+
+instance expr Printer
+where
+ containersBelow = P \v i c->["containerBelow":c]
+ lit x = P \v i c->[toString x:c]
+ (<.) (P x) (P y) = P \v i c->x v i [" < ":y v i c]
+ (>.) (P x) (P y) = P \v i c->x v i [" > ":y v i c]
+ (+.) (P x) (P y) = P \v i c->x v i [" + ":y v i c]
+
+varname i = "v" +++ toString i
+instance var Printer
+where
+ def (P e) fun = P \v i c->[createArray i '\t',"def ":e v i [" \\",varname v,".\n":let (P f) = fun (P \_ i c->[varname v:c]) in f (inc v) i c]]
+ var (P e) = P e
+ (=.) (P a) (P b) = P \v i c->[createArray i '\t':a v i [" = ":b v i c]]
+
+//Evaluating
+:: Eval a :== StateT SemState (Either String) a
+cast f = f >>| pure Step
+fail s = liftT (Left s)
+runEval = runStateT
+instance action (StateT SemState (Either String))
+where
+ moveToShip = cast $ modify (\s->{s & craneOnQuay=False})
+ moveToQuay = cast $ modify (\s->{s & craneOnQuay=True})
+ moveUp = cast $ modify (\s->{s & craneUp=True})
+ moveDown = cast $ modify (\s->{s & craneUp=False})
+ lock = cast $ getState >>= \s->case s of
+ {locked=Just _} = fail "Already locked"
+ {craneOnQuay=True,onQuay=[]} = fail "No container to lock to"
+ {craneOnQuay=False,onShip=[]} = fail "No container to lock to"
+ {craneOnQuay=True,onQuay=[x:xs]} = put {s & onQuay=xs,locked=Just x}
+ {craneOnQuay=False,onShip=[x:xs]} = put {s & onShip=xs,locked=Just x}
+ _ = fail "Shouldn't happen"
+ unlock = cast $ getState >>= \s->case s of
+ {locked=Nothing} = fail "Already unlocked"
+ {craneOnQuay=True,locked=Just x} = put {s & onQuay=[x:s.onQuay],locked=Nothing}
+ {craneOnQuay=False,locked=Just x} = put {s & onShip=[x:s.onShip],locked=Nothing}
+ _ = fail "Shouldn't happen"
+ wait = pure Step
+ (:.) x y = cast $ x >>| y
+ While x y = x >>= \b->if b (y :. (While x y)) (pure Step)
+
+instance expr (StateT SemState (Either String))
+where
+ containersBelow = gets (\s->length if s.craneOnQuay s.onQuay s.onShip)
+ lit x = pure x
+ (<.) x y = (<) <$> x <*> y
+ (>.) x y = (>) <$> x <*> y
+ (+.) x y = (+) <$> x <*> y
+
+instance var (StateT SemState (Either String))
+where
+ def d fun = d >>= \v->gets (\s->length s.variables) >>= \i->modify (\s->{s & variables=s.variables ++ [dynamic v]}) >>| fun (pure (Var i))
+ var a = a >>= \(Var i)->gets (\s->s.variables !! i) >>= cast
+ where
+ cast :: Dynamic -> StateT SemState (Either String) a | TC a
+ cast (a :: a^) = pure a
+ cast_ = fail "Something went horribly wrong"
+ (=.) a b = cast $ a >>= \(Var i)->b >>= \v->modify (\s->{s & variables=updateAt i (dynamic v) s.variables})
+
+:: SemState =
+ { onShip :: [String]
+ , onQuay :: [String]
+ , craneUp :: Bool
+ , craneOnQuay :: Bool
+ , locked :: Maybe String
+ , variables :: [Dynamic]
+ }
+
+state0 =
+ { onShip = []
+ , onQuay = ["apples","beer","camera's"]
+ , craneUp = True
+ , craneOnQuay = True
+ , locked = Nothing
+ , variables = []
+ }
+
+Start :: (String, Either String SemState, String, Either String SemState)
+Start =
+ ( concat $ runPrinter loadShip []
+ , execStateT loadShip state0
+ , concat $ runPrinter loadShip2 []
+ , execStateT loadShip2 state0
+ )
+
+loadShip =
+ While (containersBelow >. lit 0) (
+ moveDown:.
+ lock:.
+ moveUp:.
+ moveToShip:.
+ wait:.
+ moveDown:.
+ wait:.
+ unlock:.
+ moveUp:.
+ moveToQuay
+ )
+
+loadShip2 =
+ def containersBelow \n.
+ def (lit 0) \m.
+ While (var n >. lit 0) (
+ moveDown:.
+ lock:.
+ moveUp:.
+ moveToShip:.
+ wait:.
+ moveDown:.
+ wait:.
+ unlock:.
+ moveUp:.
+ moveToQuay:.
+ n =. var n +. lit (-1)
+ )
repositories / clean-tests.git / blobdiff