git @ Cat's Eye Technologies The-Dossier / master article / Nested-Modal-Transducers / NestedModalTransducers.hs
master

Tree @master (Download .tar.gz)

NestedModalTransducers.hs @masterraw · history · blame

-- SPDX-FileCopyrightText: In 2019, Chris Pressey, the original author of this work, placed it into the public domain.
-- SPDX-License-Identifier: Unlicense
-- For more information, please refer to <https://unlicense.org/>

module NestedModalTransducers where

--
-- Runnable example code, in Haskell, to accompany the article
-- about Nested Modal Transducer Assemblages.
-- 
-- Example usage: install GHC, then run
--     ghc NestedModalTransducers.hs -e testAll
-- to run all the tests.  All tests passed if the output is only `[]`.
-- 

-- -- -- -- -- -- -- --

-- First, a simple function to express our illustrative tests:
-- Given a list of pairs, show those pairs that are not equal.
-- Anything other than an empty list returned indicates a mistake.

expect [] = []
expect ((a, b):rest) = if a == b then expect rest else ((a, b):expect rest)

-- -- -- -- -- -- -- --

data LightMode = On | Off deriving (Show, Ord, Eq)
data LightInput = TurnOn | TurnOff deriving (Show, Ord, Eq)
data LightOutput = RingBell | BuzzBuzzer | BlowHorn deriving (Show, Ord, Eq)

--
-- Purely functional definition of a simple transducer.
--

lightTransducer :: LightMode -> LightInput -> (LightMode, [LightOutput])
lightTransducer mode input =
    case (mode, input) of
        (On, TurnOff) ->
            (Off, [])
        (Off, TurnOn) ->
            (On, [RingBell])
        _ ->
            (mode, [])

--
-- Purely functional test harness for transducers:
-- Determine what state and outputs it will produce, given a sequence of inputs.
-- You can think of it as having a type like:
--
--     rehearse :: Transducer -> State -> [Input] -> (State, [Output])
--

