diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,2 +1,3 @@ +0.12 Fixed BehaviorFix, added integration 0.11 Fixed import applicative 0.1 Initial version diff --git a/Control/FRPNow/Core.hs b/Control/FRPNow/Core.hs --- a/Control/FRPNow/Core.hs +++ b/Control/FRPNow/Core.hs @@ -162,7 +162,10 @@ Occ b' -> runB b' E em' -> return (x, E em') switch' (B bm) (E em) = B $ - em >>= \r -> case r of + -- liftIO (traceIO "switching!") >> + em >>= \r -> + -- liftIO (traceIO "ran ev") >> + case r of Never -> bm Occ b' -> runB b' E em' -> @@ -204,8 +207,8 @@ whenJust' (Const Nothing) = pure never whenJust' (Const (Just x)) = pure (pure x) whenJust' (B m) = B $ - do (h, t) <- m - case h of + do (h, t) <- m + case h of Just x -> return (return x, whenJust' <$> t) Nothing -> do en <- planM (runB . whenJust' <$> t) @@ -220,7 +223,7 @@ case h of Just x -> do v <- fst <$> runB x; return (pure v, whenJustSample' <$> t) Nothing -> do en <- planM (runB . whenJustSample' <$> t) - return (en >>= fst, en >>= snd) + return (en >>= fst, never) instance Monad Behavior where return x = B $ return (x, never) @@ -228,8 +231,8 @@ instance MonadFix Behavior where mfix f = B $ mfix $ \(~(h,_)) -> - do ~(h',t) <- runB (f h) - return (h, mfix f <$ t) + do (h',t) <- runB (f h) + return (h', mfix f <$ t ) -- | Introduce a change over time. -- @@ -262,7 +265,7 @@ -- If @b@ never again is positive then the result is 'never'. whenJust :: Behavior (Maybe a) -> Behavior (Event a) -whenJust b = memoB (whenJust' b) +whenJust b = (whenJust' b) -- | A more optimized version of: @@ -284,7 +287,7 @@ -- the behavior is sampled, an error is thrown. futuristic :: Behavior (Event a) -> Behavior (Event a) futuristic b = B $ do e <- makeLazy (joinEm <$> runB b) - return (fst <$> e, snd <$> e) + return (fst <$> e,snd <$> e) where joinEm (e,es) = (,) <$> e <*> es unrunB :: (a,Event (Behavior a)) -> Behavior a @@ -503,11 +506,12 @@ tryPlans = ReaderT $ tryEm where tryEm env = do pl <- readIORef (plansRef env) - --putStrLn ("nr plans: " ++ show (length pl)) + -- putStrLn ("nr plans: " ++ show (length pl)) writeIORef (plansRef env) [] runReaderT (mapM_ tryPlan (reverse pl)) env tryPlan (SomePlan pr) = - do ps <- liftIO (deRef pr) + do -- liftIO (traceIO "plan!") + ps <- liftIO (deRef pr) case ps of Just p -> do eres <- runE (planToEv p) case eres of diff --git a/Control/FRPNow/Lib.hs b/Control/FRPNow/Lib.hs --- a/Control/FRPNow/Lib.hs +++ b/Control/FRPNow/Lib.hs @@ -23,6 +23,7 @@ cmpTime, EvOrd(..), -- * Fold and state + prev, foldB, sampleUntil, -- * Sample behaviors on events @@ -59,6 +60,15 @@ boolToMaybe True = Just () boolToMaybe False = Nothing + +prev :: Eq a => a -> Behavior a -> Behavior (Behavior a) +prev i b = loop i where + loop i = do e <- nxtCur + return (i `step` e) + nxtCur = futuristic $ + do cur <- b + e <- change b + planB (loop cur <$ e) -- | Gives at any point in time the event that the input behavior changes, and the new value of the input behavior. change :: Eq a => Behavior a -> Behavior (Event a) diff --git a/Control/FRPNow/Time.hs b/Control/FRPNow/Time.hs --- a/Control/FRPNow/Time.hs +++ b/Control/FRPNow/Time.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TupleSections,TypeOperators,MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | @@ -16,7 +16,7 @@ -- The clock itself is created by a function specialized to the -- GUI library you are using FRP with such as 'Control.FRPNow.GTK.getClock' -module Control.FRPNow.Time(localTime,timeFrac, lastInputs, bufferBehavior,delayBy, delayByN) where +module Control.FRPNow.Time(localTime,timeFrac, lastInputs, bufferBehavior,delayBy, delayByN, delay, integrate, VectorSpace(..)) where import Control.FRPNow.Core import Control.FRPNow.Lib @@ -121,6 +121,160 @@ ((t1,v1) : (t2,v2) : rest) | sampleTime >= t2 -> loop n ((t2,v2) : rest) | otherwise -> v1 : loop (n-1) l - + + +-- | Integration using rectangle rule approximation. Integration depends on when we start integrating so the result is @Behavior (Behavior v)@. +integrate :: (Show v, Show time, VectorSpace v time) => + Behavior time -> Behavior v -> Behavior (Behavior v) +integrate time v = do t <- time + vp <- delay time (t,zeroVector) ((,) <$> time <*> v) + foldB add zeroVector $ (,) <$> vp <*> time + where add total ((t1,v),t2) = total ^+^ (((t2 - t1) * 0.5) *^ v) + + +-- | Delay a behavior by one tick of the clock. Occasionally useful to prevent immediate feedback loops. +delay :: Eq time => Behavior time -> a -> Behavior a -> Behavior (Behavior a) +delay time i b = loop i where + loop i = + do e <- futuristic $ + do (t,cur) <- (,) <$> time <*> b + e <- when ((/= t) <$> time) + return (cur <$ e) + e' <- plan ( loop <$> e) + return (i `step` e') + +infixr *^ +infixl ^/ +infix 7 `dot` +infixl 6 ^+^, ^-^ + +-- | A type class for vector spaces. Stolen from Yampa. Thanks Henrik :) + +-- Minimal instance: zeroVector, (*^), (^+^), dot +class (Eq a, Eq v, Ord v, Ord a, Floating a) => VectorSpace v a | v -> a where + zeroVector :: v + (*^) :: a -> v -> v + (^/) :: v -> a -> v + negateVector :: v -> v + (^+^) :: v -> v -> v + (^-^) :: v -> v -> v + dot :: v -> v -> a + norm :: v -> a + normalize :: v -> v + + v ^/ a = (1/a) *^ v + + negateVector v = (-1) *^ v + + v1 ^-^ v2 = v1 ^+^ negateVector v2 + + norm v = sqrt (v `dot` v) + + normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector" + where nv = norm v + +------------------------------------------------------------------------------ +-- Vector space instances for Float and Double +------------------------------------------------------------------------------ + +instance VectorSpace Float Float where + zeroVector = 0 + + a *^ x = a * x + + x ^/ a = x / a + + negateVector x = (-x) + + x1 ^+^ x2 = x1 + x2 + + x1 ^-^ x2 = x1 - x2 + + x1 `dot` x2 = x1 * x2 + + +instance VectorSpace Double Double where + zeroVector = 0 + + a *^ x = a * x + + x ^/ a = x / a + + negateVector x = (-x) + + x1 ^+^ x2 = x1 + x2 + + x1 ^-^ x2 = x1 - x2 + + x1 `dot` x2 = x1 * x2 + + +------------------------------------------------------------------------------ +-- Vector space instances for small tuples of Floating +------------------------------------------------------------------------------ + +instance (Eq a, Floating a, Ord a) => VectorSpace (a,a) a where + zeroVector = (0,0) + + a *^ (x,y) = (a * x, a * y) + + (x,y) ^/ a = (x / a, y / a) + + negateVector (x,y) = (-x, -y) + + (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2) + + (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2) + + (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2 + + +instance (Eq a, Floating a, Ord a) => VectorSpace (a,a,a) a where + zeroVector = (0,0,0) + + a *^ (x,y,z) = (a * x, a * y, a * z) + + (x,y,z) ^/ a = (x / a, y / a, z / a) + + negateVector (x,y,z) = (-x, -y, -z) + + (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2) + + (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2) + + (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2 + + +instance (Eq a, Floating a, Ord a) => VectorSpace (a,a,a,a) a where + zeroVector = (0,0,0,0) + + a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u) + + (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a) + + negateVector (x,y,z,u) = (-x, -y, -z, -u) + + (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2) + + (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2) + + (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + + +instance (Eq a, Floating a, Ord a) => VectorSpace (a,a,a,a,a) a where + zeroVector = (0,0,0,0,0) + + a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v) + + (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a) + + negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v) + + (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2) + + (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2) + + (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) = + x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2 diff --git a/frpnow.cabal b/frpnow.cabal --- a/frpnow.cabal +++ b/frpnow.cabal @@ -1,5 +1,5 @@ Name: frpnow -Version: 0.11 +Version: 0.12 Synopsis: Principled practical FRP Description: FRP with first-class behaviors and interalized IO, without space leaks License: BSD3