Commit a1d6b4e1 authored by Reg Huijben's avatar Reg Huijben

Expressions

parent b4a0e0c5
module week11_reg
import iTasks => qualified return, >>=, >>|, sequence, forever, :: Set
import Data.Functor, Control.Applicative, Control.Monad, Data.List
import Data.Tuple
import qualified Data.Map as Map
instance Functor Sem where
fmap f (Sem g) = Sem \s.case g s of
(Res a,s) = (Res (f a), s)
(Err e,s) = (Err e, s)
instance <*> Sem where
(<*>) (Sem f) (Sem g)
= Sem \s.case f s of
(Res f, s) = case g s of
(Res a,s) = (Res (f a),s)
(Err e, s) = (Err e, s)
(Err e,s) = (Err e,s)
unres :: (Sem a) -> (State -> (Res a, State))
unres (Sem f) = f
instance Monad Sem where // !(m a) (a -> m b) -> m b
bind (Sem f) g = Sem \s. case f s of
(Res a, s) = unres (g a) s
(Err e, s) = (Err e, s)
instance pure Sem where
pure a = Sem \s.(pure a, s)
instance pure Res where
pure a = (Res a)
//:: SetA :== Expression
//:: Elem :== Expression
:: Ident :== String
:: Res a = Res a | Err String
:: Sem a = Sem (State -> (Res a, State))
:: State = State (Map Ident Val)
:: Val = I Int | S [Int]//('iTasks'.Set Int)
:: Element :== Sem Int
:: Set :== Sem [Int]
int :: Int -> Element
int i = pure i
size :: Set -> Element
size se = fmap length se
instance + Element where
(+) (Sem a) (Sem b) = Sem \s. case a s of
(Res ares,s) = case b s of
(Res bres, s) = (pure (ares+bres),s)
e = e
e = e
/*instance + Set where
(+) (Sem a) (Sem b) = Sem \s. case a s of
(Res ares,s) = case b s of
(Res bres, s) = (pure (union ares bres),s)
e = e
e = e
*/
instance + Set where
(+) a b = (union) <$> a <*> b
instance - Element where
(-) (Sem a) (Sem b) = Sem \s. case a s of
(Res ares,s) = case b s of
(Res bres, s) = (pure (ares-bres),s)
e = e
e = e
instance - Set where
(-) (Sem a) (Sem b) = Sem \s. case a s of
(Res ares,s) = case b s of
(Res bres, s) = (pure (subtractSet ares bres),s)
e = e
e = e
instance * Element where
(*) (Sem a) (Sem b) = Sem \s. case a s of
(Res ares,s) = case b s of
(Res bres, s) = (pure (ares * bres),s)
e = e
e = e
instance * Set where
(*) a b = intersect <$> a <*> b
class ==. a where
(==.) infix 4 :: !a !a -> Sem Bool
instance ==. Set where
(==.) a b = (equalSet) <$> a <*> b
instance ==. Element where
(==.) a b = (==) <$> a <*> b
/*Logical
iif :: Logical Statement Statement -> Bool
iif log st1 st2 = False
*/
class =. a where
(=.) infixl 2 :: Ident (Sem a) -> (Sem a)
instance =. [Int] where
(=.) i (Sem a) = Sem \s. case a s of
(Res ares, State s) = (pure (ares), State ('Map'.put i (S ares) s))
//(Res ares,s) = case b s of
// (Res bres, s) = (pure (ares * bres),s)
// e = e
(Err e, s) = (Err e, s)
instance =. Int where
(=.) i (Sem a) = Sem \s. case a s of
(Res ares, State s) = (pure (ares), State ('Map'.put i (I ares) s))
(Err e, s) = (Err e, s)
//(=.) i v = Sem \(State s). (pure v, State ('Map'.put i v s))
class Var a where
var :: Ident -> (Sem a)
instance Var Int where
var i = Sem \(State s) . case ('Map'.get i s) of
(Just a) -> case a of
(I i) = (pure i, State s)
(S st) = (Err ("Expected int, found set " +++ (toString st)), State s )
_ -> (Err ("Could not find variable " +++ i), State s )
instance Var [Int] where
var i = Sem \(State s) . case ('Map'.get i s) of
(Just a) -> case a of
(I i) = (Err ("Expected set, found int " +++ (toString i)), State s )
(S st) = (pure st, State s)
_ -> (Err ("Could not find variable " +++ i), State s )
//(==.) infixr 3 :: Set Set -> Sem Bool
//(==.) a b = (equalSet) <$> a <*> b
/*
(==.) infixr 3 :: Set Set -> Sem Bool
(==.) a b = (equalSet) <$> a <*> b
(==.) infixr 3 :: Element Element -> Sem Bool
(==.) a b = (==) <$> a <*> b
*/
/*(+.) (Sem a) (Sem b) = Sem \s. case a s of
(Res ares,s) = case b s of
(Res bres, s) = (pure (if (elem bres ares) ares ([bres:ares])) ,s) //
(Err e,s) = (Err e, s)
(Err e,s) = (Err e, s)
*/
//(+.) infixr 3 :: Set Element -> Set
//(+.) a b = (\ares bres .( (if (elem bres ares) ares ([bres:ares])) )) <$> a <*> b
//(-.) infixr 3 :: Set Element -> Set
//(-.) a b = (\st elm .( (if (elem elm st) (delete elm st) (st)) )) <$> a <*> b
subtractSet a b = foldr (\e s. delete e s) a b
equalSet :: [a] [a] -> Bool | == a
equalSet aset bset = foldr (\a b . (elem a aset) && b) True bset && foldr (\a b . (elem a bset) && b) True aset
//foldr (\a b. a && (elem b aset )) aset bset //foldr (\a b. (a && elem b)) a b
//Start = subtractSet [1,6,23,3,4] [1,5]
//size (Sem sf) = Sem \s -> ( length sf ,s) // pure (length s)
// M a p Ident Val,
//:: State = State (Map Ident Val)
//:: Val = I Int | S [Int]
emptyState = State 'Map'.newMap
evl :: (Sem a) State -> ((Res a),State)//-> (Res (Either Val Bool),State)
evl vl s = let (Sem f) = vl in f s
//evl :: Stmt State -> (Res (Either Val Bool),State)
//evl e s = let (Sem f) = (stmteval e) in f s
zoepzoef :: Set
zoepzoef = pure [1,6,23,3,4]
zof = int 8 + int 9
zofset = pure [1,6,23,3,4] - pure[6]
//zoefs :: (Sem [Int])
zfl :: Set
zfl = pure [9,3,2]
zfr :: (Sem [Int])//Set
zfr = pure [9,2,3]
//zoefs = (zfl) ==. (zfr)
zoefs = "A" =. (zfr)
//zoefs = int 8 ==. int 8
zoefss = var "A" + var "A" //pure [1,2,3]
//Start = equalSet [9,2,3] [9,3,2,1] || equalSet [9,3,2,1] [9,2,3]
//Start = let ((a,b) = evl zoefs emptyState) in evl zoefss b
Start = evl zoefss (snd (evl zoefs emptyState) )
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment