module Lava2000.Signal where import Lava2000.Ref import Lava2000.Sequent import Lava2000.Error import List ( transpose ) ---------------------------------------------------------------- -- Signal, Symbol, S newtype Signal a = Signal Symbol newtype Symbol = Symbol (Ref (S Symbol)) data S s = Bool Bool | Inv s | And [s] | Or [s] | Xor [s] | VarBool String | DelayBool s s | Int Int | Neg s | Div s s | Mod s s | Plus [s] | Times [s] | Gte s s | Equal [s] | If s s s | VarInt String | DelayInt s s symbol :: S Symbol -> Symbol symbol = Symbol . ref unsymbol :: Symbol -> S Symbol unsymbol (Symbol r) = deref r instance Eq (Signal a) where Signal (Symbol r1) == Signal (Symbol r2) = r1 == r2 ---------------------------------------------------------------- -- operations -- on bits bool :: Bool -> Signal Bool bool b = lift0 (Bool b) low, high :: Signal Bool low = bool False high = bool True inv :: Signal Bool -> Signal Bool inv = lift1 Inv andl, orl, xorl :: [Signal Bool] -> Signal Bool andl = liftl And orl = liftl Or xorl = liftl Xor equalBool :: Signal Bool -> Signal Bool -> Signal Bool equalBool x y = inv (xorl [x,y]) ifBool :: Signal Bool -> (Signal Bool, Signal Bool) -> Signal Bool ifBool c (x,y) = orl[andl[c,x],andl[inv c,y]] delayBool :: Signal Bool -> Signal Bool -> Signal Bool delayBool = lift2 DelayBool varBool :: String -> Signal Bool varBool s = lift0 (VarBool s) -- on ints int :: Int -> Signal Int int n = lift0 (Int n) neg :: Signal Int -> Signal Int neg = lift1 Neg divide, modulo :: Signal Int -> Signal Int -> Signal Int divide = lift2 Div modulo = lift2 Mod plusl, timesl :: [Signal Int] -> Signal Int plusl = liftl Plus timesl = liftl Times equall :: [Signal Int] -> Signal Bool equall = liftl Equal gteInt :: Signal Int -> Signal Int -> Signal Bool gteInt = lift2 Gte equalInt :: Signal Int -> Signal Int -> Signal Bool equalInt x y = equall [x,y] ifInt :: Signal Bool -> (Signal Int, Signal Int) -> Signal a ifInt c (x,y) = lift3 If c x y delayInt :: Signal Int -> Signal Int -> Signal Int delayInt = lift2 DelayInt varInt :: String -> Signal Int varInt s = lift0 (VarInt s) -- liftings lift0 :: S Symbol -> Signal a lift0 oper = Signal (symbol oper) lift1 :: (Symbol -> S Symbol) -> Signal a -> Signal b lift1 oper (Signal a) = Signal (symbol (oper a)) lift2 :: (Symbol -> Symbol -> S Symbol) -> Signal a -> Signal b -> Signal c lift2 oper (Signal a) (Signal b) = Signal (symbol (oper a b)) lift3 :: (Symbol -> Symbol -> Symbol -> S Symbol) -> Signal a -> Signal b -> Signal c -> Signal d lift3 oper (Signal a) (Signal b) (Signal c) = Signal (symbol (oper a b c)) liftl :: ([Symbol] -> S Symbol) -> [Signal a] -> Signal c liftl oper sigas = Signal (symbol (oper (map (\(Signal a) -> a) sigas))) ---------------------------------------------------------------- -- evaluate eval :: S (S a) -> S a eval s = case s of Bool b -> Bool b Inv (Bool b) -> Bool (not b) And xs -> Bool . all bval $ xs Or xs -> Bool . any bval $ xs Xor xs -> Bool . (1 ==) . length . filter bval $ xs Int n -> Int n Neg (Int n) -> Int (-n) Div (Int n1) (Int n2) -> Int (n1 `div` n2) Mod (Int n1) (Int n2) -> Int (n1 `mod` n2) Plus xs -> Int . sum . map nval $ xs Times xs -> Int . product . map nval $ xs Gte (Int n1) (Int n2) -> Bool (n1 >= n2) Equal xs -> Bool . equal . map nval $ xs If (Bool c) x y -> if c then x else y DelayBool s s' -> wrong Lava2000.Error.DelayEval DelayInt s s' -> wrong Lava2000.Error.DelayEval VarBool s -> wrong Lava2000.Error.VarEval VarInt s -> wrong Lava2000.Error.VarEval where bval (Bool b) = b nval (Int n) = n equal (x:y:xs) = x == y && equal (y:xs) equal _ = True evalLazy :: S (Maybe (S a)) -> Maybe (S a) evalLazy s = case s of -- lazy And xs | any (`bval` False) xs -> bans False Or xs | any (`bval` True) xs -> bans True Xor xs | number (`bval` True) xs >= 2 -> bans False -- strict _ -> eval `fmap` sequent s where bans = Just . Bool bval (Just (Bool b)) b' = b == b' bval _ _ = False number p = length . filter p arguments :: S a -> [a] arguments s = case s of Bool b -> [] Inv s -> [s] And xs -> xs Or xs -> xs Xor xs -> xs Int n -> [] Neg s -> [s] Div s1 s2 -> [s1,s2] Mod s1 s2 -> [s1,s2] Plus xs -> xs Times xs -> xs Gte x y -> [x,y] Equal xs -> xs If x y z -> [x,y,z] DelayBool s s' -> [s,s'] DelayInt s s' -> [s,s'] VarBool s -> [] VarInt s -> [] zips :: S [a] -> [S a] zips s = case s of Bool b -> [Bool b] Inv s -> map Inv s And xs -> map And (transpose xs) Or xs -> map Or (transpose xs) Xor xs -> map Xor (transpose xs) Int n -> [Int n] Neg s -> map Neg s Div s1 s2 -> zipWith Div s1 s2 Mod s1 s2 -> zipWith Mod s1 s2 Plus xs -> map Plus (transpose xs) Times xs -> map Times (transpose xs) Gte x y -> zipWith Gte x y Equal xs -> map Equal (transpose xs) If x y z -> zipWith3 If x y z DelayBool s s' -> zipWith DelayBool s s' DelayInt s s' -> zipWith DelayInt s s' VarBool s -> [VarBool s] VarInt s -> [VarInt s] ---------------------------------------------------------------- -- properties of S instance Functor S where fmap f s = case s of Bool b -> Bool b Inv x -> Inv (f x) And xs -> And (map f xs) Or xs -> Or (map f xs) Xor xs -> Xor (map f xs) Int n -> Int n Neg x -> Neg (f x) Div x y -> Div (f x) (f y) Mod x y -> Mod (f x) (f y) Plus xs -> Plus (map f xs) Times xs -> Times (map f xs) Gte x y -> Gte (f x) (f y) Equal xs -> Equal (map f xs) If x y z -> If (f x) (f y) (f z) DelayBool x y -> DelayBool (f x) (f y) DelayInt x y -> DelayInt (f x) (f y) VarBool v -> VarBool v VarInt v -> VarInt v instance Sequent S where sequent s = case s of Bool b -> lift0 (Bool b) Inv x -> lift1 Inv x And xs -> liftl And xs Or xs -> liftl Or xs Xor xs -> liftl Xor xs Int n -> lift0 (Int n) Neg x -> lift1 Neg x Div x y -> lift2 Div x y Mod x y -> lift2 Mod x y Plus xs -> liftl Plus xs Times xs -> liftl Times xs Gte x y -> lift2 Gte x y Equal xs -> liftl Equal xs If x y z -> lift3 If x y z DelayBool x y -> lift2 DelayBool x y DelayInt x y -> lift2 DelayInt x y VarBool v -> lift0 (VarBool v) VarInt v -> lift0 (VarInt v) where lift0 op = do return op lift1 op x = do x' <- x return (op x') lift2 op x y = do x' <- x y' <- y return (op x' y') lift3 op x y z = do x' <- x y' <- y z' <- z return (op x' y' z') liftl op xs = do xs' <- sequence xs return (op xs') instance Show (Signal a) where showsPrec n (Signal s) = showsPrec n s instance Show Symbol where showsPrec n sym = showsPrec n (unsymbol sym) instance Show a => Show (S a) where showsPrec n s = case s of Bool True -> showString "high" Bool False -> showString "low" Inv x -> showString "inv" . showList [x] And xs -> showString "andl" . showList xs Or xs -> showString "orl" . showList xs Xor xs -> showString "xorl" . showList xs Int i -> showsPrec n i Neg x -> showString "-" . showsPrec n x Div x y -> showString "idiv" . showList [x,y] Mod x y -> showString "imod" . showList [x,y] Plus xs -> showString "plusl" . showList xs Times xs -> showString "timesl" . showList xs Gte x y -> showString "gte" . showList [x,y] Equal xs -> showString "equall" . showList xs If x y z -> showString "ifThenElse" . showList [x,y,z] DelayBool x y -> showString "delay" . showList [x,y] DelayInt x y -> showString "delay" . showList [x,y] VarBool s -> showString s VarInt s -> showString s _ -> showString "<<symbol>>" ---------------------------------------------------------------- -- the end.