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