rehearse t state [] = (state, [])
rehearse t state (input:inputs) =
    let
        (state', outputs) = t state input
        (state'', outputs') = rehearse t state' inputs
    in
        (state'', outputs ++ outputs')

testRehearse = expect
  [
    (rehearse (lightTransducer) On [TurnOff],                     (Off, [])),
    (rehearse (lightTransducer) Off [TurnOff],                    (Off, [])),
    (rehearse (lightTransducer) Off [TurnOn, TurnOn, TurnOff],    (Off, [RingBell])),
    (rehearse (lightTransducer) On [TurnOn, TurnOn, TurnOff],     (Off, []))
  ]

--
-- Reactive driver for transducer:
-- Accept inputs from console, display outputs on console, interactively.
-- Test it manually with:
--
--     reactWith lightTransducer Off
--

reactWith transducer state = do
    putStrLn $ "State is now: " ++ (show state)
    input <- waitForInput
    let (state', outputs) = transducer state input
    enactEffects outputs
    reactWith transducer state'

waitForInput = do
    putStrLn "Enter '1' to TurnOn, '2' to TurnOff"
    line <- getLine
    case line of
        "1" -> return TurnOn
        "2" -> return TurnOff
        _ -> waitForInput

enactEffects [] = return ()
enactEffects (output:outputs) = do
    enactEffect output
    enactEffects outputs

enactEffect output =
    case output of
        RingBell -> putStrLn "Ding!"

--
-- Higher-order function to combine transducers a la Redux's combineReducers.
-- Note that order matters: effects from tA will happen before effects from tB.
--

combineTransducers tA tB = tC where
    tC (stateA, stateB) input =
        let
            (stateA', outputsA) = tA stateA input
            (stateB', outputsB) = tB stateB input
            outputsC = outputsA ++ outputsB
        in
            ((stateA', stateB'), outputsC)

twoLightTransducer = combineTransducers lightTransducer lightTransducer

testCombinedTransducer = expect
  [
    (rehearse twoLightTransducer (On, Off) [TurnOff],         ((Off,Off),[])),
    (rehearse twoLightTransducer (On, Off) [TurnOff, TurnOn], ((On,On),[RingBell,RingBell]))
  ]

--
-- Extended state
--
-- (This is where we start using the word "configs" instead of "states", but don't get confused:
-- the term "configuration" comes from modern automata theory and refers to the state of the
-- entire machine.  Configuration = mode ("finite state variable") + data ("extended state").)
--

data LightConfig = LightConfig LightMode Integer deriving (Show, Ord, Eq)

countingLightTransducer (LightConfig mode count) input =
    case (mode, input) of
        (On, TurnOff) ->
            (LightConfig Off count, [])
        (Off, TurnOn) ->
            (LightConfig On (count + 1), [RingBell])
        _ ->
            (LightConfig mode count, [])

testCountingLightTransducer = expect
  [
    (rehearseCountingLightTransducer [TurnOn],                       (LightConfig On 1,[RingBell])),
    (rehearseCountingLightTransducer [TurnOn,TurnOn],                (LightConfig On 1,[RingBell])),
    (rehearseCountingLightTransducer [TurnOn,TurnOn,TurnOff],        (LightConfig Off 1,[RingBell])),
    (rehearseCountingLightTransducer [TurnOn,TurnOn,TurnOff,TurnOn], (LightConfig On 2,[RingBell,RingBell]))
  ]
  where
    rehearseCountingLightTransducer = rehearse countingLightTransducer (LightConfig Off 0)

--
-- Nested state machine.  The light is now in a room, behind a door.
-- It can only be turned on or off when the door is open.
--

-- LightMode and LightInput have already been defined

data DoorMode = Opened | Closed deriving (Show, Ord, Eq)
data DoorInput = Open | Close | LightInput LightInput deriving (Show, Ord, Eq)
data DoorConfig = DoorConfig DoorMode LightConfig deriving (Show, Ord, Eq)
data DoorOutput = LightOutput LightOutput deriving (Show, Ord, Eq)

doorTransducer :: DoorConfig -> DoorInput -> (DoorConfig, [DoorOutput])
doorTransducer (DoorConfig mode lightConfig) input =
    case (mode, input) of
        (Closed, Open) ->
            ((DoorConfig Opened lightConfig), [])
        (Opened, Close) ->
            ((DoorConfig Closed lightConfig), [])
        (Opened, LightInput lightInput) ->
            let
                (lightConfig', lightOutputs) = countingLightTransducer lightConfig lightInput
                doorOutputs = map (\x -> LightOutput x) lightOutputs
            in
                ((DoorConfig mode lightConfig'), doorOutputs)
        _ ->
            (DoorConfig mode lightConfig, [])

testDoor = expect
  [
    (rehearse doorTransducer initialDoorConfig [Open],                             (DoorConfig Opened (LightConfig Off 0),[])),
    (rehearse doorTransducer initialDoorConfig [LightInput TurnOn],                (DoorConfig Closed (LightConfig Off 0),[])),
    (rehearse doorTransducer initialDoorConfig [Open, (LightInput TurnOn), Close], (DoorConfig Closed (LightConfig On 1),[LightOutput RingBell]))
  ]
  where
    initialDoorConfig = (DoorConfig Closed (LightConfig Off 0))

--
-- Array of orthogonal regions - a list of lights are behind a barn door.
--

transduceAll t input [] (accConfigs, accOutputs) = (reverse accConfigs, accOutputs)
transduceAll t input (config:configs) (accConfigs, accOutputs) =
    let
        (config', outputs) = t config input
    in
        transduceAll t input configs ((config':accConfigs), accOutputs ++ outputs)

data BarnConfig = BarnConfig DoorMode [LightConfig] deriving (Show, Ord, Eq)

barnTransducer :: BarnConfig -> DoorInput -> (BarnConfig, [DoorOutput])
barnTransducer config@(BarnConfig mode lightConfigs) input =
    case (mode, input) of
        (Closed, Open) ->
            ((BarnConfig Opened lightConfigs), [])
        (Opened, Close) ->
            ((BarnConfig Closed lightConfigs), [])
        (Opened, LightInput lightInput) ->
            let
                (lightConfigs', lightOutputs) = transduceAll (countingLightTransducer) lightInput lightConfigs ([], [])
                doorOutputs = map (\x -> LightOutput x) lightOutputs
            in
                ((BarnConfig mode lightConfigs'), doorOutputs)
        _ ->
            (config, [])

testBarn = expect
  [
    (rehearse barnTransducer barnConfig1 [Open],                             (BarnConfig Opened [LightConfig Off 0,LightConfig On 0],[])),
    (rehearse barnTransducer barnConfig1 [LightInput TurnOn],                (BarnConfig Closed [LightConfig Off 0,LightConfig On 0],[])),
    (rehearse barnTransducer barnConfig1 [Open, (LightInput TurnOn), Close], (BarnConfig Closed [LightConfig On 1,LightConfig On 0],[LightOutput RingBell])),
    (rehearse barnTransducer barnConfig2 [Open, (LightInput TurnOn), Close], (BarnConfig Closed [LightConfig On 1,LightConfig On 1],[LightOutput RingBell,LightOutput RingBell]))
  ]
  where
    barnConfig1 = (BarnConfig Closed [(LightConfig Off 0), (LightConfig On 0)])
    barnConfig2 = (BarnConfig Closed [(LightConfig Off 0), (LightConfig Off 0)])

--
-- Entry and exit actions
--

-- In some ideal or latently-typed world, we'd have a single higher-order function
-- that we wrap all our transducers with.  But here we have types, and I don't feel
-- like mashing them together into typeclasses or whatever, so.  We have two
-- separate decorator functions here.  This is not a great example in any case,
-- but like the article says, we don't pretend to have a good solution, we only
-- want to show that it is possible.

addEntryExitOutputsLight t config@(LightConfig mode _) input =
    let
        (config2@(LightConfig mode2 data2), outputs) = t config input
        exitOutputs = case mode of
            Off -> [BuzzBuzzer]
            _ -> []
        outputs2 = exitOutputs ++ outputs
    in
        (config2, outputs2)

addEntryExitOutputsDoor t config@(DoorConfig mode _) input =
    let
        (config2@(DoorConfig mode2 data2), outputs) = t config input
        entryOutputs = case mode2 of
            Closed -> [LightOutput BlowHorn]
            _ -> []
        outputs2 = outputs ++ entryOutputs
    in
        (config2, outputs2)

decoDoorTransducer :: DoorConfig -> DoorInput -> (DoorConfig, [DoorOutput])
decoDoorTransducer = addEntryExitOutputsDoor t where
    t (DoorConfig mode lightConfig) input =
        case (mode, input) of
            (Closed, Open) ->
                ((DoorConfig Opened lightConfig), [])
            (Opened, Close) ->
                ((DoorConfig Closed lightConfig), [])
            (Opened, LightInput lightInput) ->
                let
                    decoLightTransducer = addEntryExitOutputsLight countingLightTransducer
                    (lightConfig', lightOutputs) = decoLightTransducer lightConfig lightInput
                    doorOutputs = map (\x -> LightOutput x) lightOutputs
                in
                    ((DoorConfig mode lightConfig'), doorOutputs)
            _ ->
                (DoorConfig mode lightConfig, [])

testDecoDoorTransducer = expect
  [
    (rehearseIt [Open],                             (DoorConfig Opened (LightConfig Off 0),[])),
    (rehearseIt [LightInput TurnOn],                (DoorConfig Closed (LightConfig Off 0),[LightOutput BlowHorn])),
    (rehearseIt [Open, (LightInput TurnOn), Close], (DoorConfig Closed (LightConfig On 1),
      [LightOutput BuzzBuzzer,LightOutput RingBell,LightOutput BlowHorn]))
  ]
  where
    rehearseIt = rehearse decoDoorTransducer initialDoorConfig
    initialDoorConfig = (DoorConfig Closed (LightConfig Off 0))

--
-- Synthesized events
--

data GUIInput = MouseMove Int Int | MousePress | MouseRelease | Drag Int Int deriving (Show, Ord, Eq)
data GUIMode = MouseDown | MouseUp deriving (Show, Ord, Eq)
data GUIConfig = GUIConfig GUIMode Int Int deriving (Show, Ord, Eq)
data GUIOutput = ShowClick Int Int | ShowHand Int Int deriving (Show, Ord, Eq)

makeGuiInputSynthesizingTransducer t = t' where
    t' config@(GUIConfig mode x y) input =
        case (mode, input) of
            (MouseDown, MouseMove x' y') ->
                t config (Drag x' y')
            _ ->
                t config input

baseGuiTransducer (GUIConfig mode x y) input =
    case (mode, input) of
        (MouseDown, MouseRelease) ->
            (GUIConfig MouseUp x y, [])
        (MouseUp, MousePress) ->
            (GUIConfig MouseDown x y, [ShowClick x y])
        (_, MouseMove x' y') ->
            (GUIConfig mode x' y', [])
        (_, Drag x' y') ->
            (GUIConfig mode x' y', [ShowHand x' y'])
        _ ->
            (GUIConfig mode x y, [])

guiTransducer = makeGuiInputSynthesizingTransducer baseGuiTransducer

testGui = expect
  [
    (rehearseIt [MouseMove 10 10, MousePress, MouseRelease], (GUIConfig MouseUp 10 10, [ShowClick 10 10])),
    (rehearseIt [MousePress, MouseMove 10 10, MouseRelease], (GUIConfig MouseUp 10 10, [ShowClick 0 0, ShowHand 10 10]))
  ]
  where
    rehearseIt = rehearse guiTransducer (GUIConfig MouseUp 0 0)

-- -- -- -- -- -- -- --

testAll = (map show testRehearse) ++
          (map show testCombinedTransducer) ++
          (map show testCountingLightTransducer) ++
          (map show testDoor) ++
          (map show testBarn) ++
          (map show testDecoDoorTransducer) ++
          (map show testGui)