diff options
Diffstat (limited to 'assignment-8')
| -rw-r--r-- | assignment-8/skeleton8.icl | 74 |
1 files changed, 44 insertions, 30 deletions
diff --git a/assignment-8/skeleton8.icl b/assignment-8/skeleton8.icl index ed8e447..122418f 100644 --- a/assignment-8/skeleton8.icl +++ b/assignment-8/skeleton8.icl @@ -17,17 +17,19 @@ import Control.Monad from Control.Monad.State import :: StateT(StateT), gets, modify, runStateT,
instance Functor (StateT s m), instance Applicative (StateT s m),
instance Monad (StateT s m)
+import Data.Bifunctor
import Data.Error
from Data.Func import $, on, `on`
import Data.Functor
import Data.List
-import qualified Data.Map as Map
+import qualified Data.Map as M
import Data.Maybe
+import qualified Data.Set as S
import Data.Tuple
from Text import <+, class Text(concat), instance Text String
from iTasks import
- class iTask, class toPrompt, class Publishable, instance Publishable Task,
+ class iTask, class toPrompt, class Publishable, instance Publishable (Task a),
instance toPrompt String, instance Functor Task,
class TApplicative, instance TApplicative Task,
generic gEq, generic gDefault, generic JSONDecode, generic JSONEncode,
@@ -76,9 +78,9 @@ import qualified iTasks :: Val
= VElem Int
- | VSet [Int]
+ | VSet ('S'.Set Int)
-:: State :== 'Map'.Map Ident Val
+:: State :== 'M'.Map Ident Val
:: Sem a :== StateT State (MaybeError String) a
// Or define :: Sem a = Sem (s -> MaybeErrorString (a,s)) and copy the relevant
@@ -86,11 +88,11 @@ import qualified iTasks // The types of store, read and fail are more general so that these functions
// can be used with the Check monad below as well.
-store :: Ident v -> StateT ('Map'.Map Ident v) m v | Monad m
-store i v = modify ('Map'.put i v) $> v
+store :: Ident v -> StateT ('M'.Map Ident v) m v | Monad m
+store i v = modify ('M'.put i v) $> v
-read :: Ident -> StateT ('Map'.Map Ident v) (MaybeError String) v
-read i = gets ('Map'.get i) >>= \v -> case v of
+read :: Ident -> StateT ('M'.Map Ident v) (MaybeError String) v
+read i = gets ('M'.get i) >>= \v -> case v of
Nothing -> fail $ "unknown variable '" <+ i <+ "'"
Just v -> pure v
@@ -105,30 +107,30 @@ evalE = eval instance eval Expression Val
where
eval :: Expression -> Sem Val
- eval (New xs) = pure $ VSet xs
+ eval (New xs) = pure $ VSet $ 'S'.fromList xs
eval (Elem x) = pure $ VElem x
eval (Variable i) = read i
eval (Size s) = eval s >>= \xs -> case xs of
- VSet xs -> pure $ VElem $ length xs
+ VSet xs -> pure $ VElem $ 'S'.size xs
_ -> fail "Cannot apply Size to Elem"
eval (a +. b) = (liftA2 valAdd `on` eval) a b
where
valAdd (VElem i) (VElem j) = VElem $ i + j
- valAdd (VElem i) (VSet xs) = VSet $ removeDup [i:xs]
- valAdd (VSet xs) (VElem i) = VSet $ removeDup [i:xs]
- valAdd (VSet xs) (VSet ys) = VSet $ removeDup $ xs ++ ys
+ valAdd (VElem i) (VSet xs) = VSet $ 'S'.insert i xs
+ valAdd (VSet xs) (VElem i) = VSet $ 'S'.insert i xs
+ valAdd (VSet xs) (VSet ys) = VSet $ 'S'.union xs ys
eval (a -. b) = on (liftA2 tuple) eval a b >>= uncurry valSub
where
valSub (VElem i) (VElem j) = pure $ VElem $ i - j
valSub (VElem i) (VSet xs) = fail "Cannot subtract Set from Elem"
- valSub (VSet xs) (VElem i) = pure $ VSet $ removeMember i xs
- valSub (VSet xs) (VSet ys) = pure $ VSet $ removeMembers xs ys
+ valSub (VSet xs) (VElem i) = pure $ VSet $ 'S'.delete i xs
+ valSub (VSet xs) (VSet ys) = pure $ VSet $ 'S'.difference xs ys
eval (a *. b) = (liftA2 tuple `on` eval) a b >>= uncurry valMul
where
valMul (VElem i) (VElem j) = pure $ VElem $ i * j
- valMul (VElem i) (VSet xs) = pure $ VSet $ map ((*) i) xs
+ valMul (VElem i) (VSet xs) = pure $ VSet $ 'S'.mapSet ((*) i) xs
valMul (VSet xs) (VElem i) = fail "Cannot multiply Elem with Set"
- valMul (VSet xs) (VSet ys) = pure $ VSet [x \\ x <- xs | isMember x ys]
+ valMul (VSet xs) (VSet ys) = pure $ VSet $ 'S'.intersection xs ys
eval (n =. e) = eval e >>= store n
// === semantics
@@ -142,15 +144,16 @@ where eval TRUE = pure True
eval FALSE = pure False
eval (e In s) = (liftA2 tuple `on` eval) e s >>= \t -> case t of
- (VElem i, VSet xs) -> pure $ isMember i xs
+ (VElem i, VSet xs) -> pure $ 'S'.member i xs
_ -> fail "Can only apply In to Elem and Set"
eval (a ==. b) = (liftA2 tuple `on` eval) a b >>= \t -> case t of
(VElem i, VElem j) -> pure $ i == j
- (VSet xs, VSet ys) -> pure $ all (flip isMember ys) xs && length xs == length ys
+ (VSet xs, VSet ys) -> pure $ 'S'.isSubsetOf xs ys && 'S'.size xs == 'S'.size ys
+ // Cannot use == due to name clash
_ -> fail "Cannot apply == to Elem and Set"
eval (a <=. b) = (liftA2 tuple `on` eval) a b >>= \t -> case t of
(VElem i, VElem j) -> pure $ i <= j
- (VSet xs, VSet ys) -> pure $ all (flip isMember ys) xs
+ (VSet xs, VSet ys) -> pure $ 'S'.isSubsetOf xs ys
_ -> fail "Cannot apply <= to Elem and Set"
eval (Not b) = not <$> eval b
eval (a ||. b) = (liftA2 (||) `on` eval) a b
@@ -158,7 +161,7 @@ where :: Result
= RElem Int
- | RSet [Int]
+ | RSet ('S'.Set Int)
| RBool Bool
evalS :: (Stmt -> Sem Result)
@@ -180,10 +183,11 @@ where VElem n -> if (n < 0)
(fail "Cannot iterate until a negative value")
(eval $ For v (New [0..n-1]) e)
- VSet xs -> sequence [store v (VElem x) >>| eval e \\ x <- xs] >>= \xs ->
+ VSet xs -> sequence [store v (VElem x) >>| eval e \\ x <- xs`] >>= \xs ->
if (all (\x -> x=:(RElem _)) xs)
- (pure $ RSet [x \\ RElem x <- xs])
+ (pure $ RSet $ 'S'.fromList [x \\ RElem x <- xs])
(fail "Not all results of For loop were Elems")
+ with xs` = 'S'.toList xs
eval (Expression e) = vtor <$> eval e
where
vtor (VElem x) = RElem x
@@ -231,19 +235,29 @@ where // === simulation
-derive class iTask Expression, Logical, Stmt, Val, Result
+derive class iTask Expression, Logical, Stmt, Val, Result, 'S'.Set
simulate :: Stmt -> Task Stmt
simulate stmt =
- updateInformation (Title "Program") [UpdateUsing id const stmtEditor] stmt
+ updateInformation (Title "Program") [UpdateUsing id (flip const) stmtEditor] stmt
-|| 'iTasks'.allTasks
[ viewInformation (Title "String representation") [ViewAs printToString] stmt
, viewInformation (Title "Type") [ViewAs showtype] stmt
, viewInformation (Title "Execution") [ViewAs execute] stmt
] <<@ ArrangeHorizontal
where
- execute = fmap (appSnd 'Map'.toList) o flip runStateT 'Map'.newMap o evalS
- showtype = fmap fst o flip runStateT 'Map'.newMap o type
+ execute = fmap (bifmap showResult (map (appSnd showVal) o 'M'.toList))
+ o flip runStateT 'M'.newMap o evalS
+ showtype = fmap fst o flip runStateT 'M'.newMap o type
+
+ showVal :: Val -> String
+ showVal (VElem i) = toString i
+ showVal (VSet s) = concat (intersperse ", " [toString i \\ i <- 'S'.toList s])
+
+ showResult :: Result -> String
+ showResult (RElem i) = toString i
+ showResult (RSet s) = concat (intersperse ", " [toString i \\ i <- 'S'.toList s])
+ showResult (RBool b) = toString b
// NB: I want the input fields to be put vertically but don't see how that is
// possible; neither this nor this with Vertical nor
@@ -258,7 +272,7 @@ stmtEditor = gEditor{|*|} <<@ directionAttr Horizontal | TSet
| TBool
-:: Check a :== StateT ('Map'.Map Ident Type) (MaybeError String) a
+:: Check a :== StateT ('M'.Map Ident Type) (MaybeError String) a
derive class iTask Type
@@ -291,7 +305,7 @@ where _ -> pure TSet
type (v =. e) = type e >>= \t -> case t of
TBool -> fail "Cannot assign a boolean to a variable"
- _ -> modify ('Map'.put v t) $> t
+ _ -> modify ('M'.put v t) $> t
instance type Logical
where
@@ -345,7 +359,7 @@ derive genShow Stmt, Expression, Logical derive bimap []
test :: Stmt -> (MaybeErrorString Result, MaybeErrorString Type)
-test stm = (fst <$> runStateT (evalS stm) 'Map'.newMap, fst <$> runStateT (type stm) 'Map'.newMap)
+test stm = (fst <$> runStateT (evalS stm) 'M'.newMap, fst <$> runStateT (type stm) 'M'.newMap)
check :: Stmt -> Bool
check stm = isOk result || isError type
|