Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
added ReactiveUtils
  • Loading branch information
Andreas-Christoph Bernstein committed Jul 26, 2012
1 parent 349fcb4 commit 258e17a
Show file tree
Hide file tree
Showing 3 changed files with 74 additions and 1 deletion.
4 changes: 3 additions & 1 deletion breakout.cabal
Expand Up @@ -22,15 +22,17 @@ executable breakout
other-modules: GLutils,
UnitBox,
GlutAdapter,
ReactiveUtils,
Rendering
Build-depends: base >= 4.2 && < 4.6,
mtl >= 2.0 && < 2.2,
diagrams-core >= 0.5 && < 0.6,
diagrams-lib >= 0.5 && < 0.6,
active >= 0.1 && < 0.2,
vector-space >= 0.7.7 && < 0.9,
reactive-banana >= 0.6 && < 0.7,
semigroups >= 0.3.4 && < 0.9,
OpenGLRaw >= 1.2 && < 1.3,
active >= 0.1 && < 0.2,
time >= 1.4 && < 1.5,
GLUT >= 2.3 && < 2.4

1 change: 1 addition & 0 deletions src/Main.hs
Expand Up @@ -18,6 +18,7 @@ where
import GlutAdapter
import Rendering
import UnitBox
import ReactiveUtils

import System.Exit (exitSuccess)
import qualified Data.Active as Active
Expand Down
70 changes: 70 additions & 0 deletions src/ReactiveUtils.hs
@@ -0,0 +1,70 @@
{-# LANGUAGE ExistentialQuantification
, ScopedTypeVariables
, MultiParamTypeClasses
, FlexibleInstances
, TypeFamilies
#-}

-----------------------------------------------------------------------------
-- |
-- Module : ReactiveUtils
-- Copyright : (c) 2012 Andreas-C. Bernstein
-- License : BSD-style (see LICENSE)
-- Maintainer : andreas.bernstein@gmail.com
--
-- Reactive banana utilities. Most of them very similar to the ones from
-- the Reactive library.
--
-----------------------------------------------------------------------------

module ReactiveUtils
(
integral
, sumB
, withPrevE
, withPrevEWith
, diffE
, snapshotWith
, snapshot
, snapshot_
, unique
, once
) where

import Reactive.Banana
import Data.VectorSpace
import Data.AffineSpace
import Data.Active (fromDuration, Time)

integral :: (VectorSpace v, Scalar v ~ Double) => Event t Time -> Behavior t v -> Behavior t v
integral t b = sumB (snapshotWith (*^) b (fromDuration <$> diffE t))

sumB :: AdditiveGroup a => Event t a -> Behavior t a
sumB = accumB zeroV . fmap (^+^)

withPrevE :: Event t a -> Event t (a,a)
withPrevE = filterJust . fmap f . accumE (Nothing,Nothing) . fmap ((\new (prev,_) -> (new,prev)).Just)
where
f :: (Maybe a, Maybe b) -> Maybe (a,b)
f = uncurry (liftA2 (,))

withPrevEWith :: (a -> a -> b) -> Event t a -> Event t b
withPrevEWith f e = fmap (uncurry f) (withPrevE e)

diffE :: AffineSpace a => Event t a -> Event t (Diff a)
diffE = withPrevEWith (.-.)

snapshotWith :: (a -> b -> c) -> Behavior t b -> Event t a -> Event t c
snapshotWith h b e = (flip h <$> b) `apply` e

snapshot :: Behavior t b -> Event t a -> Event t (a,b)
snapshot = snapshotWith (,)

snapshot_ :: Behavior t b -> Event t a -> Event t b
snapshot_ = snapshotWith (flip const)

This comment has been minimized.

Copy link
@HeinrichApfelmus

HeinrichApfelmus Jul 28, 2012

Contributor

The infix functions <@ and <@> offered by reactive-banana are probably an improvement over the snapshot family of functions.


unique :: Eq a => Event t a -> Event t a
unique = filterJust . accumE Nothing . fmap (\a acc -> if Just a == acc then Nothing else Just a)

once :: Event t a -> Event t a
once e = whenE (True `stepper` (False <$ e)) e

0 comments on commit 258e17a

Please sign in to comment.