src/RMCA/Auxiliary.hs

   1 {-# LANGUAGE Arrows, FlexibleContexts, MultiParamTypeClasses #-}
   2
   3 module RMCA.Auxiliary where
   4
   5 import Control.Monad
   6 import Data.CBMVar
   7 import Data.Fixed
   8 import Data.Maybe
   9 import Data.ReactiveValue
  10 import FRP.Yampa
  11
  12 --------------------------------------------------------------------------------
  13 -- General functions
  14 --------------------------------------------------------------------------------
  15
  16 bound :: (Ord a) => (a, a) -> a -> a
  17 bound (min, max) x
  18   | x < min = min
  19   | x > max = max
  20   | otherwise = x
  21
  22 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
  23 fromMaybeM_ = fromMaybe (return ())
  24
  25 safeHead :: [a] -> Maybe a
  26 safeHead [] = Nothing
  27 safeHead (x:_) = Just x
  28
  29 safeTail :: [a] -> [a]
  30 safeTail [] = []
  31 safeTail (_:xs) = xs
  32
  33 maybeToEvent :: Maybe a -> Event a
  34 maybeToEvent Nothing = NoEvent
  35 maybeToEvent (Just x) = Event x
  36
  37 eventToMaybe :: Event a -> Maybe a
  38 eventToMaybe NoEvent = Nothing
  39 eventToMaybe (Event x) = Just x
  40
  41 --------------------------------------------------------------------------------
  42 -- FRP
  43 --------------------------------------------------------------------------------
  44
  45 -- stepBack contains its previous argument as its output. Because it's
  46 -- hard to define it at time 0, it's wrapped up in a Maybe.
  47 stepBack :: SF a (Maybe a)
  48 stepBack = sscan f (Nothing, Nothing) >>^ snd
  49   where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
  50         f (Nothing,_) x' = (Just x', Nothing)
  51         f (Just x, _) x' = (Just x', Just x)
  52
  53 -- Just like stepBack but the output value is always defined and is
  54 -- equal to the input at time 0.
  55 stepBack' :: SF a a
  56 stepBack' = proc x -> do
  57   x' <- stepBack -< x
  58   returnA -< fromMaybe x x'
  59
  60 -- Throws an Event when the incoming signal change. The Event is
  61 -- tagged with the new value.
  62 onChange :: (Eq a) => SF a (Event a)
  63 onChange = proc x -> do
  64   x' <- stepBack -< x
  65   let makeEvent x x'
  66         | isNothing x' = NoEvent
  67         | otherwise = let x'' = fromJust x' in
  68             if x'' == x then NoEvent else Event x
  69   returnA -< makeEvent x x'
  70
  71 varFreqSine :: SF DTime Double
  72 varFreqSine = sin ^<< (2*pi*) ^<< (`mod'` 1) ^<< integral <<^ (1/)
  73
  74 repeatedlyS :: a -> SF DTime (Event a)
  75 repeatedlyS x = edgeBy (\a b -> if a * b < 0 then Just x else Nothing) 0
  76                 <<< varFreqSine <<^ (2*)
  77
  78 -- Similar to onChange but contains its initial value in the first
  79 -- event.
  80 onChange' :: (Eq a) => SF a (Event a)
  81 onChange' = proc x -> do
  82   x' <- stepBack -< x
  83   -- If it's the first value, throw an Event, else behave like onChange.
  84   let makeEvent x x'
  85         | isNothing x' = Event x
  86         | otherwise = let x'' = fromJust x' in
  87             if x'' == x then NoEvent else Event x
  88   returnA -< makeEvent x x'
  89
  90 updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
  91 updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
  92
  93 --------------------------------------------------------------------------------
  94 -- Reactive Values
  95 --------------------------------------------------------------------------------
  96
  97 newCBMVarRW :: a -> IO (ReactiveFieldReadWrite IO a)
  98 newCBMVarRW val = do
  99   mvar <- newCBMVar val
 100   let getter = readCBMVar mvar
 101       setter = writeCBMVar mvar
 102       notifier = installCallbackCBMVar mvar
 103   return $ ReactiveFieldReadWrite setter getter notifier
 104
 105 reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
 106                        a -> b -> m ()
 107 reactiveValueAppend rv v = do ov <- reactiveValueRead rv
 108                               reactiveValueWrite rv (ov `mappend` v)
 109
 110 reactiveValueWriteOnNotEq :: ( Eq b
 111                              , ReactiveValueReadWrite a b m) =>
 112                              a -> b -> m ()
 113 reactiveValueWriteOnNotEq rv nv = do
 114   ov <- reactiveValueRead rv
 115   when (ov /= nv) $ reactiveValueWrite rv nv
 116
 117 emptyRW :: (Monoid b, ReactiveValueReadWrite a b m) => a -> m b
 118 emptyRW rv = do
 119   val <- reactiveValueRead rv
 120   reactiveValueWrite rv mempty
 121   return val
 122
 123 -- Update when the value is an Event. It would be nice to have that
 124 -- even for Maybe as well.
 125 (>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
 126          a -> c -> IO ()
 127 eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
 128   where  syncOnEvent = do
 129            erv <- reactiveValueRead eventRV
 130            when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
 131
 132 syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
 133                            , ReactiveValueReadWrite c d m
 134                            ) => (b -> d -> d) -> a -> c -> m ()
 135 syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
 136   nl <- reactiveValueRead l
 137   or <- reactiveValueRead r
 138   reactiveValueWrite r (f nl or)
 139
 140 liftW3 :: ( Monad m
 141           , ReactiveValueWrite a b m
 142           , ReactiveValueWrite c d m
 143           , ReactiveValueWrite e f m) =>
 144           (i -> (b,d,f)) -> a -> c -> e -> ReactiveFieldWrite m i
 145 liftW3 f a b c = ReactiveFieldWrite setter
 146   where setter x = do
 147           let (x1,x2,x3) = f x
 148           reactiveValueWrite a x1
 149           reactiveValueWrite b x2
 150           reactiveValueWrite c x3
 151
 152 liftRW3 :: ( ReactiveValueReadWrite a b m
 153            , ReactiveValueReadWrite c d m
 154            , ReactiveValueReadWrite e f m) =>
 155            BijectiveFunc i (b,d,f) -> a -> c -> e -> ReactiveFieldReadWrite m i
 156 liftRW3 bij a b c =
 157   ReactiveFieldReadWrite setter getter notifier
 158   where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
 159         ReactiveFieldWrite setter = liftW3 f1 a b c
 160         (f1, f2) = (direct bij, inverse bij)
 161
 162 liftR4 :: ( ReactiveValueRead a b m
 163           , ReactiveValueRead c d m
 164           , ReactiveValueRead e f m
 165           , ReactiveValueRead g h m) =>
 166           (b -> d -> f -> h -> i) -> a -> c -> e -> g -> ReactiveFieldRead m i
 167 liftR4 f a b c d = ReactiveFieldRead getter notifier
 168   where getter = do
 169           x1 <- reactiveValueRead a
 170           x2 <- reactiveValueRead b
 171           x3 <- reactiveValueRead c
 172           x4 <- reactiveValueRead d
 173           return $ f x1 x2 x3 x4
 174         notifier p = do
 175           reactiveValueOnCanRead a p
 176           reactiveValueOnCanRead b p
 177           reactiveValueOnCanRead c p
 178           reactiveValueOnCanRead d p
 179
 180 liftW4 :: ( Monad m
 181           , ReactiveValueWrite a b m
 182           , ReactiveValueWrite c d m
 183           , ReactiveValueWrite e f m
 184           , ReactiveValueWrite g h m) =>
 185           (i -> (b,d,f,h)) -> a -> c -> e -> g -> ReactiveFieldWrite m i
 186 liftW4 f a b c d = ReactiveFieldWrite setter
 187   where setter x = do
 188           let (x1,x2,x3,x4) = f x
 189           reactiveValueWrite a x1
 190           reactiveValueWrite b x2
 191           reactiveValueWrite c x3
 192           reactiveValueWrite d x4
 193
 194 liftRW4 :: ( ReactiveValueReadWrite a b m
 195            , ReactiveValueReadWrite c d m
 196            , ReactiveValueReadWrite e f m
 197            , ReactiveValueReadWrite g h m) =>
 198            BijectiveFunc i (b,d,f,h) -> a -> c -> e -> g
 199         -> ReactiveFieldReadWrite m i
 200 liftRW4 bij a b c d =
 201   ReactiveFieldReadWrite setter getter notifier
 202   where ReactiveFieldRead getter notifier = liftR4 (curry4 f2) a b c d
 203         ReactiveFieldWrite setter = liftW4 f1 a b c d
 204         (f1, f2) = (direct bij, inverse bij)
 205
 206 liftR5 :: ( ReactiveValueRead a b m
 207           , ReactiveValueRead c d m
 208           , ReactiveValueRead e f m
 209           , ReactiveValueRead g h m
 210           , ReactiveValueRead i j m) =>
 211           (b -> d -> f -> h -> j -> k) -> a -> c -> e -> g -> i
 212        -> ReactiveFieldRead m k
 213 liftR5 f a b c d e = ReactiveFieldRead getter notifier
 214   where getter = do
 215           x1 <- reactiveValueRead a
 216           x2 <- reactiveValueRead b
 217           x3 <- reactiveValueRead c
 218           x4 <- reactiveValueRead d
 219           x5 <- reactiveValueRead e
 220           return $ f x1 x2 x3 x4 x5
 221         notifier p = do
 222           reactiveValueOnCanRead a p
 223           reactiveValueOnCanRead b p
 224           reactiveValueOnCanRead c p
 225           reactiveValueOnCanRead d p
 226           reactiveValueOnCanRead e p
 227
 228 liftW5 :: ( Monad m
 229           , ReactiveValueWrite a b m
 230           , ReactiveValueWrite c d m
 231           , ReactiveValueWrite e f m
 232           , ReactiveValueWrite g h m
 233           , ReactiveValueWrite i j m) =>
 234           (k -> (b,d,f,h,j)) -> a -> c -> e -> g -> i -> ReactiveFieldWrite m k
 235 liftW5 f a b c d e = ReactiveFieldWrite setter
 236   where setter x = do
 237           let (x1,x2,x3,x4,x5) = f x
 238           reactiveValueWrite a x1
 239           reactiveValueWrite b x2
 240           reactiveValueWrite c x3
 241           reactiveValueWrite d x4
 242           reactiveValueWrite e x5
 243
 244 liftRW5 :: ( ReactiveValueReadWrite a b m
 245            , ReactiveValueReadWrite c d m
 246            , ReactiveValueReadWrite e f m
 247            , ReactiveValueReadWrite g h m
 248            , ReactiveValueReadWrite i j m) =>
 249            BijectiveFunc k (b,d,f,h,j) -> a -> c -> e -> g -> i
 250         -> ReactiveFieldReadWrite m k
 251 liftRW5 bij a b c d e =
 252   ReactiveFieldReadWrite setter getter notifier
 253   where ReactiveFieldRead getter notifier = liftR5 (curry5 f2) a b c d e
 254         ReactiveFieldWrite setter = liftW5 f1 a b c d e
 255         (f1, f2) = (direct bij, inverse bij)
 256
 257 --------------------------------------------------------------------------------
 258 -- Curry and uncurry functions
 259 --------------------------------------------------------------------------------
 260
 261 curry3 :: ((a,b,c) -> d) -> a -> b -> c -> d
 262 curry3 f a b c = f (a,b,c)
 263
 264 uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d
 265 uncurry3 f (a,b,c) = f a b c
 266
 267 curry4 :: ((a,b,c,d) -> e) -> a -> b -> c -> d -> e
 268 curry4 f a b c d = f (a,b,c,d)
 269
 270 uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e
 271 uncurry4 f (a,b,c,d) = f a b c d
 272
 273 curry5 :: ((a,b,c,d,e) -> f) -> a -> b -> c -> d -> e -> f
 274 curry5 f a b c d e = f (a,b,c,d,e)
 275
 276 uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a,b,c,d,e) -> f
 277 uncurry5 f (a,b,c,d,e) = f a b c d e