From df57069c138d29c6f7f6d93b0c8463b29d74f15c Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Sat, 18 Nov 2017 11:42:56 +0100 Subject: Use Data.Set; fix bug where program was not updated --- assignment-8/skeleton8.icl | 74 +++++++++++++++++++++++++++------------------- 1 file 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 -- cgit v1.2.3