yampa-arrows.hs

{-# LANGUAGE Arrows         #-}
{-# LANGUAGE BlockArguments #-}

module Main where

import           Control.Concurrent
import           FRP.Yampa

data State = State { value :: Double } deriving (Show)
initialState = State 25.0

cooling :: State -> SF () (State)
cooling state = (constant (-1) >>> integral) >>^ (+ value state) >>> arr (State)

coolingWithFloor :: State -> SF () (State)
coolingWithFloor state = switch cooling' atRoomTemp
    where t' = cooling state
          cooling' = ((arr (\_ -> t')) &&& ((\_ -> t') ^>> value ^>> (<= 18) ^>> edge >>^ (\e -> e `tag` t')))        
          atRoomTemp _ = (constant 18)

main :: IO ()
main = reactimate (return ())
                (\_ -> threadDelay 1 >> return (0.1, Nothing))
                (\_ b -> (putStrLn $ show b) >> return False)
                (coolingWithFloor initialState)

scratchpad/Main.hs:16:26: error:
    • Couldn't match type ‘SF () State’ with ‘State’
      Expected type: SF () State
        Actual type: SF () (SF () State)
    • In the expression: switch cooling' atRoomTemp
      In an equation for ‘coolingWithFloor’:
          coolingWithFloor state
            = switch cooling' atRoomTemp
            where
                t' = cooling state
                cooling'
                  = ((arr (\ _ -> t'))
                       &&&
                         ((\ _ -> t')
                            ^>> value ^>> (<= 18) ^>> edge >>^ (\ e -> e `tag` t')))
                atRoomTemp _ = (constant 18)
   |
16 | coolingWithFloor state = switch cooling' atRoomTemp
   |                          ^^^^^^^^^^^^^^^^^^^^^^^^^^

scratchpad/Main.hs:18:60: error:
    • Couldn't match type ‘State’ with ‘SF () State’
      Expected type: SF (SF () State) (Event (SF () State))
        Actual type: SF State (Event (SF () State))
    • In the second argument of ‘(^>>)’, namely
        ‘value ^>> (<= 18) ^>> edge >>^ (\ e -> e `tag` t')’
      In the second argument of ‘(&&&)’, namely
        ‘((\ _ -> t')
            ^>> value ^>> (<= 18) ^>> edge >>^ (\ e -> e `tag` t'))’
      In the expression:
        ((arr (\ _ -> t'))
           &&&
             ((\ _ -> t')
                ^>> value ^>> (<= 18) ^>> edge >>^ (\ e -> e `tag` t')))
   |
18 |           cooling' = ((arr (\_ -> t')) &&& ((\_ -> t') ^>> value ^>> (<= 18) ^>> edge >>^ (\e -> e `tag` t')))        
   |                   

Original code:

cooling :: Double -> SF () (Double)
cooling t0 = proc input -> do
               t0' <- integral >>^ (+ t0) -< -1
               returnA -< t0'

coolingWithFloor :: Double -> SF () (Double)
coolingWithFloor t0 = switch cooling' atRoomTemp
    where cooling' = proc _ -> do
                        t' <- cooling t0 -< ()
                        e <- edge -< t' <= 18
                        returnA -< (t', e `tag` t')
          atRoomTemp _ = (constant 18)

main :: IO ()
main = reactimate (return ())
                (\_ -> threadDelay 100000 >> return (0.1, Nothing))
                (\_ b -> (putStrLn $ show b) >> return False)
                (coolingWithFloor 25.0)

The solution!

{-# LANGUAGE Arrows         #-}
{-# LANGUAGE BlockArguments #-}

module Main where

import           Control.Concurrent
import           FRP.Yampa

data State = State { value :: Double } deriving (Show)
initialState = State 25.0

cooling :: State -> SF () (State)
cooling state = (constant (-1) >>> integral) >>^ (+ value state) >>^ State

coolingWithFloor :: State -> SF () (State)
coolingWithFloor state = switch cooling' atRoomTemp
    where t' :: SF () State
          t' = cooling state
          branch_a :: SF () State
          branch_a = t'
          branch_b :: SF () (Event (SF () State))
          branch_b = (t' >>> value ^>> (<= 18) ^>> edge >>^ (\e -> e `tag` t'))
          cooling' :: SF () (State, Event (SF () State))
          cooling' = branch_a &&& branch_b
          atRoomTemp :: p -> SF b State
          atRoomTemp = (\_ -> constant 18 >>^ State)

main :: IO ()
main = reactimate (return ())
                (\_ -> threadDelay 100000 >> return (0.1, Nothing))
                (\_ b -> (putStrLn $ show b) >> return False)
                (coolingWithFloor initialState)