content: {-# LANGUAGE Arrows #-}
  -- |
  -- Module      :  Elevator
  -- Description :  Elevator simulation based on the Fran version by Thompson.
  -- Copyright   :  (c) Ivan Perez, 2014-2022
  --                (c) George Giorgidze, 2007-2012
  --                (c) Henrik Nilsson, The University of Nottingham, 2004-2006
  -- License     :  BSD-style (see the LICENSE file in the distribution)
  --
  -- Maintainer  :  ivan.perez@keera.co.uk
  -- Stability   :  provisional
  -- Portability :  non-portable (GHC extensions)
  --
  -- Elevator simulation based on the Fran version from Simon Thompson's paper "A
  -- functional reactive animation of a lift using Fran".
  module Elevator where
  
  import FRP.Yampa
  
  -- * Auxiliary definitions
  
  type Position = Double  -- [m]
  type Distance = Double  -- [m]
  type Velocity = Double  -- [m/s]
  
  -- * Elevator simulator
  
  lower, upper :: Position
  lower = 0
  upper = 5
  
  upRate, downRate :: Velocity
  upRate = 1
  downRate = 1.1
  
  elevator :: SF (Event (), Event ()) Position
  elevator = proc (lbp,rbp) -> do
    rec
      -- This delayed hold can be thought of as modelling acceleration.
      -- It is not "physical" to expect a desire to travel at a certain
      -- velocity to be immediately reflected in the actual velocity.
      -- (The reason we get into trouble here is that the stop/go events
      -- depends instantaneously on "stopped" which in turn depends
      -- instantaneously on "v".)
      v <- dHold 0 -< stop    `tag` 0
                      `lMerge` goUp    `tag` upRate
                      `lMerge` goDown  `tag` (-downRate)
  
      y <- (lower +) ^<< integral -< v
  
      let atBottom = y <= lower
          atTop    = y >= upper
          stopped  = v == 0                -- Somewhat dubious ...
  
          waitingBottom = atBottom && stopped
          waitingTop    = atTop    && stopped
  
      arriveBottom <- edge -< atBottom
      arriveTop    <- edge -< atTop
  
      let setUp   = lbp `tag` True
          setDown = rbp `tag` True
  
      -- This does not work. The reset events would be generated as soon
      -- as the corresponding go event was generated, but the latter
      -- depend instantaneusly on the reset signals.
      --    resetUp   = goUp `tag` False
      --    resetDown = goDown `tag` False
  
      -- One approach would be to wait for "physical confiramtion"
      -- that the elevator actually is moving in the desired direction:
      --    resetUp   <- (`tag` True)  ^<< edge -< v > 0
      --    resetDown <- (`tag` False) ^<< edge -< v < 0
  
      -- Another approach is to simply delay the reset events to avoid
      -- suppressing the very event that generates the reset event.
      resetUp   <- iPre noEvent -< goUp `tag` False
      resetDown <- iPre noEvent -< goDown `tag` False
  
      -- Of course, a third approach would be to just use dHold below.
      -- But that does not seem to be the right solution to me.
      upPending   <- hold False -< setUp   `lMerge` resetUp
      downPending <- hold False -< setDown `lMerge` resetDown
  
      let pending = upPending || downPending
          eitherButton = lbp `lMerge` rbp
  
          goDown  = arriveTop `gate` pending
                    `lMerge` eitherButton `gate` waitingTop
  
          goUp    = arriveBottom `gate` pending
                    `lMerge` eitherButton `gate` waitingBottom
  
          stop    = (arriveTop `lMerge` arriveBottom) `gate` not pending
  
    returnA -< y
  