afp/a8/a8_old.icl

   1 module a8
   2
   3 /*
   4   Advanced Progrmming 2018, Assignment 8
   5   Pieter Koopman, pieter@cs.ru.nl
   6 */
   7 import StdEnv
   8
   9 import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set
  10
  11 import Control.Applicative
  12 import Control.Monad
  13 import Control.Monad.State
  14 import Control.Monad.Trans
  15 import Data.Func
  16 import Data.Functor
  17 import Data.Either
  18 import Data.Maybe
  19
  20 import Text => qualified join
  21
  22 import qualified Data.List as List
  23 import qualified Data.Map as Map
  24
  25 :: Expression
  26   = New      [Int]
  27   | Elem     Int
  28   | Variable Ident
  29   | Size     Set
  30   | (+.) infixl 6 Expression Expression
  31   | (-.) infixl 6 Expression Expression
  32   | (*.) infixl 7 Expression Expression
  33   | (=.) infixl 2 Ident Expression
  34
  35 :: Logical
  36   = TRUE | FALSE
  37   | (In) infix 4 Elem Set
  38   | (==.) infix 4 Expression Expression
  39   | (<=.) infix 4 Expression Expression
  40   | Not Logical
  41   | (||.) infixr 2 Logical Logical
  42   | (&&.) infixr 3 Logical Logical
  43
  44 :: Stmt
  45   = Expression Expression
  46   | Logical Logical
  47   | For Ident Set Stmt
  48   | If Logical Stmt Stmt
  49
  50 :: Set    :== Expression
  51 :: Elem   :== Expression
  52 :: Ident  :== String
  53
  54 // === State
  55 :: Val :== Either Int [Int]
  56 :: SemState :== 'Map'.Map String Val
  57
  58 :: Sem a :== StateT SemState (Either String) a
  59 store :: Ident Val -> Sem Val
  60 store k v = modify ('Map'.put k v) *> pure v
  61
  62 read :: Ident -> Sem Val
  63 read k = gets ('Map'.get k) >>= maybe (fail "Unknown ident") pure
  64
  65 fail :: String -> Sem a
  66 fail s = liftT (Left s)
  67
  68 // === semantics
  69 isset :: (Sem Val) -> Sem [Int]
  70 isset s = s >>= either (\_->fail "Expected Set, got Elem") pure
  71
  72 iselem :: (Sem Val) -> Sem Int
  73 iselem s = s >>= either pure (\_->fail "Expected Elem, got Set")
  74
  75 evalExpr :: Expression -> Sem Val
  76 evalExpr (New s)      = pure $ Right s
  77 evalExpr (Elem i)     = pure $ Left i
  78 evalExpr (Variable i) = read i
  79 evalExpr (Size s)     = isset (evalExpr s) >>= pure o Left o length
  80 evalExpr (l +. r)     = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of
  81         (Left  x, Left  y) = pure $ Left (x + y)
  82         (Left  x, Right y) = pure $ Right $ 'List'.union [x] y
  83         (Right x, Left  y) = pure $ Right $ 'List'.union x [y]
  84         (Right x, Right y) = pure $ Right $ 'List'.union x y
  85 evalExpr (l -. r)     = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of
  86         (Left  x, Left  y) = pure $ Left (x - y)
  87         (Left  x, Right y) = fail "Elem -. Set is illegal"
  88         (Right x, Left  y) = pure $ Right $ 'List'.intersect x [y]
  89         (Right x, Right y) = pure $ Right $ 'List'.intersect x y
  90 evalExpr (l *. r)     = evalExpr l >>= \x->evalExpr r >>= \y->case (x, y) of
  91         (Left  x, Left  y) = pure $ Left (x * y)
  92         (Left  x, Right y) = pure $ Right [x*y\\y<-y]
  93         (Right x, Left  y) = fail "Set *. Elem is illegal"
  94         (Right x, Right y) = pure $ Right $ 'List'.intersect x y
  95 evalExpr (v =. b)    = evalExpr b >>= store v
  96
  97 evalLogic :: Logical -> Sem Bool
  98 evalLogic TRUE        = pure True
  99 evalLogic FALSE       = pure False
 100 evalLogic (e In s)    = liftM2 'List'.elem (iselem (evalExpr e)) (isset (evalExpr s))
 101 evalLogic (e1 ==. e2) = liftM2 (===) (evalExpr e1) (evalExpr e2)
 102 evalLogic (e1 <=. e2) = evalExpr e1 >>= \x->evalExpr e2 >>= \y->case (x, y) of
 103         (Left e1, Left e2) = pure $ e1 < e2
 104         (Left e1, Right e2) = pure $ True
 105         (Right e1, Left e2) = pure $ False
 106         (Right e1, Right e2) = pure $ length e1 < length e2
 107 evalLogic (Not l)     = not <$> evalLogic l
 108 evalLogic (l1 ||. l2) = liftM2 (||) (evalLogic l1) (evalLogic l2)
 109 evalLogic (l1 &&. l2) = liftM2 (&&) (evalLogic l1) (evalLogic l2)
 110
 111 evalStmt :: Stmt -> Sem ()
 112 evalStmt (Expression e) = evalExpr e >>| pure ()
 113 evalStmt (Logical l)    = evalLogic l >>| pure ()
 114 evalStmt (For i e s)    = (evalExpr e >>= store i) *> evalStmt s
 115 evalStmt (If l s1 s2)   = evalLogic l >>= \b->if b (evalStmt s1) (evalStmt s2)
 116
 117 printExpr :: Expression [String] -> [String]
 118 printExpr (New s)      c = ["[":'List'.intersperse "," $ map toString s] ++ ["]":c]
 119 printExpr (Elem i)     c = [toString i:c]
 120 printExpr (Variable i) c = [i:c]
 121 printExpr (Size s)     c = ["size(":printExpr s [")":c]]
 122 printExpr (l +. r)     c = ["(":printExpr l ["+.":printExpr r [")":c]]]
 123 printExpr (l -. r)     c = ["(":printExpr l ["-.":printExpr r [")":c]]]
 124 printExpr (l *. r)     c = ["(":printExpr l ["*.":printExpr r [")":c]]]
 125 printExpr (l =. r)     c = [l,"=.":printExpr r c]
 126
 127 printLogic :: Logical [String] -> [String]
 128 printLogic TRUE        c = ["True":c]
 129 printLogic FALSE       c = ["False":c]
 130 printLogic (e In s)    c = printExpr e [" in ":printExpr s c]
 131 printLogic (e1 ==. e2) c = ["(":printExpr e1 ["==.":printExpr e2 [")":c]]]
 132 printLogic (e1 <=. e2) c = ["(":printExpr e1 ["<=.":printExpr e2 [")":c]]]
 133 printLogic (Not l)     c = ["not (":printLogic l [")":c]]
 134 printLogic (l1 ||. l2) c = ["(":printLogic l1 ["||.":printLogic l2 [")":c]]]
 135 printLogic (l1 &&. l2) c = ["(":printLogic l1 ["&&.":printLogic l2 [")":c]]]
 136
 137 printStmt :: Stmt [String] -> [String]
 138 printStmt (Expression e) c = printExpr e c
 139 printStmt (Logical l)    c = printLogic l c
 140 printStmt (For i e s)    c = ["For ",i,"=":printExpr e ["in":printStmt s ["Rof":c]]]
 141 printStmt (If l s1 s2)   c = ["If":printLogic l ["then":printStmt s1 ["else":printStmt s2 ["Fi":c]]]]
 142
 143 // === simulation
 144 stateShared :: Shared SemState
 145 stateShared = sharedStore "sharedSemState" 'Map'.newMap
 146
 147 derive class iTask Expression, Logical, Stmt
 148
 149 main :: Task SemState
 150 main = 'iTasks'.forever $
 151             enterInformation "Enter a statement" []
 152         -|| viewSharedInformation "Old state" [ViewAs printState] stateShared
 153         >&^ viewSharedInformation "Print" [ViewAs viewer]
 154         >&> viewSharedInformation "New state" [ViewAs $ fmap printState] o mapRead evaler o ((>*<) stateShared)
 155         >>* [OnAction (Action "Execute") $ ifValue (\e->e=:(Right _)) $ \(Right s)->set s stateShared]
 156 where
 157         viewer = maybe
 158                 "No expression selected"
 159                 ('Text'.join " " o flip printStmt [])
 160         evaler (s, t) = maybe
 161                 (Left "No expression selected")
 162                 (\e->execStateT (evalStmt e) s) t
 163         printState m = [k +++ "=" +++ toSingleLineText v\\(k,v)<-'Map'.toList m]
 164
 165 Start w = doTasks main w