Exercise in 3.3 of SICP

sicp3.3.hs

import Control.Monad.ST
import Data.STRef

-- Primitive actions

getSignal wire = wire GetSignal

setSignal wire x = wire (SetSignal x)

addAction wire proc = wire (AddAction proc)

-- Wire implementation

data WireAction b a = GetSignal | SetSignal a | AddAction b

data WireReturn a = Done | Signal a deriving (Show)

makeWire = do
    signalValue <- newSTRef 0
    actionProcedures <- newSTRef []
    return $ \arg -> case arg of
        GetSignal -> do
            signal <- readSTRef signalValue
            return (Signal signal)
        (SetSignal newSignal) -> do
            signal <- readSTRef signalValue
            if newSignal /= signal
                then do
                    writeSTRef signalValue newSignal
                    procs <- readSTRef actionProcedures
                    callEach procs
                else return ()
            return Done
        (AddAction proc) -> do
            modifySTRef actionProcedures (proc:)
            return Done

callEach [] = return ()
callEach (p:procs) = do
    p
    callEach (procs)

testMakeWire = runST $ do
    a <- makeWire
    x <- getSignal a
    setSignal a 1
    y <- getSignal a
    return [x,y]



-- Compound actions

--inverter input output = addAction input invertInput where
--    invertInput = setSignal output newValue where
--        newValue = logicalNot (getSignal input)

--andGate a1 a2 output = do
--    addAction a1 andActionProc
--    addAction a2 andActionProc
--    where
--        andActionProc = setSignal output newValue where
--            newValue = (&&) (getSignal a1) (getSignal a2)

--orGate o1 o2 output = do
--    addAction o1 orActionProc
--    addAction o2 orActionProc
--    where
--        orActionProc = setSignal output newValue where
--            newValue = (||) (getSignal o1) (getSignal o2)

-- Logical functions

logicalNot 0 = 1
logicalNot 1 = 0
logicalNot _ = error "Invalid signal (NOT)"

logicalAnd 0 0 = 0
logicalAnd 0 1 = 0
logicalAnd 1 0 = 0
logicalAnd 1 1 = 1
logicalAnd _ _ = error "Invalid signal (AND)"

logicalOr 0 0 = 0
logicalOr 0 1 = 1
logicalOr 1 0 = 1
logicalOr 1 1 = 1
logicalOr _ _ = error "Invalid signal (OR)"