reactive-banana airlock

gistfile1.hs

-- Things from reactive-banana in use:
-- - stepper
--   to accumulate state in a behavior from an inital value and the firings of an event
-- - <@> and <@
--   to sample behaviors at the point when an event occurs (with or without the value in the event)
-- - whenE
--   to filter events based on a Behavior Bool
-- - reactimate
--   to do IO when an event occurs
-- plus leftmost
-- - a helper function I borrowed from reflex
-- - takes a list of events and return the first event occurring at the current point in time
--
-- We use {-# LANGUAGE RecursiveDo #-} and mdo here for the recursive definition of bLastClick and bState

clickDiff :: TimeDiff -> Time -> Maybe Time -> Bool
clickDiff diff time (Just lastTime) =
  -- completely made up time type and functionality
  time - lastTime < diff
clickDiff _ _ Nothing =
  False

doubleClick :: Behavior Time -> Event () -> Moment (Event ())
doubleClick bTime eClick = mdo
  -- remember the time at which the last click occurred by sampling the time
  -- when the clicks occur and hold on to that time until the next click
  bLastClick <- stepper Nothing . leftmost [
      -- clear the last time on the second click, so we don't trigger
      -- twice on triple clicks
      Nothing <$ eDoubleClick
      -- set the last time when we click (if this isn't a double click)
    , Just    <$> bTime <@ eClick
    ]
  let
    eDoubleClick = clickDiff 500ms <$> bTime <*> bLastClick <@ eClick
  return eDoubleClick

{-
-- This is an alternate form, where the double click delay might get changed by
-- other parts of the program.
--
-- If you pass in (pure 500ms) for the delay it is the same as the previous version,
-- so it can be a win to pass in constants like that as behaviors.
doubleClick :: Behavior TimeDiff -> Behavior Time -> Event () -> Moment (Event ())
doubleClick bDoubleClickTimeDiff bTime eClick = mdo
  bLastClick <- stepper Nothing . leftmost [
      Nothing <$ eDoubleClick
    , Just    <$> bTime <@ eClick
    ]
  let
    -- this is the line that changes
    eDoubleClick = clickDiff <$> bDoubleClickTimeDiff <*> bTime <*> bLastClick <@ eClick
  return $ whenE bDoubleClick eClick
-}

mainLogic :: MyEvents -> MomentIO ()
-- eDoublePress would have been created by doubleClick
mainLogic (MyEvents eDoubleClick eOuterDoorOpened eOuterDoorClosed eInnerDoorOpened eInnerDoorClosed ePressurized eDepressurized) = mdo
  let
    -- give names to certain states of interest
    bIsPressurized   = (== IsPressurized)   <$> bState
    bPressurizing    = (== Pressurizing)    <$> bState
    bIsDepressurized = (== IsDepressurized) <$> bState
    bDepressurizing  = (== Depressurizing)  <$> bState

    -- give names to certain events that only apply during certain states
    eStartDepressurizing  = whenE bIsPressurized   eDoubleClick
    eFinishDepressurizing = whenE bDepressurizing  eOuterDoorOpened
    eStartPressurizing    = whenE bIsDepressurized eDoubleClick
    eFinishPressurizing   = whenE bPressurizing    eInnerDoorOpened

  -- we build up the state here - certain events trigger a state change
  -- and stepper is remembering the value from the latest change
  -- that we have seen
  bState <- stepper IsPressurized . leftmost $ [
      Depressurizing  <$ eStartDepressurizing
    , IsDepressurized <$ eFinishDepressurizing
    , Pressurizing    <$ eStartPressurizing
    , IsPressurized   <$ eFinishPressurizing
    ]

  -- do all of the IO work that we need to, triggered by various events
  reactimate $ closeInnerDoor                <$ eStartDepressurizing
  reactimate $ depressurize                  <$ whenE bDepressurizing eInnerDoorClosed
  reactimate $ openOuterDoor                 <$ whenE bDepressurizing eDepressurized
  reactimate $ putStrLn "Depressurized room" <$ eFinishDepressurizing

  reactimate $ closeOuterDoor                <$ eStartPressurizing
  reactimate $ pressurize                    <$ whenE bPressurizing eOuterDoorClosed
  reactimate $ openInnerDoor                 <$ whenE bPressurizing ePressurized
  reactimate $ putStrLn "Pressurized room"   <$ eFinishPressurizing