reactivity 0.3.1.0 → 0.3.2.0
raw patch · 18 files changed
+829/−3454 lines, 18 filesdep +exceptionsdep −ConcurrentUtilsdep −Win32dep −comonad
Dependencies added: exceptions
Dependencies removed: ConcurrentUtils, Win32, comonad, concurrent-extra
Files
- reactivity.cabal +23/−20
- src/Control/CUtils/Conc.hs +173/−0
- src/Control/CUtils/FChan.hs +75/−0
- src/Data/XSizeable.hs +0/−103
- src/FRP/Reactivity.hs +0/−409
- src/FRP/Reactivity/AlternateEvent.hs +171/−0
- src/FRP/Reactivity/Basic.hs +0/−238
- src/FRP/Reactivity/Combinators.hs +98/−172
- src/FRP/Reactivity/Draw.hs +0/−583
- src/FRP/Reactivity/Examples.hs +0/−81
- src/FRP/Reactivity/Extras.hs +0/−355
- src/FRP/Reactivity/Hook.hs +0/−200
- src/FRP/Reactivity/Measurement.hs +161/−0
- src/FRP/Reactivity/MeasurementWrapper.hs +69/−0
- src/FRP/Reactivity/RPC.hs +59/−0
- src/FRP/Reactivity/UI.hs +0/−447
- src/Graphics/Subclass.hs +0/−28
- src/Graphics/Win32Extras.hs +0/−818
reactivity.cabal view
@@ -1,12 +1,10 @@ Name: reactivity-Version: 0.3.1.0+Version: 0.3.2.0 Synopsis: An alternate implementation of push-pull FRP. Category: reactivity, FRP Description: An alternate implementation of push-pull FRP. This is based on the Reactive package (http://haskell.org/haskellwiki/reactive) (and the sources have been made available in accordance with the GPL [license] of that package). .- Known problems with this version:- .- * UI library is currently on Windows only, but there are plans....+ The two types of reactive signals in this package reflect different tradeoffs. Choose Event when you need maximal speed, or to embed I/O effects in your programs. Choose MeasurementWrapper for precision. Author: James Candy Maintainer: info@alkalisoftware.net Homepage: http://www.alkalisoftware.net/Reactivity.html@@ -21,27 +19,32 @@ Build-Type: Simple Extra-Source-Files: Library- Build-Depends: base >=4 && <5, time >= 1.5.0.1, random, Win32, bmp >= 1.2.5.2,- monad-loops >= 0.4.2.1, monads-tf >= 0.1.0.2, transformers >= 0.3.0.0, comonad,- bytestring >= 0.10.0.2, array >= 0.4.0.1, ghc-prim, containers >=0.5.3.1, ConcurrentUtils >=0.4.0.0, parallel, list-extras, concurrent-extra >= 0.3+ Build-Depends: base >=4 && <5, time >= 1.5.0.1, random, bmp >= 1.2.5.2,+ monad-loops >= 0.4.2.1, monads-tf >= 0.1.0.2, transformers >= 0.3.0.0,+ bytestring >= 0.10.0.2, array >= 0.4.0.1, ghc-prim, containers >=0.5.3.1, parallel, list-extras, exceptions+ -- Win32 -- uncomment if impl(ghc < 6.9) { buildable: False } Hs-Source-Dirs: src Exposed-Modules:- FRP.Reactivity-+ FRP.Reactivity.AlternateEvent+ FRP.Reactivity.Measurement+ FRP.Reactivity.MeasurementWrapper+ FRP.Reactivity.RPC FRP.Reactivity.Combinators- FRP.Reactivity.UI- FRP.Reactivity.Basic- FRP.Reactivity.Draw- FRP.Reactivity.Hook- FRP.Reactivity.Extras- FRP.Reactivity.Examples- Data.XSizeable Data.WeakDict-- Graphics.Subclass+ -- uncomment to use Windows UI interface etc.+ -- FRP.Reactivity.UI+ -- FRP.Reactivity.Basic+ -- FRP.Reactivity.Draw+ -- FRP.Reactivity.Hook+ -- FRP.Reactivity.Extras+ -- FRP.Reactivity.Examples+ -- Graphics.Subclass+ -- Data.XSizeable Other-Modules:- Graphics.Win32Extras- extra-libraries: gdi32, comdlg32, winspool, comctl32+ Control.CUtils.FChan+ Control.CUtils.Conc+ -- Graphics.Win32Extras+ -- extra-libraries: gdi32, comdlg32, winspool, comctl32
+ src/Control/CUtils/Conc.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE Trustworthy, ScopedTypeVariables, DeriveDataTypeable, ImplicitParams #-} +-- | A module of concurrent higher order functions. +module Control.CUtils.Conc (ExceptionList(..), ConcException(..), assocFold, Concurrent(..), concF_, concF, conc_, conc, concP, progressConcF, oneOfF, oneOf) where + +import Prelude hiding (catch) +import Control.Exception +import Data.Typeable +import Control.Concurrent.QSemN +import Control.Concurrent.Chan +import GHC.Conc +import Data.Array.IO (newArray_, readArray, writeArray, getElems, IOArray) +import Data.Array +import Data.Array.Unsafe +import Data.Array.MArray +import Data.IORef +import Control.Monad +import Control.Arrow +import System.IO.Unsafe + +-- | For exceptions caused by caller code. +data ExceptionList = ExceptionList [SomeException] deriving (Show, Typeable) + +instance Exception ExceptionList + +-- | For internal errors. If a procedure throws this, some threads it created may still be running. It is thrown separately from ExceptionList. +data ConcException = ConcException deriving (Show, Typeable) + +instance Exception ConcException + +simpleConc_ mnds = do + sem <- newQSemN 0 + mapM_ (\m -> forkIO (do + m + signalQSemN sem 1)) + mnds + waitQSemN sem (length mnds) + +divideUp nPieces nVals = zip (0 : divisions) divisions where + divisions = if nPieces >= nVals then + [1..nVals] + else + map (`div` nPieces) $ take nPieces $ iterate (nVals +) nVals + +getExceptions exs = do + writeChan exs Nothing + exslst <- let chanToList exslst = do + may <- readChan exs + case may of + Just ex -> case fromException ex of + Just (_ :: ConcException) -> throwIO ex + Nothing -> chanToList (ex : exslst) + Nothing -> return exslst in + chanToList [] + unless (null exslst) $ throwIO (ExceptionList exslst) + +-- | A type class of arrows that support some form of concurrency. +class Concurrent a where + -- | Runs an associative folding function on the given array. + -- Note: this function only spawns enough threads to make effective use of the /capabilities/. + -- Any two list elements may be processed sequentially or concurrently. To get parallelism, + -- you have to set the numCapabilities value, e.g. using GHC's +RTS -N flag. + arr_assocFold :: a (b, b) b -> (c -> b) -> a (b, Array Int c) b + -- | The first parameter is the number of computations which are indexed from 0 to n - 1. + arr_concF_ :: (?seq :: Bool) => a (t, Int) () -> a (t, Int) () + arr_concF :: (?seq :: Bool) => a (u, Int) t -> a (u, Int) (Array Int t) + arr_oneOfF :: a (u, Int) b -> a (u, Int) b + +instance Concurrent (Kleisli IO) where + arr_assocFold f g = Kleisli $ \(init, parm) -> do + let (lo, hi) = bounds parm + when (lo > hi) $ error "Conc.arr_assocFold: empty list" + exs <- newChan + caps <- getNumCapabilities + -- With unlimited caps, you can do sqrt(n) folds on each thread, then sqrt(n) to fold the results (O(sqrt(n)f(n)) time). + let effectiveCaps = ceiling (sqrt (fromIntegral (rangeSize (bounds parm)))) `min` caps + ar <- (newArray_ (0, effectiveCaps - 1) :: IO (IOArray Int b)) + let + rtnException ex = writeChan exs (Just ex) >> return undefined + innerExHandler m = catch m rtnException + outerExHandler m = catch m (\(_ :: SomeException) -> rtnException (toException ConcException)) in + outerExHandler $ simpleConc_ $ map (\(i, (x, y)) -> + innerExHandler $ foldM (\x -> runKleisli f . (,) x . g . (parm !)) init [x..y] >>= writeArray ar i) $ zip [0..] (divideUp effectiveCaps (rangeSize $ bounds parm)) + getExceptions exs + ls <- getElems ar + foldM (curry (runKleisli f)) init ls + arr_concF_ mnds = Kleisli $ \(parm, n) -> do + exs <- newChan + caps <- getNumCapabilities + let + rtnException ex = writeChan exs (Just ex) >> return undefined + innerExHandler m = catch m rtnException + outerExHandler m = catch m (\(_ :: SomeException) -> rtnException (toException ConcException)) in + outerExHandler $ + simpleConc_ $ map (\(x, y) -> outerExHandler $ (if ?seq then sequence_ else simpleConc_) $ map (innerExHandler . runKleisli mnds . (,) parm) [x..y-1]) $ divideUp caps n + getExceptions exs + arr_concF mnds = Kleisli $ \(parm, n) -> partConcF (0, n - 1) (concF_ n) (runKleisli mnds . (,) parm) + arr_oneOfF mnds = Kleisli $ \(parm, n) -> partOneOfF (0, n - 1) (runKleisli mnds . (,) parm) + +-- '->' has no effects, but one can compute its results in parallel anyway (pointlessly, +-- in the case of 'arr_concF_'). +instance Concurrent (->) where + arr_assocFold f g x = unsafePerformIO $ assocFold (\x y -> return $! f (x, y)) g x + arr_concF_ _ = arr (const ()) + arr_concF mnds (parm, n) = let ?seq = True in unsafePerformIO $ concF n ((return $!) . mnds . (,) parm) + arr_oneOfF mnds (parm, n) = unsafePerformIO $ oneOfF n ((return $!) . mnds . (,) parm) + +-- | +assocFold f g = runKleisli (arr_assocFold (Kleisli (uncurry f)) g) + +partConc_ f mnds = concF_ (rangeSize (bounds mnds)) $ f . (+ fst (bounds mnds)) + +-- | +concF_ n mnds = runKleisli (arr_concF_ (Kleisli (mnds . snd))) ((), n) + +-- | +concF n mnds = runKleisli (arr_concF (Kleisli (mnds . snd))) ((), n) + +-- | +conc_ mnds = partConc_ (mnds !) mnds + +unsafeFreeze' :: IOArray Int e -> IO (Array Int e) +unsafeFreeze' = unsafeFreeze + +partConcF bnds f mnds = do + res <- newArray_ bnds + f (\i -> do + x <- mnds i + writeArray res i x) + unsafeFreeze' res + +-- | The next function takes an implicit parameter ?seq. Set it to True +-- if you want to only spawn threads for the capabilities (same as /assocFold/; +-- good for speed). If you need all the actions to be executed concurrently, +-- set it to False. + +-- Runs several computations concurrently, and returns their results as an array. Waits for all threads to end before returning. +conc mnds = partConcF (bounds mnds) (\f -> partConc_ f mnds) (mnds !) + +-- | Version of concF specialized for two computations. +concP m m2 = let ?seq = False in liftM ((\[Left x, Right y] -> (x, y)) . elems) + $ concF 2 (\i -> if i == 0 then + liftM Left m + else + liftM Right m2) + +progressConcF n f = do + res <- concF n (\i -> f i >>= \x -> when (i * 80 `mod` n == 0) (putChar '|') >> return x) + putStrLn "" + return res + +partOneOfF bnds mnds = do + thds <- newIORef [] + chn <- newChan + finally (do + mapM_ (\n -> do + thd <- forkIO (catch (mnds n >>= writeChan chn . Right) (\(ex :: SomeException) -> writeChan chn (Left ex) >> return undefined)) + modifyIORef thds (thd:)) + (range bnds) + let chanToList n exs = if n == rangeSize bnds then + throwIO (ExceptionList exs) + else readChan chn >>= + either + (chanToList (n + 1) . (:exs)) + return in + chanToList 0 []) + (catch (readIORef thds >>= mapM_ killThread) (\(_ :: SomeException) -> throwIO ConcException)) + +oneOfF n mnds = runKleisli (arr_oneOfF (Kleisli (mnds . snd))) ((), n) + +-- | Runs several computations in parallel, and returns one of their results (terminating the other computations). +oneOf :: Array Int (IO a) -> IO a +oneOf mnds = partOneOfF (bounds mnds) (mnds !) +
+ src/Control/CUtils/FChan.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE Trustworthy, DeriveDataTypeable #-} + +-- | Functional channels +-- | A channel data type which allows consumers to hold references to different points in a stream at the same time. Elements of a channel are kept alive only so long as there are references pointing before those elements. And producers on a channel are kept alive only so long as there are consumers. +module Control.CUtils.FChan (Chan, listToChan, chanContents, DoneReadingException(..), takeChan, tryTakeChan, newChan, makeConsumer, dupChan) where + +import Control.Concurrent.MVar +import Control.Concurrent (forkIO) +import Control.Monad +import Control.Exception +import System.Mem.Weak +import Data.Typeable +import Data.IORef + +import System.IO.Unsafe + +newtype Chan t = Chan {-# NOUNPACK #-} (MVar (t, Chan t)) + +-- | Construct a channel from a list. +{-# NOINLINE listToChan #-} +listToChan :: [t] -> Chan t +listToChan (x:xs) = Chan (unsafePerformIO (newMVar (x, listToChan xs))) +listToChan [] = Chan (unsafePerformIO newEmptyMVar) +-- Referential transparency is preserved because a means of adding +-- to a channel is not available unless explicitly provided. + +-- | Thrown by the writer function. +data DoneReadingException = DoneReadingException deriving (Typeable, Show) + +instance Exception DoneReadingException + +addChan :: MVar (Chan t) -> t -> IO () +addChan vr x = modifyMVar_ vr (\chn -> do + may <- return (Just chn) + case may of + Just (Chan vr2) -> do + vr' <- newEmptyMVar + let chn' = Chan vr' + putMVar vr2 (x, chn') + -- mkWeak chn' chn' Nothing + return chn' + Nothing -> throwIO DoneReadingException) + +-- | Take the first element from a channel, and a channel representing the remainder of the output. +takeChan (Chan vr) = readMVar vr + +tryTakeChan (Chan vr) = tryReadMVar vr + +-- | Create a new channel. The first return value is a function that can be used to add values to the channel. The second return value is the channel itself. +newChan = do + vr <- newEmptyMVar + vr2 <- newEmptyMVar + let chn = Chan vr + -- weak <- mkWeak chn chn Nothing + putMVar vr2 chn + return (addChan vr2, chn) + +-- | The first return value is a thunk that returns values from the channel successively, starting from the position of the parameter channel. The second thunk can be used to retrieve the position of the channel after all the reads made using the first thunk. +makeConsumer chn = do + vr2 <- newMVar chn + return (modifyMVar vr2 (\chn -> do + (x, chn2) <- takeChan chn + return (chn2, x)), + readMVar vr2) + +chanContents :: Chan t -> IO [t] +chanContents chn = tryTakeChan chn >>= maybe + (return []) + (\(x, xs) -> liftM (x:) (chanContents xs)) + +-- | Create a channel which is initially empty, but accumulates new elements. +dupChan chn = tryTakeChan chn >>= maybe + (return chn) + (dupChan . snd) +
− src/Data/XSizeable.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, OverlappingInstances, DeriveDataTypeable #-} - --- | A resizable array, equivalent to C++'s std::vector. Manipulate them with the Data.Array.MArray class. --- --- Use with multiple threads has to be synchronized. -module Data.XSizeable (memset, SA, getPtr, Resizable(..)) where - -import Foreign.Storable -import Foreign.Ptr -import Foreign.Marshal.Alloc -import Foreign.C.Types -import System.Mem.Weak -import Data.Int -import Data.Word -import Control.Monad -import Data.IORef -import Data.Array.IO -import Data.Array.Base -import Data.Typeable -import System.Win32.Mem - -newtype SA i e = SA (IORef (i, i, Int, Ptr e)) deriving (Eq, Typeable) - --- | Returns internal data about the array. But it cannot be counted on to be valid --- after the next call to 'resize'. --- --- Also use this to free the array once it is not needed. -getPtr (SA ref) = liftM (\(_, _, sz, p) -> (sz, p)) $ readIORef ref - -instance (Storable e) => MArray SA e IO where - getBounds (SA ref) = liftM (\(l, h, _, _) -> (l, h)) $ readIORef ref - getNumElements = liftM rangeSize . getBounds - newArray_ (l, h) = do - let required = sizeOf (undefined :: e) * rangeSize (l, h) - p <- mallocBytes required - memset p 0 (fromIntegral required) - ref <- newIORef (l, h, required, p) - return (SA ref) - unsafeRead (SA ref) i = do - tup@(_, _, _, p) <- readIORef ref - peekByteOff p (sizeOf (undefined :: e) * i) - unsafeWrite (SA ref) i x = do - tup@(_, _, _, p) <- readIORef ref - let loc = sizeOf (undefined :: e) * i - pokeByteOff p loc x - --- A resize that only works on single-dimensional arrays. -resizeBuffer :: forall i e. (Storable e) => (Ix i) => (i, i) -> SA i e -> IO () -resizeBuffer (l', h') sa@(SA ref) = do - (l, h, sz, p) <- readIORef ref - let wasRequired = sizeOf (undefined :: e) * rangeSize (l, h) - let nowRequired = sizeOf (undefined :: e) * rangeSize (l', h') - -- I want to maintain about 50% residency in the array. - (sz, p) <- if 4 * rangeSize (l', h') <= sz then - -- If the array gets small enough, resize it so it is 50% used. - let newSz = 2 * rangeSize (l', h') in - liftM ((,) newSz) $ reallocBytes p newSz - else if rangeSize (l', h') <= sz then - return (sz, p) - else - -- If the array exceeds its buffer, at least double it in size. - let newSz = nowRequired `max` (2 * wasRequired) in - liftM ((,) newSz) $ reallocBytes p newSz - when (nowRequired > wasRequired) $ memset (plusPtr p wasRequired) 0 (fromIntegral $ nowRequired - wasRequired) - writeIORef ref (l', h', sz, p) - -__resize (l', h') sa = do - (l, _) <- getBounds sa - resizeBuffer (l', h') sa - when (l /= l') $ __resize1 (l', h') sa - -__resize1 oldBnd sa = mapM_ (\i -> unsafeRead sa (index oldBnd i) >>= writeArray sa i) (range oldBnd) - --- | Mutable arrays that can in addition be resized. -class (Ix i, MArray a e m) => Resizable a i e m where - resize :: (i, i) -> a i e -> m () - -instance (Storable e) => Resizable SA Int e IO where - resize = __resize - -instance (Storable e) => Resizable SA Int8 e IO where - resize = __resize - -instance (Storable e) => Resizable SA Int16 e IO where - resize = __resize - -instance (Storable e) => Resizable SA Int32 e IO where - resize = __resize - -instance (Storable e) => Resizable SA Word8 e IO where - resize = __resize - -instance (Storable e) => Resizable SA Word16 e IO where - resize = __resize - -instance (Storable e) => Resizable SA Word32 e IO where - resize = __resize - -instance (Storable e, Ix i) => Resizable SA i e IO where - resize bnd sa = do - resizeBuffer bnd sa - __resize1 bnd sa -
− src/FRP/Reactivity.hs
@@ -1,409 +0,0 @@-{-# LANGUAGE Trustworthy, DeriveFunctor, DeriveDataTypeable, ImplicitParams #-} - --- | A different presentation of functional reactive programming, based on the Reactive --- library on Hackage. The functionals in Combinators are based on those from Reactive. -module FRP.Reactivity (module Data.Time.Clock.POSIX, Time, Event, firstRestE, firstRestE', --- * Primitive event combinators (see also Monad and MonadPlus instances) -cons, corec, withTime, withRest, once, over, displace, list, firstE, Stream(Stream), addToEvent, addToEventWithTime, getEvent, chanSource, --- * Executing events -FrameOfReference, startT, setupFrame, makeFrame, runFrame, diagnostic, -ChanEnd, chanEnd, Channel(Channel), chanWrite) where - -import GHC.Prim (Any) -import Control.Concurrent -import qualified Control.CUtils.Conc as CC -import Control.Parallel -import Control.Monad -import Control.Applicative -import Control.Comonad -import Data.Maybe -import Data.List hiding (union) -import Data.Monoid hiding (Any) -import Data.Function -import Data.Typeable -import Data.Traversable (mapM) -import qualified Data.Map as M -import Data.List.Extras.Argmax -import Data.Time.Clock.POSIX -import Data.IORef -import Data.Array -import System.IO.Unsafe -import Unsafe.Coerce -import System.IO -import System.Mem.Weak -import Prelude hiding (mapM) - -{- Desirable properties of functional reactive systems, and how this system addresses - - them: - - - - * Temporal monotonicity: This is accomplished using a global lock. By forcing - - channel submissions to be ordered, one can ensure a consistent ordering on - - external inputs. Monotonicity is further preserved by the primitive combinators. - - * Glitch-freedom: Once external inputs are acquired, they are preserved for - - later examination.-} - -type Time = Double - -data Handler t u = Handler - !(Channel (Maybe (t, Time))) - !(t -> Time -> Event u) deriving Functor - --- | A type of event streams. -data Event t = Event - (Maybe t, Time, Event t) - -- Wait for the first external event in the dictionary. The Time parameter provides a time - -- limit, after which we will continue with the event parameter. - (M.Map Integer (Handler Any t)) deriving (Typeable, Functor) - -pureOccurrences (Event (_, t, _) _) | t == 1/0 = [] -pureOccurrences (Event (Nothing, _, e) _) = pureOccurrences e -pureOccurrences (Event (Just x, t, e) _) = (x, t) : pureOccurrences e - -instance (Show t) => Show (Event t) where - showsPrec _ e = ("One possible sequence is:"++) . showsPrec 11 (pureOccurrences e) - -{-# NOINLINE lock #-} -lock = unsafePerformIO (newMVar ()) - --- | Find out if any of the channels contain occurrences. We have to be careful about how --- we dispatch the so-called pure events; if the current time is t0, and t <= t0, we --- cannot automatically conclude that t has occurred first, because we may be awaiting --- an occurrence from before 't' to get into the variable. However, if something has --- already occurred at a time 't2', we may conclude that t2 <= t0. If t <= t2, we can --- conclude that nothing t3 is waiting in the wings prior to t, because it must be t3 >= t2 --- due to interlocks and therefore t3 >= t. -firstRestE (Event (x, t, rest) mp) = do - when (M.size mp >= 1000) (modifyMVar_ lock $ \_ -> hPutStrLn stderr "Reactivity: Number of event sources getting large (>=1000)") - let ?seq = True - available <- liftM (catMaybes . elems) $ CC.conc $ listArray (0, M.size mp - 1) $ fmap (\(Handler (Channel ref) f) -> do - my <- readIORef ref - return (my >>= \(my', _) -> fmap (\(x, t) -> (f x t, t)) my')) (M.elems mp) - let (e, t2) = argmin snd available - if null available then - return Nothing - else if t <= t2 then - if t == 1/0 then do - when (M.null mp) (modifyMVar_ lock $ \_ -> hPutStrLn stderr "Reactivity: Event stream is empty!") - return Nothing - else if isJust x then - return (Just (cons (fromJust x) t rest)) - else - return (Just rest) - else - return (Just e) - --- | This function is beefier because it additionally accepts (a lower bound of) the current time, --- which upper bounds all prior occurrences. -firstRestE' t e@(Event (x, t2, rest) _) = if t2 <= t then - if isJust x then return (Just (fromJust x, t2, rest)) else firstRestE' t rest - else - firstRestE e >>= maybe (return Nothing) (firstRestE' t) - -{-# INLINE cons #-} -cons x t e = Event (Just x, t, displace t e) M.empty - --- | Carry some kind of value which gets updated from occurrence to occurrence, and collect --- the results in an event. -{-# INLINE[0] corec #-} -corec :: (t -> u -> Time -> (t, v, Time)) -> t -> Event u -> Event v -corec f x e = over e (\y t rest -> case f x y t of - (y, z, t2) -> cons z t2 (corec f y rest)) - -{-# INLINE withTime #-} --- | Get the time of event occurrences along with their values. -withTime e = corec (\_ x t -> ((), (x, t), t)) () e - --- | This functional lets you get a snapshot of the remaining elements of the event starting from a certain point --- in time. It is similar to the 'tails' function for lists. -withRest :: Event t -> Event (t, Event t) -withRest e = over e (\x t rest -> cons (x, rest) t (withRest rest)) - -instance Comonad Event where - duplicate e = over e (\x t rest -> cons (cons x t rest) t (duplicate rest)) - extract e = unsafePerformIO $ do - -- Sticky counts - atomicModifyIORef waiting (\x -> (if x == maxBound then x else succ x, ())) - res <- loop e - atomicModifyIORef waiting (\x -> (if x == maxBound then x else pred x, ())) - return res where - loop e = do - my <- firstRestE' 0 e - case my of - Just (x, _, _) -> return x - Nothing -> -- There is a semaphore that gets pulsed any time an occurrence - -- enters the system. - waitQSem sem >> loop e - -{-# INLINE once #-} -once e = over e (\x t _ -> cons x t mzero) - --- | A case analysis on events. -{-# INLINE over #-} -over :: Event t -> (t -> Time -> Event t -> Event u) -> Event u -over e@(Event (x, t, rest) mp) f = if isNothing x then - Event (Nothing, t, over rest f) mappedMp - else case f (fromJust x) t rest of - -- Get hold of the first limiting occurrence - Event (y, t2, rest2) mp2 -> - let mappedMp2 = fmap (\(Handler ref g) -> Handler ref (\x t2 -> displace t (g x t2))) mp2 in - -- Get the external alternatives and limit them at 't', - -- Switch in the external alternatives from 'f'; they have to be displaced - -- to beyond 't' for monotonicity. - Event (Nothing, t, Event (y, t`max`t2, rest2) mappedMp2) mappedMp - where - mappedMp = fmap (\(Handler ref g) -> Handler ref (\x t -> over (g x t) f)) - mp - -displace' :: Time -> Event t -> Event t -displace' t e@(Event (x, t2, rest) mp) = Event (if t <= t2 then - (x, t2, rest) - else - (x, t`max`t2, displace' t rest)) - (fmap (\(Handler ref f) -> Handler ref (\x t2 -> if t <= t2 then - f x t2 - else - displace' t (f x t2))) mp) - --- | Displace occurrences to at least 't'. --- --- Starting with a lower bound at 't' helps recursion be productive. -{-# INLINE displace #-} -displace t e = Event (Nothing, t, displace' t e) M.empty - --- | Turns a plain list of occurrences (and times) into an Event. -list ((x, t):xs) = cons x t (list xs) -list [] = mzero - -firstE e e2 = join $ once $ duplicate e <> duplicate e2 - --- The goal with this code: to determine, promptly and accurately, which of two external --- event sources ticks first. I am aided in this by the presence of locks on the addition --- of external events; these locks induce strong memory barriers; this means in turn --- that certain bad views of memory cannot occur. I do not need to contend with channel --- elements being read as filled in the opposite order they are filled, because of the --- memory barriers. On the whole, it does not matter either if a channel cell is read as --- empty when it is actually filled; in that case the whole question of which comes first --- can be put off. Lastly, I have to contend with two cells from the same channel both --- appearing empty; this is solved by retrying as described below. - -merge (Handler (Channel ref) f) (Handler (Channel ref2) g) = - -- When this test is false for full channel cells, we will chew through those - -- channel cells to reach an empty cell. - -- - -- For empty channel cells, strictly speaking this test should always be true; - -- there is only one empty channel cell at a given time for a particular channel. - -- However, it may be observed to be false; this is a consequence of the weak - -- memory model and can be fixed by retrying. The practice of retrying works - -- because an inconsistent view of memory must eventually be replaced by the - -- correct view if we wait long enough (this is called eventual consistency). - if ref == ref2 then - Just (Handler (Channel ref) (\x t -> f x t `mplus` g x t)) - else - Nothing - -instance MonadPlus Event where - mzero = Event (Nothing, 1/0, mzero) M.empty - mplus (Event (_, t, _) mp) e2 | t == 1/0 && M.null mp = e2 - mplus e (Event (_, t, _) mp) | t == 1/0 && M.null mp = e - mplus ~e@(Event (x, t, rest) mp) ~e2@(Event (x2, t2, rest2) mp2) = unsafePerformIO loop where - loop = do - -- We will chew through the channel cells and make sure that the comparison - -- between two channels' times is made against the latest cell. - my <- firstRestE e - my2 <- firstRestE e2 - case (my, my2) of - (Just e', Just e2') -> return (e' `mplus` e2') - (Just e', Nothing) -> return (e' `mplus` e2) - (Nothing, Just e2') -> return (e `mplus` e2') - _ -> if M.foldl' (\b -> (b ||) . isNothing) False unioned then - yield >> loop - else - return (Event - (if t <= t2 then - (x, t, mplus rest e2) - else - (x2, t2, mplus e rest2)) - (fmap fromJust unioned)) - unioned = fmap (\ei -> case ei of - Left ei2 -> case ei2 of - Left (Handler ref f) -> Just $ Handler ref (\x t -> f x t `mplus` e2) - Right (Handler ref f) -> Just $ Handler ref (\x t -> e `mplus` f x t) - Right h -> h) - $ M.unionWith - (\(Left (Left hdl)) (Left (Right hdl2)) -> Right (merge hdl hdl2)) - (fmap (Left . Left) mp) - (fmap (Left . Right) mp2) - -data Stream t = Stream !(t -> IO ()) !(t -> Time -> IO ()) !(Event t) deriving Typeable - -addToEvent ~(Stream f _ _) = f - -addToEventWithTime ~(Stream _ f _) = f - -getEvent ~(Stream _ _ e) = e - -{-# NOINLINE counter #-} -counter :: IORef Integer -counter = unsafePerformIO (newIORef 0) - -unsafeCast :: Handler t u -> Handler v u -unsafeCast = unsafeCoerce - --- Not used -{-immediates t e = firstRestE' t e >>= - maybe - (return e) - (\(x, t1, rest) -> if t1 <= t then do - x - immediates t rest - else - return e)-} - -chanSource :: FrameOfReference -> IO (Stream t) -chanSource frame = do - n <- atomicModifyIORef counter (\x -> (succ x, x)) - chn <- liftM Channel $ newIORef Nothing - end <- liftM chanEnd $ newIORef chn - let chanLoop chn@(Channel ref) = do - e <- unsafeInterleaveIO (do - Just (_, chn') <- readIORef ref - chanLoop chn') - return (Event (Nothing, 1/0, mzero) (M.singleton n (unsafeCast (Handler chn (\x t -> cons x t e))))) - event <- chanLoop chn - let strm = Stream - (\x -> modifyMVar_ (remainder frame) (\e@(Event tup mp) -> do - t1 <- getPOSIXTime - let t = fromRational (toRational (t1 - startT frame)) - -- Write into the channel - chanWrite end (Just (x, t)) - - wakeup - return e)) - (\x t -> modifyMVar_ (remainder frame) (\e -> chanWrite end (Just (x, t)) >> wakeup >> return e)) - event - -- Channels have to be terminated when their channel ends are garbage collected; otherwise there is a space leak. - -- This termination requires a finalizer, because I have elected not to embed event streams in a larger - -- structure such as an arrow; which manages resources. - mkWeak end end (Just (void $ forkIO $ modifyMVar_ (remainder frame) (\e -> putStrLn "Finalize" >> chanWrite end Nothing >> return e))) - return strm - -instance Alternative Event where - empty = mzero - (<|>) = mplus - -instance Monoid (Event t) where - mempty = mzero - mappend = mplus - --- The monad for Event is much like the list monad: --- * 'join' - instead of concatenating, it interleaves result events according to their times. --- * 'unit' - yields a "boring" one-point event at t = 0. -instance Monad Event where - return x = cons x 0 mzero - e >>= f = over e (\x _ rest -> f x <> (rest >>= f)) - fail _ = mzero - -instance Applicative Event where - pure = return - (<*>) = ap - -data ChanEnd t = ChanEnd {-# NOUNPACK #-} !(IORef (Channel t)) - -{-# NOINLINE chanEnd #-} -chanEnd x = ChanEnd x - -data Channel t = Channel !(IORef (Maybe (t, Channel t))) - -{-# NOINLINE chanWrite #-} -chanWrite (ChanEnd chnEnd) x = do - chn' <- newIORef Nothing - Channel chn <- readIORef chnEnd - writeIORef chnEnd (Channel chn') - writeIORef chn (Just (x, Channel chn')) - -------------------------------------------- --- Executing events - -data FrameOfReference = FrameOfReference - !(MVar (Event (IO ()))) -- The remainder as of the present time - !POSIXTime -- A start time - deriving Typeable - -remainder ~(FrameOfReference mv _) = mv - -startT ~(FrameOfReference _ start) = start - -{-# NOINLINE waiting #-} -waiting :: IORef Int -waiting = unsafePerformIO (newIORef 0) - --- This is a condition variable that wakes up all waiting threads. --- --- The semaphore is paired with a counter that indicates how many threads are waiting --- at a given time. Only waking up a certain number of threads works because I do --- not care about spurious wakeups -- i.e. it doesn't matter if a thread is woken up --- when there is no work for it to do. Care must be taken however, that a resource --- is checked in an interlocked manner prior to engaging with the wakeup mechanism, --- otherwise the thread may miss its opportunity to be woken up. -{-# NOINLINE sem #-} -sem = unsafePerformIO (newQSem 0) - -{-# INLINE wakeup #-} -wakeup = do - n <- readIORef waiting - modifyMVar_ lock (\_ -> hPutStrLn stderr (show n ++ " bumps")) - replicateM_ n (signalQSem sem) - --- | Create a frame of reference from an event and handler. -{-# INLINE makeFrame #-} -makeFrame e = do - mv <- newMVar e - startT <- getPOSIXTime - return (FrameOfReference mv startT) - -{-# INLINE setupFrame #-} -setupFrame frame e = do - tryTakeMVar (remainder frame) - putMVar (remainder frame) e - --- | Run a frame of reference in the current thread -- but N.B. that some executions of the --- frame's 'sink' may occur in other threads. --- --- See FRP.Reactivity.Basic for a more elaborate scheme that gets the results --- from I/O as event occurrences. -runFrame :: FrameOfReference -> IO a -runFrame frame = do - e <- takeMVar (remainder frame) - t1 <- getPOSIXTime - let t2 = fromRational (toRational (t1 - startT frame)) - my <- firstRestE' t2 e - let (x, t, rest) = case my of - Just tup -> tup - Nothing -> (undefined, 1/0, mzero) - my' <- firstRestE e - let Event (_, lower, _) _ = maybe e id my' - let time = min lower t - t2 - if t - t2 <= 0 then do - putMVar (remainder frame) rest - x - else do - atomicModifyIORef waiting (\x -> (if x == maxBound then x else succ x, ())) - putMVar (remainder frame) e - CC.oneOf $ listArray (0, 1) - [threadDelay (round (1000000 * time)), - waitQSem sem] - atomicModifyIORef waiting (\x -> (if x == maxBound then x else pred x, ())) - runFrame frame - -diagnostic (Event (my, t, _) mp) = do - putStr (if isJust my then "occurrence" else "bound") - putStr (" at " ++ show t ++ ", map:") - ls <- mapM (\(n, Handler (Channel ref) _) -> liftM ((,) n . isJust) (readIORef ref)) (M.assocs mp) - print ls - -{-# RULES -"corec/corec" forall f x g y e. corec f x (corec g y e) = corec - (\(x, y) z t -> case g y z t of (y', a, t') -> case f x a t' of (x', b, t'') -> ((x', y'), b, t'')) - (x, y) - e - #-}
+ src/FRP/Reactivity/AlternateEvent.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE Trustworthy, DeriveDataTypeable, DeriveFunctor, ScopedTypeVariables, RecursiveDo #-} + +module FRP.Reactivity.AlternateEvent (Event(..), eFromML, nonDispatchedIO, runEvent, +-- ** A minimal set of combinators +EventStream(..), filterMaybes, delay, delays, +-- ** Optimizer rules +fmap', scan') where + +import qualified Data.Map as M +import Data.Unique +import Data.IORef +import Data.Typeable +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Applicative +import Control.Concurrent +import Control.Monad.Catch +import System.IO.Unsafe +import Data.Time.Clock.POSIX +import Data.Maybe +import FRP.Reactivity.Measurement +import FRP.Reactivity.RPC + +-- | Event streams are here presented using the publisher-subscriber model (push-based handling +-- in contrast to the pull-based handling of 'MeasurementWrapper'). Such an event +-- is represented by a subscription function and a callback. The subscription function finishes fast allowing +-- the caller to continue. +-- +-- The motivation for introducing this data type is that, while the 'Measurement'/'MeasurementWrapper' +-- system is fast, its intensive use of memory cells that need to be garbage collected means +-- that it may not be fast enough for some purposes. +newtype Event t = Event { unEvent :: (t -> POSIXTime -> RPC ()) -> RPC (RPC ()) } deriving (Typeable, Functor) + +-- avoid inlining until rules have fired +{-# INLINE[0] eFromML #-} +-- | Extracts an 'Event' from a list of measurements. No attempt has been made to sync up +-- the time order of different calls to 'eFromML'. For this reason, it is not true that +-- "eFromML ml `mplus` eFromML ml2" equals "eFromML (ml `mergeStreams` ml2)"; please do any necessary +-- syncing before calling 'eFromML'. +eFromML :: [Measurement t] -> Event t +eFromML ls = Event (\f -> liftM (_nonDispatchedIO . killThread) $ rpcFork (mapM_ (\meas -> _nonDispatchedIO (getValue meas) >>= uncurry f) ls)) + +instance Monad Event where + return x = Event (\f -> f x 0 >> return (return ())) + Event f >>= g = Event (\h -> do + -- Lots of machinery to track all subscriptions... + ref <- _nonDispatchedIO (newIORef (return ())) + liftM (\m -> m >> join (_nonDispatchedIO (readIORef ref))) (f (get2 ref h))) where + get h t x' t' = h x' (max t t') + get2 ref h x t = unEvent (g x) (get h t) >>= \m -> _nonDispatchedIO (atomicModifyIORef ref (\m2 -> (m2 >> m, ()))) + fail _ = mzero + +-- All the properties (associativity, unitality etc.) fall out of the monad axioms. +instance MonadPlus Event where + mzero = Event (\_ -> return (return ())) -- Return immediately + mplus e e2 = Event (\f -> liftM2 (>>) (unEvent e f) (unEvent e2 f)) + +instance Monoid (Event t) where + mempty = mzero + mappend = mplus + +instance MonadIO Event where + liftIO m = Event (\f -> liftIO m >>= \x -> + _nonDispatchedIO (measure (return ())) >>= \meas -> + f x (time meas) >> return (return ())) + +-- I/O can be useful... +nonDispatchedIO m = Event (\f -> _nonDispatchedIO (measure m >>= getValue) >>= uncurry f >> return (return ())) + +-- | Run an event -- see .Basic module for a way to run with a Windows event loop. +runEvent :: Event t -> (t -> POSIXTime -> IO ()) -> IO () +runEvent e f = void $ runReaderT (unRPC $ unEvent e (\x t -> liftIO (f x t))) (False, undefined) + +instance Applicative Event where + pure = return + (<*>) = ap + +instance Alternative Event where + empty = mzero + (<|>) = mplus + +class (MonadPlus e) => EventStream e where + -- | Prooty self-explanatory. + eventFromList :: [(t, POSIXTime)] -> e t + -- | The "scan" primitive is analogous to "scanl" for lists. + scan :: (t -> u -> (t, v)) -> t -> e u -> e v + -- | A primitive like "switch" is the main way of implementing behaviors that can be switched + -- in and out as required. + switch :: e (e t) -> e t + -- | The main use of "withRemainder" is to implement manual aging of inputs. It helps prevent space + -- and time leaks. + withRemainder :: e t -> e (t, e t) + -- | Construct a channel in order to receive external events. + channel :: IO (t -> IO (), e t) + -- | Gets the current time along with every occurrence. + adjoinTime :: e t -> e (t, POSIXTime) + +retryLoop ref = -- It's a comin' + _nonDispatchedIO (readIORef ref) >>= either (\_ -> _nonDispatchedIO yield >> retryLoop ref) id + +eventSwitch e = Event (\f -> do + -- Just keep track of the most recent subscription... + ref <- _nonDispatchedIO (newIORef (Right (return ()))) + liftM (\m -> m >> retryLoop ref) (unEvent e (handler f ref))) where + handler f ref e' t = do + ei <- _nonDispatchedIO (atomicModifyIORef ref (\m -> (Left (), m))) + either + (\_ -> _nonDispatchedIO yield >> handler f ref e' t) + (\m -> do + -- Unsubscribe from it... + m + -- ... and switch in the new one + m' <- rpcFinally + (unEvent e' f) + (_nonDispatchedIO (writeIORef ref (Right (return ())))) + _nonDispatchedIO (writeIORef ref (Right m'))) + ei + +instance EventStream Event where + eventFromList = eFromML . fromList + + scan f x e = Event (\g -> do + ref <- _nonDispatchedIO (newIORef x) + unEvent e (\y t -> _nonDispatchedIO (atomicModifyIORef ref (\x -> let (x', z) = f x y in (x', z))) >>= \z -> g z t)) + + switch = eventSwitch + + withRemainder e = Event (\f -> unEvent e (\x t -> f (x, e) t)) + + channel = do + ref <- newIORef M.empty + return (add ref, e ref) + where + -- Machinery to keep track of subscriptions. This will maintain a set of callbacks + -- that want to receive messages. When a subscriber unsubscribes, it will be + -- removed from the set. + add ref x = measure (return ()) >>= \meas -> readIORef ref >>= \mp -> mapM_ (\f -> f x (time meas)) mp + unsub ref un = _nonDispatchedIO $ atomicModifyIORef ref (\mp -> (M.delete un mp, ())) + e ref = Event (\f -> _nonDispatchedIO newUnique >>= \un -> + RPC ask >>= \(_, mv) -> + _nonDispatchedIO (atomicModifyIORef ref (\mp -> (M.insert un (\x t -> runReaderT (unRPC (f x t)) (False, mv)) mp, ()))) + >> return (unsub ref un)) + + adjoinTime e = Event (\f -> unEvent e (\x t -> f (x, t) t)) + +filterMaybes :: (MonadPlus m) => m (Maybe t) -> m t +filterMaybes e = e >>= \x -> guard (isJust x) >> return (fromJust x) + +delay t e = filterMaybes $ adjoinTime (return Nothing `mplus` fmap Just e) >>= \(x, t') -> eventFromList [(x,t+t')] + +delays :: (EventStream e, MonadIO e) => e (t, POSIXTime) -> e t +delays e = e >>= \(x, t) -> eventFromList [(x, t)] + +---------------------------------------- +-- Optimization + +{-# INLINE fmap' #-} +fmap' :: (Measurement t -> Measurement u) -> [Measurement t] -> Event u +fmap' f e = scan' (\_ x -> let y = f x in (y, y)) (fmap (const undefined) (head e)) e + +{-# INLINE scan' #-} +scan' f x e = delays $ fmap (\x -> (copoint x, time x)) $ scan (\y z -> f y (unsafePerformIO $ assertMeasurement (return z))) + x + (adjoinTime (eFromML e)) + +{-# RULES +"eFromML/map" forall f e. eFromML (map f e) = fmap' f e +"eFromML/scanl" forall f x e. eFromML (scanl f x e) = scan' (\x y -> let z = f x y in (z, z)) x e +"eFromML/mzero" eFromML [] = mzero + #-}
− src/FRP/Reactivity/Basic.hs
@@ -1,238 +0,0 @@-{-# LANGUAGE Trustworthy, DeriveDataTypeable, GeneralizedNewtypeDeriving, DeriveFunctor, ScopedTypeVariables, ForeignFunctionInterface #-} - -module FRP.Reactivity.Basic (start, ticks, nil, defaultFrame, Act(Action), liftE, liftE', liftS, allOccs, delayedFixA, fixA, corecA, ex, ex2, timeMeasure, nominalTimes, run) where - -import Control.Monad.Loops -import Control.Monad.IO.Class -import Control.Monad.Fix -import Control.Monad.Reader -import Control.Monad -import Control.Applicative -import Control.Concurrent hiding (newChan) -import Control.Exception -import Control.Comonad -import Data.IORef -import Data.Monoid hiding (Any) -import Data.Typeable (Typeable) -import Data.Bits -import Data.Time.Clock.POSIX -import Data.Maybe -import System.IO.Unsafe -import FRP.Reactivity.Combinators -import System.Win32 -import Graphics.Win32 -import Graphics.Win32Extras -import System.IO -import System.Mem - -start :: POSIXTime -start = startT defaultFrame - -{-# NOINLINE ticks #-} -ticks :: Stream Time -ticks = Stream (const (return ())) (\_ _ -> return ()) (tick 0.1) - -nil = Stream (const (return ())) (\_ _ -> return ()) mzero - -{-# NOINLINE defaultFrame #-} -defaultFrame = unsafePerformIO $ makeFrame mzero - --- | The Act type, comprising an initial I/O action and a sequence of scheduled actions. -newtype Act a = Action { unAction :: IO (Event (IO (Maybe a))) } deriving (Typeable, Functor) - -instance Applicative Act where - pure = return - (<*>) = ap - --- The monad for Act continues with the actions expressed in 'f', for every tick in 'm'. -instance Monad Act where - {-# INLINE return #-} - return = liftIO . return - {-# INLINE (>>=) #-} - Action m >>= f = Action $ do - ev <- m - stream <- chanSource defaultFrame - let e' = getEvent stream - return $ fmap (\(m, t) -> m >>= maybe (return ()) ((>>= \x -> addToEventWithTime stream x t) . unAction . f) >> return Nothing) (withTime ev) - <> join e' - {-# INLINE[0] (>>) #-} - m >> m2 = m >>= const m2 - fail _ = Action $ return mempty - -instance Monoid (Act a) where - mempty = Action $ return mempty - mappend m m2 = Action $ do - ev <- unAction m - ev2 <- unAction m2 - return (ev <> ev2) - -instance Alternative Act where - empty = mempty - (<|>) = mappend - -instance MonadPlus Act where - mzero = mempty - mplus = mappend - -instance MonadIO Act where - liftIO m = Action $ liftM (return . return . Just) m - --- | A basic event lifter -- continues at all event occurrences. -liftE :: Event (IO t) -> Act t -liftE ev = Action $ return $ fmap (fmap Just) ev - --- | Lift pure events. -liftE' :: Event t -> Act t -liftE' ev = liftE (fmap return ev) - --- | A variant of 'liftE' which publishes occurrences under 'stream', and only continues once, immediately. -liftS :: Stream t -> Event (IO t) -> Act () -liftS stream ev = Action $ return $ return (return (Just ())) <> fmap (\(m, t) -> m >>= \x -> addToEventWithTime stream x t >> return Nothing) (withTime ev) - --- | Return all return values of the parameter 'a' in a single event. The single event is returned --- immediately. -allOccs :: Act t -> Act (Event t) -allOccs a = do - e' <- liftIO (chanSource defaultFrame) - (nominalTimes a >>= \(x, t) -> liftIO (addToEventWithTime e' x t) >> mzero) <> return (getEvent e') - --- | Constructs a delayed fixpoint of the given signal function; actions influence --- occurrences strictly later in the event stream. - --- Diagram: --- --- o o o o --- \ \ \ --- ( \ \ \ ) --- V V V --- o o o o --- --- || --- || --- \/ --- --- o o o o -delayedFixA :: (Event t -> Act t) -> Act t -delayedFixA f = do - s <- liftIO $ chanSource defaultFrame - e' <- liftIO $ unAction $ f $ getEvent s - (m, t) <- liftE' $ withTime e' - my <- liftIO m - x <- maybe mzero return my - liftIO $ addToEventWithTime s x t - return x - -corecA_ f x e = do - ((y, t), rest) <- liftE' (once (withRest e)) - (x', z, t2) <- liftIO $ f x y t - Action $ liftM (cons (return (Just z)) t2) $ unAction $ corecA_ f x rest - --- | An effectful version of 'corec'. -{-# NOINLINE corecA #-} -corecA f x = corecA_ f x . withTime - --- | Constructs a looping fixpoint of the given signal function; actions influence --- occurrences simultaneously or later in the event stream. - --- Diagram: --- --- o o o o --- | | | | --- ( | | | | ) --- V V V V --- o o o o --- --- || --- || --- \/ --- --- o o o o -fixA :: (Event t -> Act t) -> Act t -fixA f = do - s <- liftIO $ chanSource defaultFrame - mv <- liftIO newEmptyMVar - liftIO $ unsafeInterleaveIO (takeMVar mv) >>= addToEvent s - e' <- liftIO $ unAction $ f $ getEvent s - m <- liftE' e' - x <- liftIO m - y <- maybe mzero return x - liftIO $ putMVar mv y - liftIO $ unsafeInterleaveIO (takeMVar mv) >>= addToEvent s - return y - -ex :: Act Double -ex = corecA (\x _ t -> print x >> return (succ x, succ x, t)) 0 (tick 1) - -ex2 :: Act () -ex2 = delayedFixA (\e -> return () <> liftE' (fmap (const ()) $ delayE 5 e)) >>= liftIO . print - --- A specialized version of the foregoing where only the first occurrence is fed in. -instance MonadFix Act where - {-# INLINE mfix #-} - mfix f = fixA (\e -> liftE' (once e) >>= f) - --- | This functional gives a measurement of the current time (as measured from the start --- of execution). This measurement is subject to additional measurement error. -timeMeasure :: IO Time -timeMeasure = do - t1 <- getPOSIXTime - return (fromRational (toRational (t1 - startT defaultFrame))) - --- | Obtains the time at which the parameter action has scheduled each event occurrence. -nominalTimes :: Act t -> Act (t, Time) -nominalTimes (Action m) = Action (liftM (\e -> fmap (\(m, t) -> fmap (fmap $ \x -> (x, t)) m) $ withTime e) m) - -{-# RULES -"liftIO/liftIO" forall m m2. liftIO m >> liftIO m2 = liftIO (m >> m2) -"liftE/liftIO" forall e m. liftE e >> liftIO m = liftE (fmap (>> m) e) - #-} - --- | This is the only way to run a computation in the 'Act' monad. --- --- Care and feeding: --- --- * Programs work better when compiled, compiled with -threaded, --- and run with +RTS -Nn (n = number of capabilities). --- --- * UI operations are bound to the same thread as the message loop. --- --- * 'run' uses global state; it cannot work on multiple threads. -{-# INLINE run #-} -run :: Act a -> IO b -run action = do - -- Register window class - hdl <- getModuleHandle Nothing - cursor <- loadCursor Nothing iDC_ARROW - null <- getStockBrush nULL_BRUSH - let name = mkClassName "Frame" - registerClass (0, hdl, Nothing, Just cursor, Just null, Nothing, name) - - -- Build and run the event stream - ev <- unAction action - mv <- newEmptyMVar - let e = fmap (putMVar mv . void) ev - setupFrame defaultFrame e - forkIO $ runFrame defaultFrame - - -- Pump messages - allocaMessage $ \msg -> do - whileM_ - (return True) - (-- Dispatch an action - do - my <- tryTakeMVar mv - maybe (return ()) id my - - -- Process all messages in the queue. - whileM_ - (liftM (/=0) $ c_PeekMessage msg nullPtr 0 0 pM_REMOVE) - $ do - translateMessage msg - dispatchMessage msg - - when (isNothing my) yield - -- and repeat. - ) - - return undefined -
src/FRP/Reactivity/Combinators.hs view
@@ -3,18 +3,17 @@ -- | A different presentation of functional reactive programming, based on the Reactive -- library on Hackage. Push-pull FRP is due to Conal Elliott. The functionals here -- are directly based on those from Reactive. -module FRP.Reactivity.Combinators (module FRP.Reactivity, +module FRP.Reactivity.Combinators ( -- * Derived event combinators -list, tick, untilE, eitherOf, holdE, delayedHoldE, zipE, simultE, intersectE, differenceE, unionE, filterE, justE, duplicateE, withPrev, switchE, scanlE, calmE, count, takeE, dropE, everyNth, delayE, slowE, rests, startAt, splitE, +tick, untilE, eitherOf, holdE, zipE, simultE, intersectE, differenceE, unionE, filterE, justE, duplicateE, withPrev, calmE, count, takeE, dropE, once, everyNth, slowE, rests, startAt, splitE, -- * Reactive behaviors -Behavior, time, switcher, stepper, snapshot, flipFlop, history, scan, delay, slow, monoid, throttle, sumE, derivative, supersample, integral, threshold, frequencyToAmplitude, convolution) where +Behavior, extractB, duplicateB, time, sampleAt, switcher, stepper, snapshot, flipFlop, history, scanB, delayB, slow, monoid, throttle, sumE, derivative, supersample, integral, threshold) where import Control.Monad import Control.Monad.Fix import Control.Monad.Loops import Control.Applicative import Control.Exception -import Control.Comonad import Control.Parallel.Strategies import Control.Parallel import Data.Maybe @@ -23,43 +22,44 @@ import Data.Function import qualified Data.Map as M import Data.IORef -import FRP.Reactivity +import FRP.Reactivity.MeasurementWrapper +import FRP.Reactivity.AlternateEvent +import Data.Time.Clock.POSIX -- | A convenience to generate a tick on a regular interval. {-# INLINE tick #-} -tick t = list (map (\t -> (t, t)) [0,t..]) - -_untilE e = over e (\ei t rest -> either (\x -> cons x t (_untilE rest)) (\_ -> mzero) ei) +tick start t = eventFromList (map (\t -> (t, t)) [start,start+t..]) -- | This functional can be used to terminate an event early. {-# INLINE untilE #-} -untilE :: Event t -> Event u -> Event t -untilE e u = _untilE (eitherOf e u) +untilE :: (EventStream e) => e t -> e u -> e t +untilE e u = switch (return e `mplus` fmap (const mzero) u) {-# INLINE eitherOf #-} -eitherOf e e2 = fmap Left e <> fmap Right e2 +eitherOf :: (MonadPlus e) => e t -> e u -> e (Either t u) +eitherOf e e2 = fmap Left e `mplus` fmap Right e2 -- | Give the event times of 'e', but latching onto the ticks of 'e2'. Prior to 'e2' ticking, gives 'x'. {-# INLINE holdE #-} -holdE :: Event t -> Event u -> u -> Event (t, u) +holdE :: (EventStream e) => e t -> e u -> u -> e (t, u) holdE e e2 x = justE - $ corec (\x ei t -> either (\y -> (x, Just (y, x), t)) (\y2 -> (y2, Nothing, t)) ei) x + $ scan (\x ei -> either (\y -> (x, Just (y, x))) (\y2 -> (y2, Nothing)) ei) x $ eitherOf e e2 -- | Same deal as the previous, but holding is delayed. That is, if a tick from 'e' follows a value -- from 'e2' but happens at the same nominal time, the prior value of 'e2' is used and not said -- value. -delayedHoldE e e2 x = justE - $ corec (\(prevX, t, x) ei t2 -> either (\y -> ((prevX, t, x), Just (y, if t < t2 then x else prevX), t)) +{-delayedHoldE e e2 x = justE + $ scan (\(prevX, t, x) ei t2 -> either (\y -> ((prevX, t, x), Just (y, if t < t2 then x else prevX), t)) (\y2 -> ((x, t2, y2), Nothing, t2)) ei) (x, 0, x) - $ eitherOf e e2 + $ eitherOf e e2-} swap (x, y) = (y, x) {-# INLINE zipE #-} -zipE e x e2 y = holdE e e2 y <> fmap swap (holdE e2 e x) +zipE e x e2 y = holdE e e2 y `mplus` fmap swap (holdE e2 e x) {-# INLINE cozip #-} cozip ls = (catMaybes (map (either Just (const Nothing)) ls), catMaybes (map (either (const Nothing) Just) ls)) @@ -72,28 +72,26 @@ -- | Pair values from 'e' to simultaneous occurrences from 'a'. Multiple occurrences -- are paired up as with 'zip'. Excess occurrences from 'a' are discarded, while --- excess occurrences from 'e' are paired with 'Nothing'. -{-# INLINE simultE #-} -simultE :: Event t -> Event u -> Event (t, Maybe u) +-- excess WithAtoms falses atomsoccurrences from 'e' are paired with 'N(E simultE #-) +simultE :: (EventStream e) => e t -> e u -> e (t, Maybe u) simultE e a = justE - $ fmap (\(x, _, _) -> x) - $ scanlE (\(_, prev, ti) (ei, t) -> if ti < t then + $ scan (\(prev, ti) (ei, t) -> if ti < t then -- Discard old occurrences either - (\y -> (Nothing, [y], t)) - (\x -> (Just (x, Nothing), [], t)) + (\y -> (([y], t), Nothing)) + (\x -> (([], t), Just (x, Nothing))) ei else -- Zip up occurrences at a single time either - (\y -> (Nothing, prev ++ [y], t)) - (\x -> case prev of { y:ys -> (Just (x, Just y), ys, t); [] -> (Just (x, Nothing), [], t) }) + (\y -> ((prev ++ [y], t), Nothing)) + (\x -> case prev of { y:ys -> ((ys, t), Just (x, Just y)); [] -> (([], t), Just (x, Nothing)) }) ei) - (Nothing, [], 0) - $ withTime + ([], 0) + $ adjoinTime $ eitherOf a e --- | Set operations on events +-- | Set-theoretical operations on event streams {-# INLINE differenceE #-} differenceE e a = justE $ fmap (\(x, m) -> maybe (Just x) (const Nothing) m) $ simultE e a @@ -101,189 +99,160 @@ intersectE e a = justE $ fmap (uncurry fmap) $ simultE e a {-# INLINE unionE #-} -unionE :: (Monoid t) => Event t -> Event t -> Event t +unionE :: (EventStream e, Monoid t) => e t -> e t -> e t unionE e e2 = intersectE (fmap (<>) e) e2 - <> differenceE e e2 - <> differenceE e2 e + `mplus` differenceE e e2 + `mplus` differenceE e2 e --- | Drop event occurrences that fail the predicate 'f'. -filterE f e = over e (\x t rest -> if f x then cons x t (filterE f rest) else filterE f rest) +{-# INLINE filterE #-} +filterE f e = e >>= \x -> guard (f x) >> return x {-# INLINE justE #-} justE e = fmap fromJust (filterE isJust e) {-# INLINE duplicateE #-} -duplicateE e = fmap (\(x, e) -> return x <> e) (withRest e) +duplicateE e = fmap (\(x, e) -> return x `mplus` e) (withRemainder e) {-# INLINE withPrev #-} -withPrev e = justE $ corec (\may y t -> (Just y, fmap (\x -> (x, y)) may, t)) Nothing e - -{-# INLINE switchE #-} -switchE e = withRest e >>= \(x, u) -> x `untilE` u - -{-# INLINE scanlE #-} -scanlE f x e = corec (\x y t -> let x' = f x y in (x', x', t)) x e +withPrev e = justE $ scan (\may y -> (Just y, fmap (\x -> (x, y)) may)) Nothing e --- | "Calms" an event so that only one event occurs at a given time. +-- | "Calms" an event stream so that only one event occurs at a given time. {-# INLINE calmE #-} calmE e = once e - <> + `mplus` fmap (fst . snd) (filterE (\((_, t), (_, t1)) -> t < t1) $ withPrev - $ withTime e) + $ adjoinTime e) {-# INLINE count #-} -count e = corec (\n x t -> (n + 1, (x, n + 1), t)) 0 e +count e = scan (\n x -> (n + 1, (x, n + 1))) 0 e -- | Event versions of 'drop' and 'take'. {-# INLINE dropE #-} dropE n e = fmap fst $ filterE ((>n) . snd) $ count e {-# INLINE takeE #-} -takeE :: (Num n, Ord n) => n -> Event t -> Event t -takeE n e = fmap fst $ filterE ((<=n) . snd) (c `untilE` delayE epsilon (filterE ((>n) . snd) c)) where +takeE :: (EventStream e, Num n, Ord n) => n -> e t -> e t +takeE n e = fmap fst $ filterE ((<=n) . snd) c where c = count e +{-# INLINE once #-} +once e = takeE 1 e + {-# INLINE everyNth #-} -everyNth :: (Num n, Ord n) => n -> Event t -> Event t +everyNth :: (EventStream e, Num n, Ord n) => n -> e t -> e t everyNth n = justE - . corec (\i x t -> if 1 + i >= n then - (0, Just x, t) + . scan (\i x -> if 1 + i >= n then + (0, Just x) else - (1 + i, Nothing, t)) + (1 + i, Nothing)) n --- | Gives all the events of 'e', but delayed 't' seconds. -{-# INLINE delayE #-} -delayE :: Time -> Event t -> Event t -delayE t e = rec t e where - rec t1 e = displace t1 (over e (\x t1 rest -> let t2 = t + t1 in cons x t2 (rec t2 rest))) - --- rec t e where --- rec t1 e = displace t1 (over e (\x t1 rest -> let t2 = t + t1 in cons x t2 (rec t2 rest))) - {-# INLINE slowE #-} -slowE x e = withTime e >>= \(y, t) -> list [(y, (x - 1) * t)] +slowE x e = adjoinTime e >>= \(y, t) -> eventFromList [(y, (x - 1) * t)] -- | Get the remainder events of 'e' looking forward from particular occurrences in 'a' {-# INLINE rests #-} -rests e a = holdE a (fmap snd (withRest e)) e +rests e a = holdE a (fmap snd (withRemainder e)) e -- | Waits until 'a' ticks before it starts ticking. {-# INLINE startAt #-} startAt e a = once (rests e a) >>= snd --- | Divides 'e' into chunks based on the ticks of 'a', and returns those chunks in an event. +-- | Divides 'e' into chunks based on the ticks of 'a', and returns those chunks in an event stream. -- The occurrences of 'e' prior to the first occurrence of 'a' are omitted. {-# INLINE splitE #-} -splitE e a = fmap (\((_, a), e) -> e `untilE` a) $ rests e (withRest a) +splitE e a = fmap (\((_, a), e) -> e `untilE` a) $ rests e (withRemainder a) {-# INLINE sumE #-} sumE :: (Num t) => Event t -> Event t -sumE = corec (\x y t -> let x' = x + y in (x', x', t)) 0 - -{-fixpoint :: (Event t -> Event t) -> Event t -fixpoint f = E - (\schedule disp g -> do - -- When the event ticks, the current tick has to be in hand prior to evaluation. - current <- newEmptyMVar - let e = f $ E - (\schedule _ g -> do - -- Feeds the value to the handler (prior to its calculation!). - let loop = do - ~(x, t) <- unsafeInterleaveIO $ takeMVar current - g mempty x t - threadDelay 100000 - loop - thd <- forkIO loop - return (killThread thd)) - 0 - -- When a value is obtained, provide it in the variable. - internalRunEvent schedule disp e (\_ x t -> do - tryPutMVar current (x, t) - processEvent schedule g mempty x t)) - 0 - -instance MonadFix Event where - mfix f = join $ fixpoint $ fmap (>>= f)-} +sumE = scan (\x y -> let x' = x + y in (x', x')) 0 ------------------------------------------- -- Reactive behaviors -data Behavior t = Switcher !(Time -> t) (Event (Time -> t)) deriving Functor +data Behavior e t = Switcher !(POSIXTime -> t) (e (POSIXTime -> t)) deriving Functor {-# INLINE time #-} -time = Switcher id mempty +time :: (MonadPlus e) => Behavior e POSIXTime +time = Switcher id mzero +{-# INLINE sampleAt #-} +sampleAt :: Behavior MeasurementWrapper t -> POSIXTime -> t +sampleAt beh t = snd $ extractMW $ snapshot (eventFromList [((), t)]) beh + {-# INLINE switcher #-} -switcher (Switcher f e) e2 = Switcher f (switchE $ return e <> fmap (\(Switcher f e) -> return f <> e) e2) +switcher (Switcher f e) e2 = Switcher f (switch $ return e `mplus` fmap (\(Switcher f e) -> return f `mplus` e) e2) {-# INLINE stepper #-} stepper x e = Switcher (const x) (fmap const e) {-# INLINE snapshot #-} snapshot e (Switcher f e2) = fmap (\((x, f), t) -> (x, f t)) - $ withTime + $ adjoinTime $ holdE e e2 f {-# INLINE flipFlop #-} -flipFlop e e2 = stepper False (fmap (const True) e <> fmap (const False) e2) +flipFlop e e2 = stepper False (fmap (const True) e `mplus` fmap (const False) e2) -- | Keep a history of 't' seconds as a "moving window" -- giving values for -- the behavior, 't' seconds prior to the current time. Outside of this --- moving window, gives a flat behavior. +-- moving window, gives a constant behavior. -- -- This functional should be enough for all "history-dependent" behaviors -- there -- should be some 't' which is a constant bound on a behavior's history, -- in order to conserve memory. -history :: Time -> Behavior t -> Behavior (Time -> t) +history :: (EventStream e) => Double -> Behavior e t -> Behavior e (POSIXTime -> t) history t (Switcher f e) = function <$> stepper [(f, 0)] windowFunctions <*> time where + tCoerced = fromRational (toRational t) function ls t1 t2 = if t1 <= t2 then fst (head ls) t1 - else maybe (fst (last ls) (t1-t)) (($t2) . fst) + else maybe (fst (last ls) (t1-tCoerced)) (($t2) . fst) $ find ((<=t2) . snd) ls - windowFunctions = corec (\ls f t1 -> let ls' = (f, t1) : map fst (takeWhile ((<t1-t) . snd . snd) $ zip ls $ tail ls) `using` evalList rseq in - (ls, ls, t1)) + windowFunctions = scan (\ls (f, t1) -> let ls' = (f, t1) : map fst (takeWhile ((>=t1-tCoerced) . snd . snd) $ zip ls $ tail ls) `using` evalList rseq in + (ls, ls)) [(f, 0)] - e + $ adjoinTime e -- | A scan for behaviors. -scan :: Behavior (t -> Event t) -> t -> Event t -scan b x = return x <> (snapshot (extract b x) (duplicate b) >>= uncurry (flip scan)) +scanB :: (EventStream e) => Behavior e (t -> e t) -> t -> e t +scanB b x = return x `mplus` (snapshot (extractB b x) (duplicateB b) >>= uncurry (flip scanB)) -_monoid e b = return b <> (snapshot (once (withRest e)) (duplicate b) >>= \((x, e), b2) -> _monoid e (x <> b2)) +_monoid :: (EventStream e, Monoid t) => e (Behavior e t) -> Behavior e t -> e (Behavior e t) +_monoid e b = return b `mplus` (snapshot (once (withRemainder e)) (duplicateB b) >>= \((x, e), b2) -> _monoid e (x <> b2)) -- | Collect the event occurrences and add them together into a single behavior, using a monoid. {-# INLINE monoid #-} -monoid :: (Monoid t) => Event (Behavior t) -> Behavior t +monoid :: (EventStream e, Monoid t) => e (Behavior e t) -> Behavior e t monoid e = switcher mempty $ _monoid e mempty --- | Each event occurrence casts a "shadow" for 't' seconds in the behavior. +-- | Each event occurrence casts a shadow for 't' seconds in the behavior. {-# INLINE throttle #-} -throttle :: Time -> Event t -> Behavior (Maybe t) -throttle t e = fmap getLast $ monoid (fmap (\(x, ti) -> stepper (Last Nothing) (list [(Last (Just x), ti), (Last Nothing, t + ti)])) (withTime e)) +throttle :: (EventStream e) => Double -> e t -> Behavior e (Maybe t) +throttle t e = fmap getLast $ monoid (fmap (\(x, ti) -> stepper (Last Nothing) (eventFromList [(Last (Just x), ti), (Last Nothing, tCoerce + ti)])) (adjoinTime e)) where + tCoerce = fromRational (toRational t) -- | Delay by 't' seconds before continuing as the behavior. -{-# INLINE delay #-} -delay t (Switcher f e) = Switcher (f . subtract t) (fmap (. subtract t) (delayE t e)) +{-# INLINE delayB #-} +delayB t (Switcher f e) = Switcher (f . subtract t) (fmap (. subtract t) (delay t e)) -- | Slow down the behavior by a factor of 'x'. {-# INLINE slow #-} slow x (Switcher f e) = Switcher (f . (/x)) (slowE x (fmap (. (/x)) e)) -instance (Monoid t) => Monoid (Behavior t) where +instance (EventStream e, Monoid t) => Monoid (Behavior e t) where mempty = pure mempty mappend e e2 = mappend <$> e <*> e2 -instance Alternative Behavior where +instance (EventStream e) => Alternative (Behavior e) where empty = error "FRP.Reactivity.empty: use Monoid instead" (<|>) = error "FRP.Reactivity.<|>: use Monoid instead" -instance Applicative Behavior where - pure x = Switcher (const x) mempty +instance (EventStream e) => Applicative (Behavior e) where + pure x = Switcher (const x) mzero Switcher f e <*> Switcher f2 e2 = Switcher (f <*> f2) $ fmap (uncurry (<*>)) $ zipE e f e2 f2 @@ -291,30 +260,25 @@ {-# INLINE cutoff #-} cutoff t f t1 = f (max t t1) --- The Behavior functor forms a /Comonad/. Its --- * 'duplicate' - produces, for a time 't', a version of the Behavior with a flat behavior up to 't'. --- If the original behavior (snapshotted) looks like [1,2,3,4,5], the duplicated --- behavior looks like [[1,2,3,4,5],[2,2,3,4,5],[3,3,3,4,5],[4,4,4,4,5],[5,5,5,5,5]]. --- --- * 'extract' - gets the value of the flat behavior, by sampling at t = 0. In the example, 'extract' --- would pull out the first element of each list, giving [1,2,3,4,5]. -instance Comonad Behavior where - extract (Switcher f _) = f 0 - duplicate (Switcher f e) = Switcher (\t -> Switcher (cutoff t f) e) (fmap (\(f, e) t -> Switcher (cutoff t f) e) (withRest e)) +-- The Behavior functor forms a Comonad. +extractB (Switcher f _) = f 0 +duplicateB (Switcher f e) = Switcher (\t -> Switcher (cutoff t f) e) (fmap (\(f, e) t -> Switcher (cutoff t f) e) (withRemainder e)) + ------------------------------------------- -- Integration epsilon = 0.0001 -- | Estimate the derivative of a behavior. -derivative :: (Real t, Fractional t) => Behavior t -> Behavior t -derivative b = (\x x1 -> (x1 - x) / fromRational (toRational epsilon)) <$> delay epsilon b <*> b +derivative :: (EventStream e, Real t, Fractional t) => Behavior e t -> Behavior e t +derivative b = (\x x1 -> (x1 - x) / fromRational (toRational epsilon)) <$> delayB epsilon b <*> b -- | Adaptively supersample a behavior. -supersample precision b = scan - ((\t x deriv _ -> list [((t, x), if t < epsilon then t + epsilon else t + fromRational (toRational $ precision / (1 + abs deriv)))]) <$> time <*> b <*> derivative b) - (extract b, 0) +supersample :: (EventStream e, Real t, Fractional t) => Double -> Behavior e t -> e (POSIXTime, t) +supersample precision b = scanB + ((\t x deriv _ -> eventFromList [((t, x), if t < epsilon then t + epsilon else t + fromRational (toRational precision) / (1 + fromRational (toRational (abs deriv))))]) <$> time <*> b <*> derivative b) + (0, extractB b) -- | Integral of behaviors integral precision b = @@ -328,15 +292,15 @@ -- | Given a differentiable behavior, find the times at which -- a certain value could be found. The result is an event which ticks -- when (an approximation of) the value is encountered. +threshold :: (EventStream e, Real t, Fractional t) => Double -> Behavior e t -> t -> e Bool threshold precision b x = justE - $ fmap (\(b, m) -> fmap (const b) m) - $ scanlE (\(gt, _) (t, y) -> if gt == (y < x) then (not gt, Just t) else (gt, Nothing)) (extract b > x, Nothing) + $ scan (\gt (t, y) -> if gt == (y < x) then (not gt, Just (not gt)) else (gt, Nothing)) (extractB b > x) $ supersample precision b ------------------------------------------- -- Waveforms -frequencyToAmplitude :: (Floating t) => [(t, Behavior t)] -> Behavior t +{-frequencyToAmplitude :: (Floating t) => [(t, Behavior t)] -> Behavior t frequencyToAmplitude frequencies = fmap sum $ traverse (\(frequency, intensity) -> (*) <$> intensity <*> fmap (sin . (* frequency) . fromRational . toRational) time) frequencies convolution :: (Real t) => [(Time, t)] -> Behavior t -> Behavior t @@ -344,43 +308,5 @@ fmap (\f -> sum $ map (\(x, y) -> f x * y) kernel) $ history kernelSize b where - kernelSize = -minimum (map fst kernel) + kernelSize = -minimum (map fst kernel)-} -------------------------------------------- --- Laws --- --- mempty >>= f = mempty [left-mempty] --- e >>= const mempty [right-mempty] --- (e <> e2) >>= f = (e >>= f) <> (e2 >>= f) [left-distributivity] --- e <> e2 <> e3 = e <> (e2 <> e3) [associativity] --- mempty <> e = e [left-mempty2] --- e <> mempty = e [right-mempty2] --- The monad laws --- --- firstE e e2 = e \/ firstE e e2 = e2 [in any given instance, either e or e2 ticks first] --- e `firstE` e2 `firstE` e2 = (e `firstE` e2) `firstE` e3 [associativity] --- firstE mempty e = e [left-mempty-firstE] --- --- withTimeE (withTimeE e) = fmap (\(x, t) -> ((x, t), t)) (withTimeE e) [fold-withTimeE] --- --- e `untilE` e = mempty [mempty-untilE] --- e `untilE` u `untilE` u2 = e `untilE` (u <> u2) [distributivity of untilE] --- --- filterE f e = e >>= \x -> guard (f x) >> return x --- --- fmap fst (withRestE e) = e --- calmE (join (duplicateE e)) = calmE e --- fmap (\(_, t) -> e `startAt` listE [((), t)]) (withTimeE e) = duplicateE e --- --- (e `untilE` a) <> (e `startAt` a) = e --- e `startAt` e = e --- e `startAt` a `startAt` a2 = e `startAt` (a >> a2) --- e `startAt` (e <> e2) = e --- e2 `startAt` (e <> e2) = e2 --- e `untilE` a `startAt` a2 = e `startAt` a2 `untilE` a --- --- delayE 0 e = e --- delayE t (delayE t2 e) = delayE (t + t2) e --- --- join (splitE e a) = startAt e a --- switchE (splitE e a) = startAt e a
− src/FRP/Reactivity/Draw.hs
@@ -1,583 +0,0 @@-{-# LANGUAGE Unsafe, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, ImplicitParams, ForeignFunctionInterface #-} - --- | A Draw monad for drawing in bitmaps. -module FRP.Reactivity.Draw (defBackground, Draw(unDraw), pack, onNewBitmap, unsafeOnBitmap, newBitmap, onBitmap, askDims, getOffset, setOffset, getPixel, setPixel, askDims', getPixel', getRValue, getGValue, getBValue, rgb, blend, mask, Font, defFont, textOut, textDimensions, areaFill, useFilter, convolve, flipped, swap, correlate, blur, enTuple, unTuple, resample, horzGradient, vertGradient, laplacian, fillRect, function, function', drawBitmap, graffito, spline, ellipse) where - -import Foreign.Ptr -import Foreign.Storable -import Foreign.C.Types -import Foreign.Marshal.Alloc -import Foreign.Marshal.Utils -import Data.ByteString (copy, index, replicate) -import qualified Data.ByteString as B -import Data.ByteString.Unsafe -import Data.Bits -import Data.Int -import Data.Word -import Data.Fixed -import Data.Array hiding (index) -import Control.Arrow -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Trans -import Control.Applicative -import Control.Exception hiding (mask) -import Control.Monad -import Control.CUtils.Conc -import Control.Concurrent -import Codec.BMP -import System.IO.Unsafe -import System.Mem.Weak -import Graphics.Win32 hiding (ellipse, fillRect, textOut) -import Graphics.Win32Extras -import Prelude hiding (replicate) - -defBackground = rgb 245 246 247 - -newtype Draw t = Draw { unDraw :: ReaderT ((Int32, Int32), Ptr CChar, Maybe (Chan (Int32, Int32, COLORREF))) (StateT (Int32, Int32) IO) t } deriving (Functor, Applicative, Monad) - -bi bmp = case bmpBitmapInfo bmp of - InfoV3 b -> b - InfoV4 b -> dib4InfoV3 b - -sizeOfFileHeader :: Int -sizeOfFileHeader = 14 - --- | Magic number that should come at the start of a BMP file. -bmpMagic :: Word16 -bmpMagic = 0x4d42 - --- | Size of `BitmapInfoV3` header (in bytes) -sizeOfBitmapInfoV3 :: Int -sizeOfBitmapInfoV3 = 40 - --- --- | Pack a 24-bit bitmap, but without error checking. -pack width height str = let - fileHeader - = FileHeader - { fileHeaderType = bmpMagic - - , fileHeaderFileSize = fromIntegral - $ sizeOfFileHeader + sizeOfBitmapInfoV3 + B.length str - - , fileHeaderReserved1 = 0 - , fileHeaderReserved2 = 0 - , fileHeaderOffset = fromIntegral (sizeOfFileHeader + sizeOfBitmapInfoV3) } - - bitmapInfoV3 - = BitmapInfoV3 - { dib3Size = fromIntegral sizeOfBitmapInfoV3 - , dib3Width = fromIntegral width - , dib3Height = fromIntegral height - , dib3HeightFlipped = False - , dib3Planes = 1 - , dib3BitCount = 24 - , dib3Compression = CompressionRGB - , dib3ImageSize = fromIntegral $ (3 * width + 3) `quot` 4 * 4 * height - , dib3PelsPerMeterX = 2834 - , dib3PelsPerMeterY = 2834 - - , dib3ColorsUsed = 0 - , dib3ColorsImportant = 0 } - - in BMP - { bmpFileHeader = fileHeader - , bmpBitmapInfo = InfoV3 bitmapInfoV3 - , bmpRawImageData = str } - --- | Create a new bitmap and draw on it. -{-# NOINLINE onNewBitmap #-} -onNewBitmap :: (Int32, Int32) -> Draw t -> (BMP, t) -onNewBitmap (wd32, ht32) draw = unsafePerformIO $ do - let sz = fromIntegral $ nBytes wd32 ht32 - p <- mallocBytes sz - let Draw st = fillRect defBackground (0, 0, wd32, ht32) >> draw - (x, _) <- runStateT (runReaderT st ((wd32, ht32), p, Nothing)) (0, 0) - ar <- unsafePackCStringLen (p, sz) - addFinalizer ar (free p) - return (pack wd ht ar, x) where - wd = fromIntegral wd32 - ht = fromIntegral ht32 - --- | Create a new blank bitmap. -{-# INLINE newBitmap #-} -newBitmap dim = fst $ onNewBitmap dim (return ()) - --- | Make a copy of a bitmap and draw on it. This only works with 24-bit bitmaps --- (but the Codec.BMP library provides conversion functions). -{-# NOINLINE onBitmap #-} -onBitmap bmp draw = unsafeOnBitmap (bmp { bmpRawImageData = copy $ bmpRawImageData bmp }) draw - --- | An unsafe version of 'onBitmap' that scribbles on the old bitmap, violating --- referential transparency. -{-# NOINLINE unsafeOnBitmap #-} -unsafeOnBitmap :: BMP -> Draw t -> (BMP, t) -unsafeOnBitmap bmp draw = unsafePerformIO $ unsafeUseAsCString (bmpRawImageData bmp) $ \p -> do - let Draw st = draw - (x, _) <- runStateT (runReaderT st ((wd32, ht32), p, Nothing)) (0, 0) - return (pack wd ht (bmpRawImageData bmp), x) where - (wd32, ht32) = askDims' bmp - wd = fromIntegral wd32 - ht = fromIntegral ht32 - -calculateByte wid x y = (3 * wid + 3) `quot` 4 * 4 * y + 3 * x - -nBytes wd32 ht32 = calculateByte wd32 0 ht32 - --- | Retrieve the bitmap's dimensions. -askDims = Draw $ liftM (\(pr, _, _) -> pr) ask - --- | Get/set the origin of the drawing viewport (normally (0, 0)). -getOffset :: Draw POINT -getOffset = Draw $ lift get - -setOffset :: POINT -> Draw () -setOffset pt = Draw (lift (put pt)) - -{-# INLINE unsafeGetPixel #-} -unsafeGetPixel (x, y) = Draw $ do - ((wid, _), ar, _) <- ask - (offX, offY) <- lift get - let byte = calculateByte wid (x + offX) (y + offY) - liftIO $ do - b <- peekByteOff ar (fromIntegral byte) - g <- peekByteOff ar (fromIntegral $ byte + 1) - r <- peekByteOff ar (fromIntegral $ byte + 2) - return (rgb r g b) - --- | -getPixel (x, y) = do - (offX, offY) <- getOffset - b <- inBounds (x + offX, y + offY) - unless b $ do - (wid, ht) <- askDims - Draw $ liftIO $ throwIO $ IndexOutOfBounds $ "FRP.Draw.getPixel: " ++ show (x + offX, y + offY) ++ " not in " ++ show wid ++ "x" ++ show ht ++ " bitmap" - unsafeGetPixel (x, y) - -makeLPARAM x y = shiftL y 16 .|. x - -{-# INLINE unsafeSetPixel #-} -unsafeSetPixel (x, y) clr = Draw $ do - (offX, offY) <- lift get - ((wid, _), ar, chn) <- ask - let byte = calculateByte wid (x + offX) (y + offY) - liftIO $ maybe - (do - pokeByteOff ar (fromIntegral byte) (getBValue clr) - pokeByteOff ar (fromIntegral $ byte + 1) (getGValue clr) - pokeByteOff ar (fromIntegral $ byte + 2) (getRValue clr)) - (\chn -> writeChan chn (x, y, clr)) - chn - --- | -setPixel (x, y) clr = do - (offX, offY) <- getOffset - b <- inBounds (x + offX, y + offY) - when b $ unsafeSetPixel (x, y) clr - --- | -askDims' :: BMP -> (Int32, Int32) -askDims' bmp = (fromIntegral (dib3Width (bi bmp)), fromIntegral (dib3Height (bi bmp))) - --- | -getPixel' (x, y) bmp = rgb - (index dat (byte + 2)) - (index dat (byte + 1)) - (index dat byte) where - dat = bmpRawImageData bmp - wid = fst (askDims' bmp) - byte = fromIntegral $ calculateByte wid x y - --- | Blend a colour into a pixel with a certain intensity. -blend :: Double -> (Int32, Int32) -> COLORREF -> Draw () -blend intensity (x, y) clr = do - (offX, offY) <- getOffset - b <- inBounds (x + offX, y + offY) - when b $ do - clr2 <- unsafeGetPixel (x, y) - let formula f = round $ fromIntegral (f clr) * intensity + fromIntegral (f clr2) * (1 - intensity) - unsafeSetPixel (x, y) $ rgb - (formula getRValue) - (formula getGValue) - (formula getBValue) - --- | Fill a region according to the given mask bitmap. -mask intensity (x, y) bmp = do - let (wid, ht) = askDims' bmp - let f = if intensity >= 1 then - \x2 y2 -> setPixel (x + x2, y + y2) - else - \x2 y2 -> blend intensity (x + x2, y + y2) - mapM_ (\y2 -> mapM_ (\x2 -> f x2 y2 (getPixel' (x2, y2) bmp)) [0..wid-1]) [0..ht-1] - -foreign import stdcall unsafe "windows.h GetDIBits" - c_GetDIBits :: HDC -> HBITMAP -> INT -> INT -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT - -type Font = (COLORREF, COLORREF, String, Int32, DWORD, Bool, Bool) - --- | A default font option -defFont :: Font -defFont = (defBackground, 0, "Tahoma", 14, fW_NORMAL, False, False) - --- | Draw some text at the point in the bitmap. -textOut :: String -> POINT -> Font -> Draw () -textOut text (drawX, drawY) (bgclr, fgclr, font, sz, weight, italic, underline) = void $ Draw $ ask >>= \tup -> lift get >>= \offs -> liftIO $ do - -- This procedure draws the text in a DDB, grabs that DDB into a DIB, then masks it into the original image. - dc <- getDC Nothing - finally - (do - cdc <- createCompatibleDC (Just dc) - finally - (withRECT (0, 0, 0, 0) $ \p -> do - setBkColor cdc bgclr - setTextColor cdc fgclr - fhdl <- createFont (sz * 72 `quot` 96) 0 0 0 weight italic underline False dEFAULT_CHARSET 0 0 0 0 font - finally - (do - oldFont <- selectFont cdc fhdl - finally - (do - -- Measure text - withTStringLen text $ \(s, l) -> c_DrawText cdc s (fromIntegral l) p dT_CALCRECT - -- Create a DDB - rt@(_, _, x, y) <- peekRECT p - bmp <- createCompatibleBitmap dc x y - finally - (runStateT - (runReaderT - (unDraw $ mask 1 (drawX, drawY) $ fst $ onNewBitmap (x, y) $ Draw $ ask >>= \(_, pbits, _) -> liftIO $ do - oldBmp <- selectBitmap cdc bmp - finally - (do - drawText cdc text rt 0 - withBITMAP (bmpBitmapInfo (pack x y B.empty)) $ \p -> c_GetDIBits cdc bmp 0 y (castPtr pbits) p dIB_RGB_COLORS) - (selectBitmap cdc oldBmp)) - tup) - offs) - (deleteBitmap bmp)) - (selectFont cdc oldFont)) - (deleteFont fhdl)) - (deleteDC cdc)) - (releaseDC Nothing dc) - --- | Get the dimensions of a piece of text in a given font. (Note: this may be slightly different --- on different platforms). -textDimensions :: String -> Font -> POINT -textDimensions text (_, _, font, sz, weight, italic, underline) = unsafePerformIO $ do - dc <- getDC Nothing - finally - (do - fhdl <- createFont (sz * 72 `quot` 96) 0 0 0 weight italic underline False dEFAULT_CHARSET 0 0 0 0 font - finally - (do - oldFont <- selectFont dc fhdl - finally - (withRECT (0, 0, 32767, 32767) $ \p -> do - withTStringLen text $ \(s, l) -> c_DrawText dc s (fromIntegral l) p dT_CALCRECT - (_, _, x, y) <- peekRECT p - return (x, y)) - (selectFont dc oldFont)) - (deleteFont fhdl)) - (releaseDC Nothing dc) - ----------------------------------------- --- Area fill - -inBounds (x, y) = do - (wid, ht) <- askDims - return (inRange (0, wid - 1) x && inRange (0, ht - 1) y) - -areaFillImpl _ [] _ _ = return () -areaFillImpl 0 _ _ _ = return () -areaFillImpl n frontier clrFill clrMatch = do - mapM_ (\pt -> unsafeSetPixel pt clrFill) frontier - let choices = concat [ [(x - 1, y), (x, y - 1), (x + 1, y), (x, y + 1)] | (x, y) <- frontier ] - ok <- mapM (\pt -> do - b <- inBounds pt - if b then - liftM (==clrMatch) (getPixel pt) - else - return False) choices - areaFillImpl (n - 1) (map fst $ filter snd $ zip choices ok) clrFill clrMatch - --- | Do an area fill with the given colour. -areaFill = undefined{-clr pt@(x, y) = do - clrMatch <- getPixel pt - unsafeSetPixel pt clr - let choices = listArray (0, 3) [(x - 1, y), (x, y - 1), (x + 1, y), (x, y + 1)] - Draw $ do - d <- ask - let ?seq = True - lift $ conc_ (fmap (\choice -> runReaderT (unDraw $ areaFillImpl 10 [choice] clr clrMatch) d) choices)-} - ----------------------------------------- --- Convolution - -{-# INLINE useFilter #-} -useFilter filter shift im x y = let - (kw, kh) = askDims' filter - (wid, ht) = askDims' im - halfX = kw `quot` 2 - halfY = kh `quot` 2 - x1 = (x - halfX) `max` 0 - y1 = (y - halfY) `max` 0 - x2 = (x + halfX) `min` wid - y2 = (y + halfY) `min` ht - shiftBy = fromIntegral (if shift then 127 else 0) - sz = if shift then - fromIntegral $ (y2 - y1) * (x2 - x1) * 127 - else - sum (map (\y -> sum $ map (\x -> enTuple (getPixel' (x, y) filter)) - [0..x2-x1-1]) [0..y2-y1-1]) `max` 1 in - shiftBy + sum (map (\y -> sum $ map (\x -> (enTuple (getPixel' (x, y) filter) - shiftBy) * enTuple (getPixel' (x1 + x, y1 + y) im)) [0..x2-x1-1]) [0..y2-y1-1]) / sz - --- | Standard convolution (with cutoffs). -convolve :: BMP -> Bool -> BMP -> Draw () -convolve filter shift bmp = function' (\x y -> unTuple $ useFilter filter shift bmp x y) - --- | Flip the current image corner to corner. -flipped = do - (wid, ht) <- askDims - mapM_ (\y -> mapM_ (\x -> unsafeSwap (x, y) (wid - 1 - x, ht - 1 - y)) [0..wid-1]) [0..ht`div`2-1] - -unsafeSwap pt pt2 = do - clr <- unsafeGetPixel pt - clr2 <- unsafeGetPixel pt2 - unsafeSetPixel pt clr2 - unsafeSetPixel pt2 clr - --- | Swaps two pixels. -swap pt pt2 = do - clr <- getPixel pt - clr2 <- getPixel pt2 - unsafeSetPixel pt clr2 - unsafeSetPixel pt2 clr - --- | Standard correlation -correlate :: BMP -> Bool -> BMP -> Draw () -correlate kernel = convolve (fst $ onBitmap kernel flipped) - -intensity x = rgb n n n where - n = round $ 255 * x - --- | Gaussian blur filter. -blur :: Double -> BMP -blur sigma = fst $ onNewBitmap (2 * dist, 2 * dist) $ function' $ \x y -> intensity $ f (x - dist, y - dist) where - dist = round (3 * sigma) - f (x, y) = exp (-0.5 * (fromIntegral x ^ 2 + fromIntegral y ^ 2) / sigma ^ 2) / (2 * pi) - ----------------------------------------- --- Bilinear resampling - -instance (Num t, Num u, Num v) => Num (t, u, v) where - (n1, n2, n3) + (m1, m2, m3) = (n1 + m1, n2 + m2, n3 + m3) - negate (n1, n2, n3) = (-n1, -n2, -n3) - (n1, n2, n3) * (m1, m2, m3) = (n1 * m1, n2 * m2, n3 * m3) - signum (n1, n2, n3) = (signum n1, signum n2, signum n3) - abs (n1, n2, n3) = (abs n1, abs n2, abs n3) - fromInteger n = (fromInteger n, fromInteger n, fromInteger n) - -instance (Fractional t, Fractional u, Fractional v) => Fractional (t, u, v) where - fromRational n = (fromRational n, fromRational n, fromRational n) - recip (n1, n2, n3) = (recip n1, recip n2, recip n3) - -enTuple :: COLORREF -> (Fixed E6, Fixed E6, Fixed E6) -enTuple x = (fromIntegral $ getRValue x, fromIntegral $ getGValue x, fromIntegral $ getBValue x) - -unTuple :: (Fixed E6, Fixed E6, Fixed E6) -> COLORREF -unTuple (r, g, b) = rgb (round r) (round g) (round b) - -{-# INLINE weights #-} -weights f (lo, hi) = if floor lo == floor hi then - f (floor lo) - else fromRational (recip (hi - lo)) * (fromRational (fromIntegral (ceiling lo) - lo) * f (floor lo) - + fromRational (hi - fromIntegral (floor hi)) * f (floor hi) - + sum (map f [ceiling lo..floor hi-1])) - -{-# INLINE weightsSpecial1 #-} -weightsSpecial1 factor f (lo, hi) = fromRational (recip (fromIntegral factor)) * sum (map f [ceiling lo..floor hi-1]) - -{-# INLINE weightsSpecial2 #-} -weightsSpecial2 f (lo, _) = f (floor lo) - -{-# INLINE weightsSpecial3 #-} -weightsSpecial3 f (lo, hi) = fromRational (recip (hi - lo)) * (fromRational (fromIntegral (ceiling lo) - lo) * f (floor lo) - + fromRational (hi - fromIntegral (floor hi)) * f (floor hi) - + sum (map f [ceiling lo..floor hi-1])) - --- | Averages over the pixels in the given rectangle. -{-# INLINE sample #-} -sample weights im ((loX, loY), (hiX, hiY)) = unTuple $ weights (\y -> weights (\x -> enTuple $ getPixel' (x, y) im) (loX, hiX)) (loY, hiY) - -rescale2 hi hi2 x = fromIntegral (x * (hi2 + 1)) / fromIntegral (hi + 1) - --- | Rescales a coordinate by moving it from the given first rectangle to the proportionate spot in the second rectangle. -rescale (hiX, hiY) (hiX2, hiY2) (x, y) = (rescale2 hiX hiX2 x, rescale2 hiY hiY2 y) - -down1 (x, y) = (x - 1, y - 1) - --- | Resamples the given image into the current image. -resample :: BMP -> Draw () -resample im = do - bnds <- askDims - if bnds == askDims' im then - mask 1 (0, 0) im - else let (factor, m) = divMod (fst (askDims' im)) (fst bnds) in - function' $ \x y -> sample - -- These are optimizations for the case when the input image is an integral multiple of the output in size... - (if m == 0 && snd (askDims' im) `mod` snd bnds == 0 then - weightsSpecial1 factor - -- and the opposite... - else if fst bnds `mod` fst (askDims' im) == 0 && snd bnds `mod` snd (askDims' im) == 0 then - weightsSpecial2 - -- and for when the image is being downsampled. - else if fst bnds < fst (askDims' im) && snd bnds < snd (askDims' im) then - weightsSpecial3 - else - weights) - im (rescale (down1 bnds) (down1 $ askDims' im) (x, y), rescale (down1 bnds) (down1 $ askDims' im) (x + 1, y + 1)) - -horzGradient = fst $ onNewBitmap (3, 3) $ function' $ \x _ -> intensity (fromIntegral x / 2) - -vertGradient = fst $ onNewBitmap (3, 3) $ function' $ \_ y -> intensity (fromIntegral y / 2) - -laplacian = fst $ onNewBitmap (3, 3) $ function' $ curry (listArray ((0, 0), (2, 2)) [0,-1,0,-1,10,-1,0,-1,0] !) - ----------------------------------------- --- Quadratic splines - -stepsI :: Int -stepsI = 100 - -steps :: Double -steps = fromIntegral stepsI - -graph (ax, ay, len) (x, y, direction, ddydirection, dy, t) = (x + direction / steps, y + direction * dy / steps, direction, ddydirection, dy + 2 * direction * ddydirection * ay / ax * step, t + step) where - step = sqrt (1 + dy ^ 2) / len / steps - --- Compute pixel intensities for a piece of the spline. --- TODO: Some parameter signs and flags need to be twiddled for the various quadrants, so this doesn't work currently. -intensities _ [] _ = [] -intensities swapped (parm@(ax, bx, cx, ay, by, cy):parms) tuple = - -- The intensities made by 'graph' only make sense in a certain range, - -- so when you get to a 45 degree angle, you switch x and y. - processed ++ if t >= 1 then - intensities swapped parms (x, y, direction, direction * ddydirection, dy, 0) - else - intensities (not swapped) ((ay, by, cy, ax, bx, cx):parms) (y, x, signum dy * direction, direction * ddydirection, recip dy, t) - where - (ok, (x, y, direction, ddydirection, dy, t):_) = break (\(_, _, _, _, dy, t) -> abs dy > 1 || t >= 1) $ iterate (graph (ax, ay, len parm)) tuple - processed = map (\(x, y, _, _, _, _) -> let - (y', n) = properFraction y - (a, b) = if swapped then (y', floor x) else (floor x, y') in - -- Intensity can't be 0, or we can't area fill. - ((a, b), recip 255 `max` if {-(dx > 0) == -}dy > 0 then 1 - n else n)) ok - -rotate1 ls = tail ls ++ [head ls] - -unrotate1 ls = last ls : init ls - -pairUp ls = zip ls (rotate1 ls) - --- Compute the length of a piece of the spline. -len (a, b, _, c, d, _) = f 1 - f 0 where - f t = x t * (a ^ 2 * t + a * b + c * (c * t + d)) / 2 / (a ^ 2 + c ^ 2) + 1 / 2 / (a ^ 2 + c ^ 2) ** 1.5 * (b * c - a * d) ^ 2 * log (sqrt (a ^ 2 + c ^ 2) * x t + a ^ 2 * t + a * b + c ^ 2 * t + c * d) - x t = sqrt (t ^ 2 * (a ^ 2 + c ^ 2) + 2 * a * b * t + b ^ 2 + 2 * c * d * t + d ^ 2) - -windows _ [] = [] -windows n ls = tk : windows n dr where - (tk, dr) = splitAt n ls - --- Draw the fringe of a spline. -drawAA aa parms@((_, bx, cx, _, by, cy):_) = mapM_ (\(pt, i) -> (if aa then blend i else setPixel) pt (rgb 255 255 255)) - $ map head $ windows stepsI $ drop (stepsI `quot` 2) - $ intensities - False - parms - (cx, cy, 1, 1, by / bx, 0) - --- Compute parameters of the spline. -splineCoefficients = tail . scanl (\(accel, slope, _) (x1, x2) -> let slope' = 2 * accel + slope in - (x2 - x1 - slope', slope', x1)) (0, 0, 0) . pairUp - --- | Draw an antialiased filled spline. --- The first knot should be roughly at the bottom of the spline, and they should --- go around counter clockwise. -spline aa clr knots = do - let parmX = unrotate1 $ splineCoefficients $ rotate1 $ map fst knots - let parmY = splineCoefficients $ map snd knots - let parameters = zipWith (\(ax, bx, cx) (ay, by, cy) -> (ax, bx, cx, ay, by, cy)) parmX parmY - dims <- askDims - let (bmp, _) = onNewBitmap dims $ do - drawAA aa parameters - -- areaFill (rgb 255 255 255) (ceiling *** ((+1) . ceiling) $ head knots) - mask 1 (0, 0) bmp - ----------------------------------------- --- Basic shapes - -clipRect (x1, y1, x2, y2) (x1a, y1a, x2a, y2a) = (x1 `max` x1a, y1 `max` y1a, x2 `min` x2a, y2 `min` y2a) - --- | Fill a rectangle. -fillRect clr rect = do - (wid, ht) <- askDims - function rect (\_ _ _ -> clr) - --- | Fill using a functional. -function :: (Int32, Int32, Int32, Int32) -> (COLORREF -> Int32 -> Int32 -> COLORREF) -> Draw () -function rt f = Draw $ do - d <- ask - let ?seq = True - (offX, offY) <- unDraw getOffset - (wid, ht) <- unDraw askDims - let (x1, y1, x2, y2) = clipRect rt (-offX, -offY, wid - offX, ht - offY) - liftIO $ concF_ (fromIntegral (y2 - y1)) (\y -> mapM_ (\x -> runStateT (runReaderT (unDraw $ unsafeGetPixel (x, fromIntegral y + y1) >>= \c -> unsafeSetPixel (x, fromIntegral y + y1) (f c x (fromIntegral y + y1))) d) (0, 0)) [x1..x2-1]) - -function' f = do - (wid, ht) <- askDims - function (0, 0, wid, ht) (const f) - -mean x y = (y - x) / 2 + x - --- | A filled ellipse. -ellipse aa clr (x1, y1, x2, y2) = spline aa clr [(mean x1 x2, y1), (x2, mean y1 y2), (mean x1 x2, y2), (x1, mean y1 y2)] - ----------------------------------------- --- Drawing in a device context. - -drawBitmap wnd hdc wd ht x y p = do - let wd32 = fromIntegral wd - let ht32 = fromIntegral ht - -- Draw the bitmap - withBITMAP (InfoV3 (BitmapInfoV3 40 wd ht False 1 24 CompressionRGB (4 * wd32 * ht32) 0 0 0 0)) $ \pBmp -> - c_SetDIBitsToDevice hdc x y wd32 ht32 0 0 0 ht32 p pBmp dIB_RGB_COLORS - --- | Put up a quick window to visualize the drawing as it's being drawn. -graffito (x1, y1, x2, y2) d = do - chn <- newChan - wnd <- frameWindow Nothing Nothing nullPtr "Graffito" $ \wnd msg wParam lParam -> do - if msg == wM_CREATE then do - moveWindow wnd (fromIntegral x1) (fromIntegral y1) (fromIntegral (x2 - x1)) (fromIntegral (y2 - y1)) True - else if msg == wM_PAINT then - allocaPAINTSTRUCT $ \ps -> do - hdc <- beginPaint wnd ps - forkIO $ runStateT (runReaderT (unDraw d) ((x2 - x1, y2 - y1), nullPtr, Just chn)) (0, 0) >> writeChan chn (-1, 0, 0) - let loop = do { (x, y, clr) <- readChan chn; when (x >= 0) $ do { set hdc x (y2 - y1 - 1 - y) clr; loop } } in - loop - endPaint wnd ps - else if msg == wM_CLOSE then - void $ postMessage nullPtr wM_QUIT 0 0 - else - return () - defWindowProc (Just wnd) msg wParam lParam - postMessage wnd wM_CREATE 0 0 - allocaMessage $ \msg -> - let loop = - do - b <- getMessage msg Nothing - when b $ do - translateMessage msg - dispatchMessage msg - loop in - loop
− src/FRP/Reactivity/Examples.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module FRP.Reactivity.Examples where--import Codec.BMP-import Control.Monad.IO.Class-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Fix-import Foreign.Ptr-import Data.Int-import Data.Monoid-import FRP.Reactivity.Combinators-import qualified FRP.Reactivity.Draw as D-import FRP.Reactivity.UI-import FRP.Reactivity.Hook-import FRP.Reactivity.Extras-import Control.Applicative-import Graphics.Win32-import Control.Monad.IO.Class-import System.Mem---- Examples---- | Counter app - counts the number of times the button is pressed-counter = run $ runHook $- -- Create a generic frame window...- hCreate "Frame" (Appearance mempty "Counter" (0, 0, 400, 300), mempty :: Event (Appearance -> Appearance)) $ do- -- and a button...- w <- hCreate' "BUTTON" (Appearance (return ()) "Count" (0, 0, 200, 20), mempty)-- -- Make a label with a behavior that shows the count...- let e = corec (\pr@(_, n) msg t -> case msg of- Mouse _ Down _ -> ((Appearance mempty (show $ n + 1) (0, 20, 200, 40), n + 1),- Appearance mempty (show $ n + 1) (0, 20, 200, 40),- t)- _ -> (pr, fst pr, t))- (mempty, 0 :: Int) (event w)- hCreate' "STATIC" (mempty, fmap const e)-- -- Finally wait to close...- wnd <- window- Close <- lift $ liftE $ fmap return $ event wnd- liftIO $ destroyWindow $ hwnd wnd---- | Make a graph of the sine function.-animation = fmap (\b -> Appearance b "Graph" (0, 0, 250, 150)) $ graphBehavior (fmap sin time) (pure (0, 0, 250, 150)) (-1, 1) 10 (\_ -> rgb 212 100 0)--graphing = run $ runHook $ hCreate "Frame" animation autoclose--barChartTest = run $ runHook $ hCreate "Frame" (pure $ mempty { rect = (0, 0, 250, 150) }) $ barChart [("0", 10), ("1", 20)] 40 (250, 150) (const (rgb 255 0 0))--trackingBox ev = stepper mempty (fmap (\(x, y) -> Appearance (D.fillRect (rgb 0 255 0) (x - 20, y - 20, x + 20, y + 20)) "Tracker" (0, 0, 400, 300)) (mousePos ev))--mouseTracker = run $ do- ev <- liftIO (chanSource defaultFrame)- runHook (hCreate "Frame" (trackingBox (getEvent ev)) (autoclose >> window >>= \w -> lift (liftE (fmap return (event w))) >>= \x -> liftIO (print () >> addToEvent ev x)))--blinky = run $ runHook $ hCreate "Frame" (fmap (\n -> Appearance (D.function (0, 0, 32767, 32767) (\_ x y -> rgb- 0- (fromIntegral $ (x ^ 2 + y ^ 2) * round (n * 16))- (fromIntegral $ (x ^ 2 - y ^ 2) * round (n * 16)))) "" (0, 0, 400, 300)) time)- $ do- autoclose- lift $ liftE $ fmap (const performGC) (tick 5)---- Scrollbars-scrollbars = run $ runHook $- hCreate "Frame" (mempty { rect = (0, 0, 400, 300) }, mempty) $ do- scroll $ hCreate' "BUTTON" (Appearance (return ()) "" (500, 300, 700, 330), mempty)- autoclose--highFive = run $ runHook $ do- s <- liftIO $ chanSource defaultFrame- w <- hCreate "Frame" (fmap (\s -> Appearance (return ()) s (0, 0, 400, 300)) $ stepper "High five"- (justE (fmap (\x -> case x of- Mouse _ Down _ -> Just "Too slow!"- _ -> Nothing) (getEvent s))- <> cons "Don't leave me hanging" 5 mzero))- (autoclose >> window)- lift $ liftS s (fmap return (event w))
− src/FRP/Reactivity/Extras.hs
@@ -1,355 +0,0 @@-{-# LANGUAGE Trustworthy, FlexibleContexts, ScopedTypeVariables #-} - --- | Extra utilities. -module FRP.Reactivity.Extras where - -import FRP.Reactivity.Hook hiding (convert) -import FRP.Reactivity.UI -import FRP.Reactivity.Draw -import FRP.Reactivity.Combinators -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Fix -import Control.Arrow -import Control.Applicative -import Control.Comonad (duplicate) -import Control.Exception -import Control.Concurrent.MVar -import Data.Int -import Data.Monoid -import Data.Fixed -import Data.Maybe -import qualified Data.Map as M -import Graphics.Win32 hiding (textOut, fillRect) -import Codec.BMP -import Prelude hiding (until) - -import System.IO.Unsafe - --- | -dragNDrop :: (Monoid r) => (POINT -> Appearance) -> Maybe RECT -> Hook r (Event Message) Act t -> Hook r (Event Message) Act (Either t (Window, Btn, POINT, POINT)) -dragNDrop appr rect h = do - w <- window - (x, child) <- getReturns id id h - tellReturn child - return (Left x) <> do - -- Pick a child to follow - w2 <- lift $ liftE $ fmap return child - - -- Wait for a child to be clicked - (btn, pt@(origX, origY), rest) <- lift $ liftE $ justE $ fmap (\(e, rest) -> case e of - Mouse b Down pt -> Just (return (b, pt, rest)) - _ -> Nothing) - (withRest (event w2)) - - let pos = mousePos rest - - -- Wait for the mouse to exit a "guard region" which prevents unwanted drags. - -- If the mouse is released before exiting the guard region, the drag operation is aborted. - lift $ liftE $ fmap return $ once $ filterE (\(x, y) -> abs (x - origX) > 20 && abs (y - origY) > 20) pos `untilE` filterE (\e -> case e of Mouse _ Up _ -> True; _ -> False) rest - - liftIO (putStrLn "Dragging") - - -- Move the drag icon in a drag operation. - liftM fst $ getReturns1 mempty id $ hCreate "STATIC" (stepper mempty $ fmap appr pos) - (do - drag <- window - lift $ liftE $ once $ justE (fmap (\e -> case e of Mouse _ Up pt2 -> Just (destroyWindow (hwnd drag) >> return (Right (w2, btn, pt, pt2))); _ -> Nothing) rest)) - --- | -draggable :: (POINT -> Appearance) -> Maybe RECT -> Hook (Event (Appearance -> Appearance)) (Event Message) Act t -> Hook (Event (Appearance -> Appearance)) (Event Message) Act t -draggable appr rt h = do - dragEvents <- liftIO (chanSource defaultFrame) - (ei, child) <- getReturns (fmap (\(_, _, (x1, y1), (x2, y2)) a -> a { rect = shift (x2 - x1, y2 - y1) (rect a) }) (getEvent dragEvents) <>) id $ dragNDrop appr rt h - either - (\ei -> tellReturn child >> return ei) - (\tup -> lift (liftS dragEvents $ return $ return tup) >> mzero) - ei - -dragMargin = 5 - -data Side = Ll | Rr | U | D | N deriving Eq - -updateRect (Ll, U) (_, _, x2, y2) (x, y) = (x, y, x2, y2) -updateRect (Rr, U) (x1, _, _, y2) (x, y) = (x1, y, x, y2) -updateRect (Ll, D) (_, y1, x2, _) (x, y) = (x, y1, x2, y) -updateRect (Rr, D) (x1, y1, _, _) (x, y) = (x1, y1, x, y) -updateRect (Ll, N) (_, y1, x2, y2) (x, _) = (x, y1, x2, y2) -updateRect (Rr, N) (x1, y1, _, y2) (x, _) = (x1, y1, x, y2) -updateRect (N, U) (x1, _, x2, y2) (_, y) = (x1, y, x2, y2) -updateRect (N, D) (x1, y1, x2, _) (_, y) = (x1, y1, x2, y) -updateRect (N, N) rt _ = rt - -isRight (Right _) = True -isRight _ = False - --- | Functional which makes windows from the parameter 'h' into sizeable windows with draggable edges. -sizeable :: Hook (Event (Appearance -> Appearance)) (Event Message) Act t -> - Hook (Event (Appearance -> Appearance)) (Event Message) Act t -sizeable h = do - w <- window - wit <- liftIO (chanSource defaultFrame) - (x, child) <- getReturns (getEvent wit <>) (fmap (\(_, _, _, e, _) -> e) . filterE (\(hside, vside, _, _, _) -> hside == N && vside == N) . findDragEvents) h - tellReturn child - return x <> do - -- Pick a child - w2 <- lift $ liftE $ fmap return child - - -- Wait for a child to be sized - (hside, vside, rt@(left, top, _, _), _, eRest) <- lift $ liftE $ fmap return $ findDragEvents (event w2) - - guard (hside /= N || vside /= N) - - let resizeRects = justE (fmap (\e -> case e of - Mouse _ Mv (x, y) -> Just (updateRect (hside, vside) rt (left + x, top + y)) - _ -> Nothing) eRest) - let endResizeRect = justE (fmap (\e -> case e of - Mouse _ Up (x, y) -> Just (updateRect (hside, vside) rt (left + x, top + y)) - _ -> Nothing) eRest) - - -- Draw selection rectangle (the four borders) - -- This illustrates how static controls can be used to draw shapes - let initAppearance = Appearance (fillRect 0 (0, 0, 65536, 65536)) "" (0, 0, 0, 0) - s1 <- hCreate' "STATIC" (cons (const initAppearance) 0 $ fmap (\(x1, y1, x2, y2) a -> a { rect = (x1, y1, x2, y1 + dragMargin) }) resizeRects) - s2 <- hCreate' "STATIC" (cons (const initAppearance) 0 $ fmap (\(x1, y1, x2, y2) a -> a { rect = (x1, y1 + dragMargin, x1 + dragMargin, y2 - dragMargin) }) resizeRects) - s3 <- hCreate' "STATIC" (cons (const initAppearance) 0 $ fmap (\(x1, y1, x2, y2) a -> a { rect = (x2 - dragMargin, y1 + dragMargin, x2, y2 - dragMargin) }) resizeRects) - s4 <- hCreate' "STATIC" (cons (const initAppearance) 0 $ fmap (\(x1, y1, x2, y2) a -> a { rect = (x1, y2 - dragMargin, x2, y2) }) resizeRects) - - -- Wait for mouse cursor to release - newRt <- lift $ liftE $ fmap return $ once endResizeRect - - -- Remove selection rectangle - liftIO $ destroyWindow (hwnd s1) >> destroyWindow (hwnd s2) >> destroyWindow (hwnd s3) >> destroyWindow (hwnd s4) - - -- Update the rectangle - lift $ liftS wit $ return $ return $ \a -> a { rect = newRt } - mzero where - findDragEvents e = fmap (\(((e, eRest), rt@(x1, y1, x2, y2)), t) -> case e of - Mouse _ Down (x, y) -> - let - hside = if x < dragMargin then Ll else if x >= x2 - x1 - dragMargin then Rr else N - vside = if y < dragMargin then U else if y >= y2 - y1 - dragMargin then D else N in - (hside, vside, rt, e, startAt eRest (list [(t, 0.1)])) - _ -> (N, N, rt, e, startAt eRest (list [(t, 0.1)]))) - $ withTime - $ holdE (withRest e) (position e) (0, 0, 0, 0) - --- | Perform an action when the window is closed. -onClose :: (HWND -> IO ()) -> Hook r x Act () -onClose f = void $ do - w <- window - lift $ liftS nil $ fmap (\msg -> case msg of Close -> liftIO $ f (hwnd w); _ -> return ()) (event w) - --- | Causes the current window to close when the user closes it. -autoclose :: Hook r x Act () -autoclose = onClose destroyWindow - -realign (lo, hi) (mn, mx) x = if x < lo then - mn - else if x > hi then - mx - else - (x - lo) * (mx - mn) / (hi - lo) + mn - --- | Given, --- * A behavior 'b' --- * An event --- * A display range 'rng' --- * Sampling rate (number of samples per second) --- * And a colour functional 'clrF', --- Gives a behavior that graphs 'b' in the range 'rng'. The event indicates when to resize --- the graph in the display window. -graphBehavior :: (RealFrac t) => Behavior t -> Event RECT -> (t, t) -> Int32 -> (t -> COLORREF) -> Behavior (Draw ()) -graphBehavior b pos (nY, mY) samps clr = switcher (pure mempty) - $ fmap (\(rt@(x1, y1, x2, y2), b) -> (\t f -> graph (t - fromIntegral (x2 - x1) / fromIntegral samps, nY, t, mY) (dim rt) f clr) - <$> time - <*> history (fromIntegral $ samps * (x2 - x1)) b) - (snapshot pos (duplicate b)) - -vertLine x (y1, y2) = fillRect 0 (x, y1, x + 1, y2) - -horzLine (x1, x2) y = fillRect 0 (x1, y, x2, y + 1) - -maxOfRange :: (RealFrac t) => t -> (Int32, Fixed E6) -maxOfRange mx = (ceiling (mx / 10 ^^ n), 10 ^^ n) - where n = floor (log (fromRational (toRational mx) * 0.75) / log 10) - --- | Graphs a function in a specific range. --- --- Parameters; --- --- * (mX, mY) - The maximum data values of the graph. --- --- * (x1, y1) - The dimensions of the graph, in pixels. --- --- * f - The function to graph. --- --- * clrF - A colour functional. -graph :: (RealFrac t, RealFrac u) => (t, u, t, u) -> POINT -> (t -> u) -> (u -> COLORREF) -> Draw () -graph (nX, nY, mX, mY) (x1, y1) f clrF = do - -- Draw abscissa/ordinate - mapM_ (\n -> do - let x2 = 30 + (x1 - 40) * n `div` mxX - textOut (showFixed True $ fromRational (toRational nX) + fromIntegral n * incrementX) (x2 - 5, 5) defFont - vertLine x2 (20, 25)) [0..mxX] - mapM_ (\n -> do - let y2 = 25 + (y1 - 35) * n `div` mxY - textOut (showFixed True $ fromRational (toRational nY) + fromIntegral n * incrementY) (0, y2 - 5) defFont - horzLine (25, 30) y2) [0..mxY] - horzLine (30, x1) 25 - vertLine 30 (25, y1) - - -- Draw graph - function (31, 26, x1, y1) (\c x y -> let - v = f (realign (31, fromIntegral (x1 - 10)) (nX, mX) (fromIntegral x)) - aln = realign (nY, mY) (26, fromIntegral $ y1 - 10) v in - if y > floor aln then c else clrF v) - where - (mxX, incrementX) = maxOfRange (mX - nX) - (mxY, incrementY) = maxOfRange (mY - nY) - --- | This is for anything with text. Upon double-clicking on the object, it displays --- an edit control (which can be dismissed by hitting ENTER). -editableText :: Hook (Event (Appearance -> Appearance)) (Event Message) Act t -> - Hook (Event (Appearance -> Appearance)) (Event Message) Act t -editableText h = do - wnd <- window - changes <- liftIO (chanSource defaultFrame) - (x, child) <- getReturns (fmap (\t a -> a { text = t }) (getEvent changes) <>) id h - tellReturn child - return x <> do - ((w, txt), rect) <- lift $ liftE $ child >>= \w -> fmap return $ holdE (holdE (fmap (const w) $ filterE (\e -> case e of - Mouse _ Dbl _ -> True - _ -> False) (event w)) (texts (event w)) "") - (position (event w)) (0, 0, 0, 0) - - liftIO $ showWindow (hwnd w) sW_HIDE - w2 <- hCreate' "EDIT" (cons (const (Appearance mempty txt rect)) 0 mzero) - - let finish = fmap (\(_, txt) -> destroyWindow (hwnd w2) >> return txt) $ once $ holdE (filterE (\e -> case e of - Key True key -> key == vK_RETURN - _ -> False) (event w2)) - (texts (event w2)) txt - - liftIO $ showWindow (hwnd w) sW_SHOW - lift $ liftS changes finish - mzero - -data Pair t u = Pair t u deriving Show - -instance (Ord t, Ord u, Bounded t, Bounded u) => Monoid (Pair t u) where - mempty = Pair minBound minBound - mappend (Pair a1 b1) (Pair a2 b2) = Pair (max a1 a2) (max b1 b2) - -{-# INLINE convert #-} -convert reac ev = (\(pos, (rt, mx)) _ -> let (wid, ht) = dim rt in - Appearance (return ()) (show mx - ++ ',' : show pos - ++ ",0") rt) - <$> - snapshot ev reac - -{-# INLINE extent #-} -extent = monoid . fmap (stepper (Pair 0 0) . justE . fmap (\msg -> case msg of - Move (_, _, x, y) -> Just (Pair x y) - Close -> Just (Pair 0 0) - _ -> Nothing)) - -shiftControls :: Event (Int32, Int32) - -> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t - -> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act (t, Event Window) -shiftControls displacement h = do - -- Add a hook to move controls around - -- and a hook to make this invisible to other components - let adjust = (\((x, y), (x2, y2)) appr -> - appr { rect = shift (x2 - x, y2 - y) (rect appr) }) - <$> - withPrev (cons (0, 0) 0 displacement) - {-let adjust2 = (\((x, y), (x2, y2)) -> - appr { rect = shift (x2 - x, y2 - y) (rect appr) }) - <$> - withPrev (cons (0, 0) 0 displacement)-} - getReturns (second (adjust <>)) id h - -shiftAppearance :: Event (Int32, Int32) - -> Hook (Behavior Appearance) (Event Message) Act t - -> Hook (Behavior Appearance) (Event Message) Act (t, Event Window) -shiftAppearance displacement h = do - let adjust ((x, y), (x2, y2)) appr = appr { draw = getOffset >>= \(offX, offY) -> setOffset (x2 - x + offX, y2 - y + offX) >> draw appr >> setOffset (offX, offY) } - getReturns (\x -> adjust <$> stepper ((0, 0), (0, 0)) (withPrev displacement) <*> x) id h - --- | If some child controls are out of view, --- adds scroll bars that allow the user to access them. -scroll :: Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t - -> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t -scroll h = do - wnd <- window - adjustStream <- liftIO $ chanSource defaultFrame - ~(x, children) <- shiftControls (getEvent adjustStream) h - let changes = justE $ fmap (\msg -> case msg of Move rt -> Just (dim rt); _ -> Nothing) (event wnd) - let hDim = fmap (\(wid, ht) -> (0, ht - barSize, wid - barSize, ht)) changes - let vDim = fmap (\(wid, ht) -> (wid - barSize, 0, wid, ht - barSize)) changes - let ext = extent (fmap event children) - hw <- hCreate' "HSCROLLBAR" (mempty { text = "0,0,0" }, convert ((,) - <$> stepper empt hDim - <*> fmap (\(Pair x _) -> x) ext) - (fmap (\(_, _, x, _) -> x) $ position (event wnd))) - vw <- hCreate' "SCROLLBAR" (mempty { text = "0,0,0" }, convert ((,) - <$> stepper empt vDim - <*> fmap (\(Pair _ x) -> x) ext) - (fmap (\(_, _, _, y) -> y) $ position (event wnd))) - let adjusts = zipE (negate <$> getChanges (event hw)) 0 (negate <$> getChanges (event vw)) 0 - lift $ liftS adjustStream $ fmap return adjusts - return x where - empt = (0, 0, 0, 0) - getChanges = justE . fmap (\msg -> case msg of Change s -> Just (read s); _ -> Nothing) - -barSize :: LONG -barSize = 18 - -fn x = -17 * x ^ 3 + 105 * x ^ 2 - 198 * x + 100 - -easing h = shiftAppearance (switchE $ list [(fmap (\x -> (0, round (fn x))) (tick 0.1), 0), (pure (0, 0), 2)]) h - -style h = getReturns ((fillRect 0xbebed4 (0, 0, 32767, 32767) - >> mapM_ (\y -> mapM_ (\x -> blend (fromIntegral y / 200) (x, y) 0x404092) [0..199]) [0..399]) <>) - h - -darken clr = rgb (getRValue clr `quot` 2) (getGValue clr `quot` 2) (getBValue clr `quot` 2) - -barChartHelper rt@(x1, y1, x2, y2) clr = do - fillRect clr rt - let dclr = darken clr - mapM_ (\y -> fillRect dclr (x1+y, y1+y, x2+y, y2+y+1)) [0..9] - mapM_ (\x -> fillRect 0 (x1+x, y1+x, x2+x+1, y2+x)) [0..9] - --- | Graphs a list of items in a bar chart. --- --- Parameters; --- --- * items - A list of bar labels paired with their values. --- --- * mY - The maximum data value of the Y axis. --- --- * (x1, y1) - The dimensions of the graph, in pixels. --- --- * clrF - A colour functional. --- --- Returns a 'Window'. -barChart :: (RealFrac u) => [(t, u)] -> u -> POINT -> (t -> COLORREF) -> Hook (Behavior Appearance) (Event Message) Act Window -barChart items mY (x1, y1) clrF = - liftM (fst . fst) $ getReturns - (fmap (<> mempty { draw = drawAbscissa })) - id - (easing $ hCreate' "STATIC" (pure (Appearance drawBars "" (0, 0, x1, y1)))) - where - (mxY, incrementY) = maxOfRange mY - drawAbscissa = do - mapM_ (\n -> do - let y2 = 25 + (y1 - 35) * n `div` mxY - textOut (showFixed True $ fromIntegral n * incrementY) (0, y2 - 5) defFont - horzLine (25, 30) y2) [0..mxY] - horzLine (30, x1) 25 - vertLine 30 (25, y1) - drawBars = mapM_ (\((x, v), n) -> let y = realign (0, mY) (26, fromIntegral $ y1 - 10) v in barChartHelper (n, 0, n + 20, round y) (clrF x)) (zip items [0,30..]) -
− src/FRP/Reactivity/Hook.hs
@@ -1,200 +0,0 @@-{-# LANGUAGE Unsafe, GeneralizedNewtypeDeriving, DeriveFunctor, FlexibleInstances, FlexibleContexts, Rank2Types, FunctionalDependencies, OverlappingInstances, UndecidableInstances #-} - -module FRP.Reactivity.Hook (Resource(..), toBeh, Hook, --- | * Versions of UI functions that can be modified by hooks. -hCreate, hCreate', --- | * Hook readers -getFilter, window, getResource, tellReturn, getReturns, getReturns1, --- | * Running -ty, runHook) where - -import Foreign.Ptr -import Control.Applicative -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.Trans -import Control.Monad -import Data.Monoid -import FRP.Reactivity.Combinators -import FRP.Reactivity.UI -import FRP.Reactivity.Draw -import Codec.BMP -import Graphics.Win32 - -newtype Hook r x m t = Hook { unHook :: WriterT (Event Window) (ReaderT (Window, r -> r{-resource-}, x -> x{-output-}) m) t } deriving (Monad, MonadPlus, MonadFix, Functor, Applicative, Alternative, MonadIO) - -instance MonadTrans (Hook r x) where - lift = Hook . lift . lift - -instance (MonadPlus m) => Monoid (Hook r x m t) where - mempty = mzero - mappend = mplus - --- | Versions of UI functions that can be modified by hooks. -{-# INLINE hCreate #-} -hCreate :: (Resource r (Behavior Appearance)) => WndClass -> r -> Hook r (Event Message) Act t -> Hook r (Event Message) Act t -hCreate wndclass r hook = do - parent <- window - rf <- getResource - f <- getFilter - w <- lift $ create parent wndclass (\w -> toBeh w (rf r)) - tellReturn (return w) - (x, y) <- lift $ runReaderT (runWriterT (unHook hook)) (w { event = f (event w) }, rf, f) - tellReturn y - return x - -{-# INLINE hCreate' #-} -hCreate' wndclass r = hCreate wndclass r window - --- | Filters are hooks modifying the event stream the caller sees. -{-# INLINE getFilter #-} -getFilter :: (Monad m) => Hook r x m (x -> x) -getFilter = Hook $ liftM (\(_, _, f) -> f) $ lift ask - --- | Resource hooks are a way of augmenting the behaviors used by subsequent controls. -{-# INLINE getResource #-} -getResource :: (Monad m) => Hook r x m (r -> r) -getResource = Hook $ liftM (\(_, r, _) -> r) $ lift ask - -{-# INLINE tellReturn #-} -tellReturn r = Hook $ tell r - -{-# INLINE getReturns #-} -getReturns :: (Monad m) => (r -> r) -> (x -> x) -> Hook r x m t -> Hook r x m (t, Event Window) -getReturns rf f h = do - w <- window - r2 <- getResource - f2 <- getFilter - (x, children) <- lift $ runReaderT (runWriterT (unHook h)) (w, r2 . rf, f . f2) - tellReturn children - return (x, children) - -{-# INLINE getReturns1 #-} -getReturns1 r f h = do - w <- window - lift $ runReaderT (runWriterT (unHook h)) (w, r, f) - --- | 'window' gives the identity of the parent window. -{-# INLINE window #-} -window :: (Monad m) => Hook r x m Window -window = Hook $ liftM (\(w, _, _) -> w) $ lift ask - --- | Functional that fixes the usual type parameters. -{-# INLINE ty #-} -ty :: Hook (Behavior Appearance) (Event Message) Act t -> Hook (Behavior Appearance) (Event Message) Act t -ty = id - --- | Runs a procedure in the Hook monad transformer. -{-# INLINE runHook #-} -runHook ~(Hook h) = runReaderT (runWriterT h) (desktop, id, id) - -err = error "FRP.Hook.toBeh: no start value" - -toBeh :: (Resource r (Behavior Appearance)) => HWND -> r -> Behavior Appearance -toBeh = convert - --- | These are common ways of converting data to a behavior. -class Resource r s where - convert :: HWND -> r -> s - -instance Resource t t where - convert _ = id - -instance Resource (Event Appearance) (Behavior Appearance) where - convert _ = stepper err - -instance Resource (Event Appearance) (Appearance, Event (Appearance -> Appearance)) where - convert _ e = (err, fmap const e) - -instance Resource (Appearance, Event (Appearance -> Appearance)) (Behavior Appearance) where - convert _ (x, e) = stepper x $ corec (\x f t -> (f x, f x, t)) x e - -instance Resource (Event (Appearance -> Appearance)) (Behavior Appearance) where - convert w e = convert w (err :: Appearance, e) - -instance Resource (String, Event (String -> String)) (Appearance, Event (Appearance -> Appearance)) where - convert _ (s, e) = (Appearance (return ()) s (0, 0, 0, 0), fmap (\f a -> a { text = f (text a) }) e) - -instance Resource (Event String) (String, Event (String -> String)) where - convert _ e = (err, fmap const e) - -instance Resource (Event String) (Appearance, Event (Appearance -> Appearance)) where - convert _ e = (err, fmap (\x _ -> Appearance (return ()) x (0, 0, 0, 0)) e) - -instance Resource (Event String) (Behavior Appearance) where - convert _ e = stepper err (fmap (\s -> Appearance (return ()) s (0, 0, 0, 0)) e) - -instance Resource Appearance (Behavior Appearance) where - convert _ = pure - -instance Resource Appearance (Event Appearance) where - convert _ = pure - -instance Resource Appearance (Appearance, Event (Appearance -> Appearance)) where - convert _ a = (a, mempty) - -instance Resource (Draw ()) Appearance where - convert _ d = Appearance d "" (0, 0, 0, 0) - -instance Resource (Draw ()) (Behavior Appearance) where - convert _ d = pure (Appearance d "" (0, 0, 0, 0)) - -instance Resource (Draw ()) (Event Appearance) where - convert _ d = pure (Appearance d "" (0, 0, 0, 0)) - -instance Resource (Draw ()) (Appearance, Event (Appearance -> Appearance)) where - convert _ d = (Appearance d "" (0, 0, 0, 0), mempty) - -instance Resource BMP Appearance where - convert _ b = Appearance (mask 1 (0, 0) b) "" (0, 0, 0, 0) - -instance Resource BMP (Behavior Appearance) where - convert w = convert w . mask 1 (0, 0) - -instance Resource BMP (Event Appearance) where - convert _ b = pure (Appearance (mask 1 (0, 0) b) "" (0, 0, 0, 0)) - -instance Resource BMP (Appearance, Event (Appearance -> Appearance)) where - convert _ b = (Appearance (mask 1 (0, 0) b) "" (0, 0, 0, 0), mempty) - -instance Resource BMP (BMP, Event (BMP -> BMP)) where - convert _ b = (b, mempty) - -instance Resource String Appearance where - convert _ s = Appearance (return ()) s (0, 0, 0, 0) - -instance Resource String (Behavior Appearance) where - convert _ s = pure (Appearance (return ()) s (0, 0, 0, 0)) - -instance Resource String (Event Appearance) where - convert _ s = pure (Appearance (return ()) s (0, 0, 0, 0)) - -instance Resource String (Appearance, Event (Appearance -> Appearance)) where - convert _ s = (Appearance (return ()) s (0, 0, 0, 0), mempty) - -instance Resource String (String, Event (String -> String)) where - convert _ s = (s, mempty) - -instance (Resource t u) => Resource (HWND -> t) u where - convert w x = convert w (x w) - -instance Monoid BMP where - mempty = newBitmap (0, 0) - mappend b b2 = fst $ onNewBitmap (wid `max` wid2, ht + ht2) $ do - mask 1 (0, 0) b - mask 1 (0, ht) b2 where - (wid, ht) = askDims' b - (wid2, ht2) = askDims' b2 - -instance Monoid Appearance where - mempty = Appearance (return ()) "" (0, 0, 0, 0) - mappend a a2 = Appearance (draw a >> draw a2) - (text a ++ text a2) - (x1 `max` x3, y1 `max` y3, x2 `max` x4, y2 `max` y4) where - (x1, y1, x2, y2) = rect a - (x3, y3, x4, y4) = rect a2 - -instance Monoid (Draw ()) where - mempty = return () - mappend = (>>) -
+ src/FRP/Reactivity/Measurement.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE Trustworthy, DeriveDataTypeable, ScopedTypeVariables, DeriveFunctor, GeneralizedNewtypeDeriving #-} +-- | The elements of FRP. +module FRP.Reactivity.Measurement (Measurement(Empty), wait, stmAction, assertMeasurement, measure, await, blindAwait, fromList, assertChan, chan, first, leMeas, mergeStreams, getValue, copoint, time) where + +import GHC.Conc hiding (Chan, newChan) +import Control.Concurrent.MVar +import Control.CUtils.Conc +import Control.CUtils.FChan +import System.IO.Unsafe +import Data.Time.Clock.POSIX +import Data.Typeable +import Control.Monad +import Control.Applicative +import Data.Maybe +import Data.Monoid + +eitherOr :: IO t -> IO u -> IO () +eitherOr m m2 = oneOfF 2 (\n -> if n == 0 then void m else void m2) + +-- | Measurements are a basic building block for pull-based FRP. They are like futures in that: when you have +-- something running on a separate thread, you can use a Measurement to wait on it. They also establish a +-- measurement of an an event occurrence time. Primitives for Measurements, make this measurement inside an +-- STM (software transactional memory) block. The STM system induces a global time ordering of transactions. +-- I piggyback on top of this mechanism to get a global time ordering of measurement as well. This is an +-- attempt to answer the tricky question of how to measure. +data Measurement t = Measurement + !(IO ()) + !(STM (Maybe (t, POSIXTime))) | Empty deriving (Typeable, Functor) + +instance (Show t) => Show (Measurement t) where + showsPrec prec meas = showsPrec prec (copoint meas, time meas) + +instance (Eq t) => Eq (Measurement t) where + meas == meas2 = copoint meas == copoint meas2 && time meas == time meas2 + +instance Monad Measurement where + return x = Measurement (return ()) (return (Just (x, 0))) + meas >>= f = Measurement + (getValue meas >>= wait . f . fst) + (stmAction meas >>= maybe + (return Nothing) + (\(x, t) -> liftM (fmap (\(y, t') -> (y, max t t'))) (stmAction (f x)))) + fail _ = mzero + +instance Applicative Measurement where + pure = return + (<*>) = ap + +wait ~(Measurement co _) = co + +stmAction ~(Measurement _ stm) = stm + +_assertMeasurement :: IO (t, Maybe POSIXTime) -> IO (Measurement t) +_assertMeasurement m = do + mv <- newEmptyMVar + tv <- newTVarIO Nothing + let writeMeas = do + (x, my) <- m + atomically (maybe (unsafeIOToSTM getPOSIXTime) return my >>= \t -> readTVar tv >>= maybe (writeTVar tv (Just (x, t))) (\_ -> return ())) + tryPutMVar mv () + return () + let meas = Measurement + (readMVar mv) + (readTVar tv) + forkIO writeMeas + return meas + +assertMeasurement :: IO (t, POSIXTime) -> IO (Measurement t) +assertMeasurement m = _assertMeasurement (liftM (\(x, t) -> (x, Just t)) m) + +measure :: IO t -> IO (Measurement t) +measure m = _assertMeasurement (liftM (\x -> (x, Nothing)) m) + +delayUntil :: POSIXTime -> IO () +delayUntil t = getPOSIXTime >>= \time -> threadDelay (round (1000000 * fromRational (toRational (t - time)))) + +-- | Wait for a time, then measure that time. +await :: POSIXTime -> IO (Measurement ()) +await t = measure (delayUntil t) + +-- | Give the parameter time as the time of the measurement. This is "blind" to system lags that may disrupt +-- the timing of a control signal. +blindAwait :: POSIXTime -> Measurement () +blindAwait t = unsafePerformIO (do + Measurement wait stm <- measure (delayUntil t) + return (Measurement wait (return (Just ((), t))))) + +{-# INLINE fromList #-} +fromList :: [(t, POSIXTime)] -> [Measurement t] +fromList ((x, t):xs) = fmap fst meas : snd (copoint meas) where + meas = fmap (const (x, fromList xs)) (blindAwait t) +fromList [] = [] + +{-# INLINE assertChan #-} +assertChan :: forall t. IO (t -> POSIXTime -> IO (), [Measurement t]) +assertChan = do + (f, chn) <- newChan + let loop (chn :: Chan (t, POSIXTime)) = do + meas <- assertMeasurement (do + ((x, t), chn') <- takeChan chn + ls <- unsafeInterleaveIO (loop chn') + return ((x, ls), t)) + return (fmap fst meas : snd (copoint meas)) + ls <- loop chn + return (curry f, ls) + +{-# INLINE chan #-} +chan :: IO (t -> IO (), [Measurement t]) +chan = liftM (\(f, ls) -> (\x -> getPOSIXTime >>= f x, ls)) assertChan + +-- | Decide which of the 'Measurement's comes first. I rely on the 'STM' subsystem to find +-- a consistent ordering. +first :: Measurement t -> Measurement t -> Measurement t +first Empty meas2 = meas2 +first meas Empty = meas +first meas meas2 = Measurement wt stm + where + stm = do + pr <- liftM2 (,) (stmAction meas) (stmAction meas2) + return $ case pr of + (Just (x, t), Just (x2, t2)) -> Just (if t <= t2 then (x, t) else (x2, t2)) + (Just pr, Nothing) -> Just pr + (Nothing, Just pr) -> Just pr + _ -> Nothing + wt = wait meas `eitherOr` wait meas2 + +instance MonadPlus Measurement where + mzero = Empty + mplus = first + +instance Monoid (Measurement t) where + mempty = mzero + mappend = mplus + +instance Alternative Measurement where + empty = mzero + (<|>) = mplus + +leMeas :: Measurement t -> Measurement u -> Bool +leMeas x y = copoint (fmap (const True) x `first` fmap (const False) y) + +mergeStreams (x:xs) (y:ys) = fmap fst x' : snd (copoint x') where + x' = fmap (\x' -> (x', mergeStreams xs (y:ys))) x + `first` fmap (\x' -> (x', mergeStreams (x:xs) ys)) y +mergeStreams [] xs = xs +mergeStreams xs [] = xs + +-- | Extract value and time of the measurement. +getValue :: Measurement t -> IO (t, POSIXTime) +getValue meas = do + wait meas + liftM fromJust (atomically (stmAction meas)) + +{-# INLINE copoint #-} +copoint :: Measurement t -> t +copoint = fst . unsafePerformIO . getValue + +{-# INLINE time #-} +time :: Measurement t -> POSIXTime +time = snd . unsafePerformIO . getValue +
+ src/FRP/Reactivity/MeasurementWrapper.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE Safe, DeriveDataTypeable, DeriveFunctor #-} + +module FRP.Reactivity.MeasurementWrapper (MeasurementWrapper(..), wrapOne, extractMW, measUntil, wrapperToList) where + +import FRP.Reactivity.AlternateEvent +import FRP.Reactivity.Measurement +import Data.Time.Clock.POSIX +import Data.Typeable +import Control.Monad +import Control.Monad.Fix +import Control.Applicative +import Control.Arrow (second) + +newtype MeasurementWrapper t = MeasurementWrapper { unMeasurementWrapper :: [Measurement t] } deriving (Typeable, Functor, Show) + +wrapOne m = MeasurementWrapper [m] + +instance Monad MeasurementWrapper where + return x = MeasurementWrapper [return x] + MeasurementWrapper (x:xs) >>= f = f (copoint x) `mplus` (MeasurementWrapper xs >>= f) + MeasurementWrapper [] >>= _ = mzero + fail _ = mzero + +instance MonadPlus MeasurementWrapper where + mzero = MeasurementWrapper [] + MeasurementWrapper ls `mplus` MeasurementWrapper ls2 = MeasurementWrapper (ls `mergeStreams` ls2) + +instance Monoid (MeasurementWrapper t) where + mempty = mzero + mappend = mplus + +instance Applicative MeasurementWrapper where + pure = return + (<*>) = ap + +instance Alternative MeasurementWrapper where + empty = mzero + (<|>) = mplus + +extractMW :: MeasurementWrapper t -> t +extractMW (MeasurementWrapper (x:_)) = copoint x +extractMW (MeasurementWrapper []) = error "Comonad.extract: empty MeasurementWrapper" + +measUntil :: MeasurementWrapper t -> MeasurementWrapper u -> Measurement (MeasurementWrapper t) +measUntil (MeasurementWrapper (x:xs)) (MeasurementWrapper (y:ys)) = continueInX `mplus` halt where + continueInX = liftM2 (\_ (MeasurementWrapper xs) -> MeasurementWrapper (x:xs)) + x + (measUntil (MeasurementWrapper xs) (MeasurementWrapper (y:ys))) + halt = fmap (const mzero) y + +instance EventStream MeasurementWrapper where + eventFromList ls = MeasurementWrapper (fromList ls) + + scan f x (MeasurementWrapper (y:ys)) = fmap snd $ MeasurementWrapper $ scanl (\y z -> fmap (f (fst (copoint y))) z) (fmap (const (x, undefined)) y) (y:ys) + scan _ _ (MeasurementWrapper []) = MeasurementWrapper [] + + switch (MeasurementWrapper (x1:x2:xs)) = copoint (measUntil (copoint x1) (copoint x2)) `mplus` switch (MeasurementWrapper (x2:xs)) + switch (MeasurementWrapper [x1]) = copoint x1 + switch (MeasurementWrapper []) = mzero + + withRemainder wrapper = scan (\(MeasurementWrapper rest) y -> (MeasurementWrapper (tail rest), (y, MeasurementWrapper (tail rest)))) wrapper wrapper + + channel = liftM (second MeasurementWrapper) chan + + adjoinTime (MeasurementWrapper ls) = MeasurementWrapper (map (\meas -> fmap (\x -> (x, time meas)) meas) ls) + +{-# INLINE wrapperToList #-} +wrapperToList :: MeasurementWrapper t -> [(t, POSIXTime)] +wrapperToList (MeasurementWrapper meass) = map (\meas -> (copoint meas, time meas)) meass
+ src/FRP/Reactivity/RPC.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE Safe, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveDataTypeable, ScopedTypeVariables #-} + +module FRP.Reactivity.RPC where + +import Control.Monad.Reader +import Control.Monad.IO.Class +import Control.Monad.Trans +import Control.Monad.Loops +import Control.Monad.Catch +import Control.Concurrent +import Control.Applicative +import Data.Typeable + +-- | A simple RPC server. +newtype RPC t = RPC { unRPC :: ReaderT (Bool, MVar (IO ())) IO t } deriving (Functor, Typeable) + +instance Monad RPC where + return = RPC . return + m >>= f = RPC $ unRPC m >>= unRPC . f + fail = RPC . fail + +instance Applicative RPC where + pure = return + (<*>) = ap + +instance MonadIO RPC where + liftIO m = RPC $ ask >>= \(ty, mv2) -> lift $ + if ty then + newEmptyMVar >>= \mv -> putMVar mv2 (catch (m >>= putMVar mv . Right) (\(ex :: SomeException) -> putMVar mv (Left ex))) + >> takeMVar mv >>= either throwM return + else + m + +rpcFork (RPC m) = RPC $ ask >>= \(_, mv) -> lift (forkIO (runReaderT m (True, mv))) + +{-# INLINE _nonDispatchedIO #-} +_nonDispatchedIO m = RPC (lift m) + +instance MonadThrow RPC where + throwM e = _nonDispatchedIO (throwM e) + +instance MonadCatch RPC where + catch m f = RPC $ ask >>= \pr -> lift (catch (runReaderT (unRPC m) pr) (\e -> runReaderT (unRPC (f e)) pr)) + +rpcFinally :: RPC t -> RPC u -> RPC t +rpcFinally m m2 = catch m (\(ex :: SomeException) -> m2 >> throwM ex) + +data RpcFinishedException = RpcFinishedException deriving (Show, Typeable) + +instance Exception RpcFinishedException + +rpcServer :: MVar (IO ()) -> IO () +rpcServer mv = catch + (whileM_ (return True) (join (takeMVar mv))) + (\RpcFinishedException -> return ()) + +killRpcServer :: MVar (IO ()) -> IO () +killRpcServer mv2 = putMVar mv2 (throwM RpcFinishedException) +
− src/FRP/Reactivity/UI.hs
@@ -1,447 +0,0 @@-{-# LANGUAGE Trustworthy, ScopedTypeVariables, DeriveDataTypeable #-} - -module FRP.Reactivity.UI (Btn(..), MouseEv(..), Message(..), Appearance(..), WndClass, isMouse, isKey, isChange, isMove, onMouse, onKey, onMove, Window(..), hwnd, event, desktop, dim, shift, inside, intersectRect, regulate, suspendUpdate, unsuspendUpdate, create, position, texts, mousePos, module FRP.Reactivity.Basic) where - -import Data.XSizeable -import FRP.Reactivity.Combinators -import FRP.Reactivity.Basic -import FRP.Reactivity.Draw -import Data.IORef -import Data.Typeable -import Data.Monoid -import Data.Int -import Data.Bits hiding (shift) -import Data.Array.MArray -import qualified Data.Map as M -import Data.Char -import Foreign.Storable -import Foreign.Ptr -import Foreign.C.Types -import System.IO.Unsafe -import Unsafe.Coerce -import Graphics.Win32 hiding (fillRect) -import System.Win32 -import Graphics.Win32Extras -import Graphics.Subclass -import Control.Monad -import Control.Monad.Loops -import Control.Monad.Reader -import Control.Monad.State -import Control.Exception hiding (mask) -import Codec.BMP -import System.IO -import Prelude hiding (until) - -import Data.Char - -data Btn = L | R deriving (Eq, Show, Typeable) - -data MouseEv = Down | Up | Dbl | Mv deriving (Eq, Show, Typeable) - -data InternalMessage = - IChange !String !HWND - | IPush !HWND - | IFocus !HWND - | Destroy - | Tick !HWND deriving (Eq, Show, Typeable) - -data Message = - Mouse !Btn !MouseEv !POINT - | Key !Bool !VKey - | Change !String - | Push - | Move !RECT - | Close - | Focus - | Internal !InternalMessage deriving (Eq, Show, Typeable) - -data Appearance = Appearance { draw :: !(Draw ()), text :: !String, rect :: !RECT } deriving Typeable - -instance Show Appearance where - showsPrec prec appr = showParen (prec == 11) $ ("Appearance _ "++) - . showsPrec 11 (text appr) - . (' ':) - . showsPrec 11 (rect appr) - -type WndClass = String - -{-# INLINE isMouse #-} -isMouse (Mouse _ _ _) = True -isMouse _ = False - -{-# INLINE isKey #-} -isKey (Key _ _) = True -isKey _ = False - -{-# INLINE isChange #-} -isChange (Change _) = True -isChange _ = False - -{-# INLINE isMove #-} -isMove (Move _) = True -isMove _ = False - -{-# INLINE onMouse #-} -onMouse f ev = justE $ fmap (\m -> case m of Mouse b m p -> Just (f b m p); _ -> Nothing) ev - -{-# INLINE onKey #-} -onKey f ev = justE $ fmap (\m -> case m of Key b n -> Just (f b n); _ -> Nothing) ev - -{-# INLINE onMove #-} -onMove f ev = justE $ fmap (\m -> case m of Move rt -> Just (f rt); _ -> Nothing) ev - -toWPARAM :: Ptr a -> WPARAM -toWPARAM = unsafeCoerce - -toLPARAM :: Ptr a -> LPARAM -toLPARAM = unsafeCoerce - -data Window = Window { hwnd :: !HWND, event :: Event Message } -- The type of windows. - --- | A window representing the desktop. -desktop = Window nullPtr mempty - --- | Dimensions of a rectangle. -dim (x1, y1, x2, y2) = (x2 - x1, y2 - y1) - --- | Shift a rectangle. -shift (x, y) (x1, y1, x2, y2) = (x1 + x, y1 + y, x2 + x, y2 + y) - --- | Membership test for rectangles. -inside (x1, y1, x2, y2) = inRange ((x1, y1), (x2, y2)) - --- | Intersection of two rectangles. -intersectRect (x1, y1, x2, y2) (x1a, y1a, x2a, y2a) = (x1a `max` x1, y1a `max` y1, x2a `min` x2, y2a `min` y2) - -{-# INLINE regulate #-} --- | Under some circumstances, such as video playback, it can be undesirable to buffer --- up many frames and play them back. In order to avoid time leaks, the program --- can drop frames. -regulate :: Event t -> Act (Event t) -regulate e = liftM justE $ allOccs (corecA (\t1 x t -> do - t1 <- timeMeasure - if t < t1 then - return (t1, Just x, t) - else - return (t1, Nothing, t)) - 0 - e) - -{-# NOINLINE suspendedUpdateWindows #-} -suspendedUpdateWindows :: IORef (M.Map HWND ()) -suspendedUpdateWindows = unsafePerformIO (newIORef M.empty) - --- | The "built-in suspending mechanism" prevents interference between the reactive behavior --- of a window and user input to that window. --- The behavior is as follows: --- * When the user moves/drags a window, its position stops reflecting the position --- in its reactive behavior. --- * When the user enters text in a text box, its text stops reflecting the text --- of the reactive behavior. --- * When the user moves a scroll bar, its position stops reflecting that --- of the reactive behavior. --- --- 'suspendUpdate' suspends the update of a window. Unlike the built-in mechanism --- for suspending, this suspends drawing on the surface of the window as well. -suspendUpdate :: HWND -> IO () -suspendUpdate hwnd = modifyIORef' suspendedUpdateWindows (M.insert hwnd ()) - --- | Undoes any suspending of the window. This affects both 'suspendUpdate' and --- the built-in suspending mechanism. -unsuspendUpdate :: HWND -> IO () -unsuspendUpdate hwnd = modifyIORef' suspendedUpdateWindows (M.delete hwnd) - -{-# NOINLINE ref #-} -ref = unsafePerformIO $ newIORef $ Appearance (return ()) "" (0, 0, 0, 0) - -create :: Window -> WndClass -> (HWND -> Behavior Appearance) -> Act Window -create (Window parent parentEv) cls beh = do - (wnd, ev) <- liftIO $ createWnd parent cls - let ev' = return (Internal (Tick nullPtr)) <> if isFrame cls then - ev - else - ev <> routeChildEvents wnd parentEv - ev'' <- regulate (fmap (const Focus) (getEvent ticks) <> ev') - let ups = updates cls (beh wnd) ev'' - liftS nil $ fmap (\tup@((_, app), _) -> do -- Do updates - writeIORef ref app - update wnd cls tup) - ups - return (Window wnd ev') -- Return the event stream - -{-# INLINE routeChildEvents #-} -routeChildEvents wnd = fmap (\msg -> case msg of - Internal (IChange s hwnd) -> if wnd == hwnd then Change s else msg - Internal (IPush hwnd) -> if wnd == hwnd then Push else msg - Internal (IFocus hwnd) -> if wnd == hwnd then Focus else msg - _ -> Internal (Tick nullPtr)) - -read' x = if all isDigit x then read x else unsafePerformIO (print x >> return 0) - -isScrollBar cls = map toUpper cls `elem` ["SCROLLBAR", "HSCROLLBAR"] - -update wnd cls ((msg, Appearance draw text (x, y, xx, yy)), suspend) = do - mp <- readIORef suspendedUpdateWindows - unless (M.member wnd mp) (catch (do - let wid = xx - x - let ht = yy - y - -- Size the window - (x1, y1, x2, y2) <- getWindowRect wnd - unless (isMove msg) $ if isFrame cls then unless suspend $ do - (_, _, clientWd, clientHt) <- getClientRect wnd - unless (fromIntegral clientWd == wid && fromIntegral clientHt == ht) $ - setWindowPos wnd - nullPtr - (fromIntegral x1) - (fromIntegral y1) - (fromIntegral (x2 - x1 - clientWd) + fromIntegral wid) - (fromIntegral (y2 - y1 - clientHt) + fromIntegral ht) - sWP_NOZORDER - else unless (x1 == fromIntegral x && y1 == fromIntegral y && x2 == fromIntegral xx && y2 == fromIntegral yy) $ - setWindowPos wnd - nullPtr - (fromIntegral x) - (fromIntegral y) - (fromIntegral wid) - (fromIntegral ht) - sWP_NOZORDER - - -- Set the text - if isScrollBar cls then - do - let (mx, _:rest) = break (==',') text - let (page, _:pos) = break (==',') rest - old <- getScrollInfo wnd (fromIntegral sB_CTL) - let mask = sIF_RANGE .|. sIF_POS .|. if suspend then 0 else sIF_POS - let new = SCROLLINFO mask 0 (read' mx) (read' page) (read' pos) 0 - unless (old { fMask = mask } == new) $ void $ setScrollInfo wnd (fromIntegral sB_CTL) new - else do - prev <- getText wnd - when (isFrame cls || not suspend && prev /= text) $ setWindowText wnd text - - -- Repaint the window - invalidateRect (Just wnd) Nothing True - updateWindow wnd) - (\(_ :: IOError) -> return ())) - --- | The rectangle of a window from its message stream. -{-# INLINE position #-} -position ev = corec (\rt msg t -> let rt' = case msg of Move rt -> rt; _ -> rt in - (rt', rt', t)) (0, 0, 0, 0) ev - -{-# INLINE _texts #-} -_texts ev = corec (\s pr@(msg, _) t -> let s' = case msg of Change s -> s; _ -> s in - (s', (pr, s'), t)) "" ev - --- | The text of a window from its message stream. -{-# INLINE texts #-} -texts ev = fmap snd $ _texts $ fmap (\msg -> (msg, Appearance (return ()) "" (0, 0, 1, 1))) ev - --- | The position of the mouse. -{-# INLINE mousePos #-} -mousePos ev = corec (\pt msg t -> let pt' = case msg of Mouse _ Mv pt -> pt; _ -> pt in - (pt', pt', t)) (0, 0) ev - --- Rules out Change messages caused by behavior updates. -{-# INLINE behFree #-} -behFree ev = corec (\((prevMsg, _), b) (pr@(_, app), txt) t -> let pr' = (pr, text app == txt && (isChange prevMsg || b)) in - (pr', pr', t)) - ((Focus, undefined), True) - $ _texts ev - -{-# INLINE userChange #-} -userChange cls ev = if isFrame cls then - filterE (\(msg, _) -> isMove msg) ev - else - fmap fst $ filterE (\((msg, _), b) -> isChange msg && b) (behFree ev) - -{-# INLINE suspend #-} -suspend cls ev = flipFlop (userChange cls ev) mempty - --- Sample a behavior. This also takes care of suspending behaviors. -{-# INLINE updates #-} -updates :: WndClass -> Behavior Appearance -> Event Message -> Event ((Message, Appearance), Bool) -updates cls beh ev = snapshot samp (suspend cls samp) where - ev' = ev `untilE` filterE (\m -> case m of Internal Destroy -> True; _ -> False) ev -- The event stream should not deliver messages after Destroy is delivered. - samp = snapshot ev' beh - -getText wnd = catch (getWindowText wnd) (\(_ :: IOError) -> return "") - -drawButton wnd hdc app wid ht p bkclr clr = do - hilite <- getSysColor cOLOR_BTNHIGHLIGHT - shadow <- getSysColor cOLOR_BTNSHADOW - grayed <- getSysColor cOLOR_GRAYTEXT - state <- peekByteOff p 16 - let (upperLeft, lowerRight, pushDown) = if state .&. oDS_SELECTED == 0 then (shadow, hilite, 0) else (hilite, shadow, 2) - -- let (txtX, txtY) = extent txt - -- let left = (wid - (drawX + 4 + txtX)) `div` 2 + pushDown - let margin = 4 - let font = (defBackground, 0, "Tahoma", 16, 0, False, False) - runStateT (runReaderT (unDraw (do - fillRect upperLeft (0, 0, wid, 1) - fillRect upperLeft (0, 0, 1, ht - 1) - fillRect lowerRight (wid - 1, 1, wid, ht) - fillRect lowerRight (0, ht - 1, wid, ht) - fillRect bkclr (1, 1, wid - 1, ht - 1) - mask 1 (1, 1) (fst $ onNewBitmap (wid - 2, ht - 2) (draw app)) - FRP.Reactivity.Draw.textOut (text app) (margin + 32 + pushDown, margin - pushDown) font)) - ((wid, ht), p, Nothing)) - (0, 0) - drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) 0 0 p - -- let txt = Text (0, 0) (snd $ isEnabled $ text wnd) 12 "Tahoma" bkclr (if state .&. oDS_DISABLED /= 0 then grayed else clr) - {-when (state .&. oDS_FOCUS /= 0) $ do - drawFocusRect dc (2, 2, wid - 2, ht - 2) - return ()-} - -createWnd parent cls = do - -- Make event fed by the window - Stream sink _ ev <- chanSource defaultFrame - bmp :: SA Int32 CChar <- newArray_ (0, -1) - let handler proc wnd msg wParam lParam = do - may <- mapMessage (if isFrame cls then nullPtr else parent) wnd msg wParam lParam - - maybe - (catch - (do - app <- readIORef ref - (_, _, wid, ht) <- getClientRect wnd - let sz = 4 * wid * ht - resize (0, sz - 1) bmp - (_, p) <- getPtr bmp - runStateT (runReaderT (unDraw (fillRect defBackground (0, 0, wid, ht) >> draw app)) ((wid, ht), p, Nothing)) (0, 0) - if msg == wM_PAINT && isFrame cls then - allocaPAINTSTRUCT $ \ps -> do - hdc <- beginPaint wnd ps - drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) 0 0 p - endPaint wnd ps - else if msg == wM_DRAWITEM then do - let drawStruct = unsafeCoerce lParam - (ctltype, wnd, hdc) <- catch (liftM3 (,,) (peekByteOff drawStruct 0) (peekByteOff drawStruct 20) (peekByteOff drawStruct 24)) (\(_ :: IOException) -> return (0, nullPtr, nullPtr)) - (_, _, wid, ht) <- getClientRect wnd - if ctltype == oDT_BUTTON then - void $ drawButton wnd hdc app wid ht p (rgb 255 255 255) 0 - else void $ do - drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) 0 0 p - drawText hdc (text app) (0, 0, wid, ht) (dT_VCENTER .|. dT_SINGLELINE) - else when (msg `elem` [wM_CTLCOLORSTATIC, wM_CTLCOLORBTN]) $ void $ setBkMode (unsafeCoerce wParam) tRANSPARENT) - (\(ex :: SomeException) -> hPutStrLn stderr $ "Reactivity.run: warning: drawing failed with " ++ show ex)) - (\x -> do - print x - sink x - case x of - Mouse _ Up pt -> when (map toUpper cls == "BUTTON") $ do - rt <- getClientRect wnd - when (inside rt pt) (sink Push) - _ -> return ()) - may - - -- Take care of mouse capture - if msg `elem` [wM_LBUTTONDOWN, wM_RBUTTONDOWN] then - void $ setCapture wnd - else when (msg `elem` [wM_LBUTTONUP, wM_RBUTTONUP]) $ void releaseCapture - - -- An application can't be expected to respond to WM_ENDSESSION immediately, - -- therefore it holes up in an event loop here, waiting for approval - -- from the app to close. - when (msg == wM_ENDSESSION) $ allocaMessage $ \msg -> - untilM_ - (return ()) - (do - getMessage msg Nothing - translateMessage msg - dispatchMessage msg - hwnd <- peekByteOff msg 0 - msgN <- peekByteOff msg 4 - return $ hwnd == wnd && msgN == wM_DESTROY) - - if msg == wM_CLOSE || msg == wM_DRAWITEM then - return 0 - else - proc wnd msg wParam lParam - - -- Create the window - hdl <- getModuleHandle Nothing - let name = mkClassName (if isScrollBar cls then "SCROLLBAR" else cls) - wnd <- createWindow name "" (wS_CLIPCHILDREN .|. wS_VISIBLE .|. case map toUpper cls of - "FRAME" -> wS_OVERLAPPEDWINDOW - "STATIC" -> wS_CHILDWINDOW .|. sS_OWNERDRAW - "BUTTON" -> wS_CHILDWINDOW .|. bS_OWNERDRAW - "EDIT" -> wS_CHILDWINDOW .|. eS_AUTOHSCROLL - "SCROLLBAR" -> wS_CHILDWINDOW .|. sBS_VERT - "HSCROLLBAR" -> wS_CHILDWINDOW .|. sBS_HORZ - _ -> wS_CHILDWINDOW) (Just 0) (Just 0) (Just 0) (Just 0) (Just parent) Nothing hdl (handler (defWindowProc . Just)) - updateWindow wnd - - if isFrame cls then void $ sendMessage wnd wM_ACTIVATE 0 0 - else void $ do - -- Set the font - font <- createFont 16 0 0 0 fW_NORMAL False False False dEFAULT_CHARSET 0 0 dEFAULT_QUALITY fF_DONTCARE "Tahoma" - sendMessage wnd wM_SETFONT (toWPARAM font) 0 - - subclassProc wnd handler - - -- Send a create message to the parent on this control's behalf - postMessage parent wM_APP (toWPARAM wnd) 0 - - return (wnd, ev) - -isFrame cls = cls == "Frame" - -mapMessage parent hwnd msg wParam lParam = if msg `elem` [wM_LBUTTONUP, wM_LBUTTONDOWN, wM_RBUTTONUP, wM_RBUTTONDOWN, wM_LBUTTONDBLCLK, wM_RBUTTONDBLCLK, wM_MOUSEMOVE] then - return $ Just $ Mouse - (if msg `elem` [wM_LBUTTONDOWN, wM_LBUTTONUP, wM_LBUTTONDBLCLK] then L else R) - (if msg `elem` [wM_LBUTTONDOWN, wM_RBUTTONDOWN] then - Down - else if msg `elem` [wM_LBUTTONDBLCLK, wM_RBUTTONDBLCLK] then - Dbl - else if msg == wM_MOUSEMOVE then - Mv - else - Up) - (fromIntegral (fromIntegral (loWord lParam) :: Int16) :: Int32, hiWord lParam) - else if msg `elem` [wM_KEYDOWN, wM_KEYUP] then - return $ Just $ Key (msg == wM_KEYDOWN) wParam - else if msg == wM_COMMAND && hiWord wParam `elem` [eN_UPDATE, cBN_EDITUPDATE, cBN_SELENDOK] then - liftM (\s -> Just $ Internal $ IChange s (unsafeCoerce lParam)) $ getText $ unsafeCoerce lParam - else if msg == wM_COMMAND && hiWord wParam == bN_CLICKED then - return $ Just $ Internal $ IPush (unsafeCoerce lParam) - else if msg `elem` [wM_HSCROLL, wM_VSCROLL] then do - si <- getScrollInfo (unsafeCoerce lParam) (fromIntegral sB_CTL) - let newY = if loWord wParam == sB_LINEDOWN then - nPos si + 50 - else if loWord wParam == sB_LINEUP then - nPos si - 50 - else if loWord wParam == sB_PAGEDOWN then - nPos si + fromIntegral (nPage si) - else if loWord wParam == sB_PAGEUP then - nPos si - fromIntegral (nPage si) - else if loWord wParam == sB_THUMBTRACK then - maxBound - else if loWord wParam == sB_THUMBPOSITION then - nTrackPos si - else - nPos si - if newY == maxBound then - return Nothing - else do - setScrollInfo (unsafeCoerce lParam) (fromIntegral sB_CTL) (si { nPos = newY }) - return $ Just $ Internal $ IChange (show $ max 0 (min newY (nMax si - fromIntegral (nPage si)))) (unsafeCoerce lParam) - else if msg == wM_WINDOWPOSCHANGED then do - liftM (Just . Move) $ if parent == nullPtr then - getClientRect hwnd - else do - rt <- getWindowRect hwnd - (cx, cy) <- clientToScreen parent (0, 0) - return (shift (-cx, -cy) rt) - else if msg == wM_ACTIVATE && wParam == 1 then - return $ Just Focus - else if msg == wM_SETFOCUS then - return $ Just $ Internal $ IFocus (unsafeCoerce wParam) - else if msg == wM_APP then - return $ Just $ Internal $ Tick (unsafeCoerce wParam) - else if msg `elem` [wM_CLOSE, wM_ENDSESSION] then - return $ Just Close - else if msg == wM_DESTROY then - return $ Just $ Internal Destroy - else - return Nothing
− src/Graphics/Subclass.hs
@@ -1,28 +0,0 @@-module Graphics.Subclass (subclassProc) where - -import Unsafe.Coerce -import Data.IORef -import Foreign.Ptr -import Control.Monad -import Graphics.Win32 -import Graphics.Win32Extras - --- | This function subclasses a window and takes care of freeing --- the function pointer when the window closes. The parameter function --- is passed a function that invokes the default behaviour of the --- window. -subclassProc :: HWND -> (WindowClosure -> WindowClosure) -> IO () -subclassProc wnd proc = do - procVar <- newIORef Nothing - let closure wnd msg wParam lParam = do - may <- readIORef procVar - case may of - Just (funPtr, oldProc) -> do - when (msg == wM_NCDESTROY) $ do - c_SetWindowLongPtr wnd gWLP_WNDPROC oldProc - freeHaskellFunPtr funPtr - proc (callWindowProc (unsafeCoerce oldProc)) wnd msg wParam lParam - Nothing -> proc (\_ _ _ _ -> return 0) wnd msg wParam lParam - funPtr <- mkWindowClosure closure - oldProc <- c_SetWindowLongPtr wnd gWLP_WNDPROC (unsafeCoerce funPtr) - writeIORef procVar (Just (funPtr, oldProc))
− src/Graphics/Win32Extras.hs
@@ -1,818 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-} -module Graphics.Win32Extras where - -import Graphics.Win32 -import System.Win32.DLL -import Data.Int -import Data.Word -import Data.Bits -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Alloc -import Foreign.C.Types -import Data.IORef -import System.IO.Unsafe -import Control.Monad -import Control.Monad.Loops -import Codec.BMP - -foreign import stdcall "windows.h GetWindowTextW" c_GetWindowText :: HWND -> LPTSTR -> Int32 -> IO LRESULT - --- | A wrapper for 'c_GetWindowText' which fails if the string is too long. -getWindowText wnd = do - fp <- mallocForeignPtrBytes 1024 - withForeignPtr fp $ \p -> do - pokeByteOff p 1021 '\0' - failIfZero "GetWindowText" $ c_GetWindowText wnd p 1024 - ch :: Word8 <- peekByteOff p 1021 - failIf_ id "GetWindowText" $ return $ ch /= 0 -- Test if string was truncated - peekTString p - -foreign import stdcall "windows.h GetClassNameW" c_GetClassName :: HWND -> LPTSTR -> Int32 -> IO LRESULT - -getClassName wnd = do - fp <- mallocForeignPtrBytes 1024 - withForeignPtr fp $ \p -> do - pokeByteOff p 1021 '\0' - failIfZero "GetClassName" $ c_GetClassName wnd p 1024 - ch :: Word8 <- peekByteOff p 1021 - failIf_ id "GetClassName" $ return $ ch /= 0 -- Test if string was truncated - peekTString p - -foreign import stdcall "windows.h SetFocus" setFocus :: HWND -> IO HWND - ------------------------------- --- Drawing - -foreign import stdcall unsafe "windows.h SetPixel" set :: HDC -> Int32 -> Int32 -> COLORREF -> IO COLORREF - -dT_TOP :: Word32 -dT_TOP = 0 - -dT_LEFT :: Word32 -dT_LEFT = 0 - -dT_CENTER :: Word32 -dT_CENTER = 1 - -dT_RIGHT :: Word32 -dT_RIGHT = 2 - -dT_VCENTER :: Word32 -dT_VCENTER = 4 - -dT_BOTTOM :: Word32 -dT_BOTTOM = 8 - -dT_WORDBREAK :: Word32 -dT_WORDBREAK = 16 - -dT_SINGLELINE :: Word32 -dT_SINGLELINE = 32 - -dT_EXPANDTABS :: Word32 -dT_EXPANDTABS = 64 - -dT_TABSTOP :: Word32 -dT_TABSTOP = 128 - -dT_NOCLIP :: Word32 -dT_NOCLIP = 256 - -dT_EXTERNALLEADING :: Word32 -dT_EXTERNALLEADING = 512 - -dT_CALCRECT :: Word32 -dT_CALCRECT = 1024 - -dT_NOPREFIX :: Word32 -dT_NOPREFIX = 2048 - -dT_INTERNAL :: Word32 -dT_INTERNAL = 4096 - -dT_EDITCONTROL :: Word32 -dT_EDITCONTROL = 8192 - -dT_PATH_ELLIPSIS :: Word32 -dT_PATH_ELLIPSIS = 16384 - -dT_END_ELLIPSIS :: Word32 -dT_END_ELLIPSIS = 32768 - -dT_MODIFYSTRING :: Word32 -dT_MODIFYSTRING = 65536 - -dT_RTLREADING :: Word32 -dT_RTLREADING = 131072 - -dT_WORD_ELLIPSIS :: Word32 -dT_WORD_ELLIPSIS = 262144 - -dT_NOFULLWIDTHCHARBREAK :: Word32 -dT_NOFULLWIDTHCHARBREAK = 524288 - -dT_HIDEPREFIX :: Word32 -dT_HIDEPREFIX = 1048576 - -dT_PREFIXONLY :: Word32 -dT_PREFIXONLY = 2097152 - -foreign import stdcall "windows.h DrawTextW" c_DrawText :: HDC -> LPTSTR -> Int32 -> LPRECT -> UINT -> IO Int32 - -drawText dc s rt format = withTString s $ \ps -> - withRECT rt $ \pr -> - failIfZero "DrawText" $ c_DrawText dc ps (-1) pr format - -foreign import stdcall "windows.h SetDIBitsToDevice" - c_SetDIBitsToDevice :: HDC -> Int32 -> Int32 -> Word32 -> Word32 -> Int32 -> Int32 -> Word32 -> Word32 -> Ptr CChar -> LPBITMAPINFO -> Word32 -> IO Int32 - -withBITMAP :: BitmapInfo -> (Ptr () -> IO a) -> IO a -withBITMAP (InfoV3 bi) f = do - fp <- mallocForeignPtrBytes 40 - withForeignPtr fp $ \p -> do - pokeByteOff p 0 (dib3Size bi) - pokeByteOff p 4 (dib3Width bi) - pokeByteOff p 8 (dib3Height bi) - pokeByteOff p 12 (dib3Planes bi) - pokeByteOff p 14 (dib3BitCount bi) - pokeByteOff p 16 bI_RGB - pokeByteOff p 20 (dib3ImageSize bi) - pokeByteOff p 24 (dib3PelsPerMeterX bi) - pokeByteOff p 28 (dib3PelsPerMeterY bi) - pokeByteOff p 32 (dib3ColorsUsed bi) - pokeByteOff p 36 (dib3ColorsImportant bi) - f p - -type XFORM = Ptr () - -foreign import stdcall "windows.h SetWorldTransform" setWorldTransform :: HDC -> XFORM -> IO Bool - -withXFORM :: (Float, Float, Float, Float, Float, Float) -> (XFORM -> IO t) -> IO t -withXFORM (eM11, eM12, eM21, eM22, eDx, eDy) f = do - fp <- mallocForeignPtrBytes 24 - withForeignPtr fp $ \p -> do - pokeByteOff p 0 eM11 - pokeByteOff p 4 eM12 - pokeByteOff p 8 eM21 - pokeByteOff p 12 eM22 - pokeByteOff p 16 eDx - pokeByteOff p 20 eDy - f p - -oDT_BUTTON :: Word32 -oDT_BUTTON = 4 - -oDA_DRAWENTIRE :: Word32 -oDA_DRAWENTIRE = 1 - -oDA_SELECT :: Word32 -oDA_SELECT = 2 - -oDA_FOCUS :: Word32 -oDA_FOCUS = 4 - -oDS_SELECTED :: Word32 -oDS_SELECTED = 1 - -oDS_DISABLED :: Word32 -oDS_DISABLED = 4 - -oDS_FOCUS :: Word32 -oDS_FOCUS = 16 - -foreign import stdcall "windows.h DrawFocusRect" c_DrawFocusRect :: HDC -> LPRECT -> IO Bool - -drawFocusRect dc rt = withRECT rt $ c_DrawFocusRect dc - -foreign import stdcall "windows.h SetWindowPos" c_SetWindowPos :: HWND -> HWND -> LONG -> LONG -> LONG -> LONG -> Word32 -> IO Bool - -setWindowPos hwnd hwndAfter x y wd ht flags = failIfFalse_ "SetWindowPos" $ c_SetWindowPos hwnd hwndAfter x y wd ht flags - -foreign import stdcall "windows.h SetWindowLongW" setWindowLong :: HWND -> LONG -> LONG -> IO LONG - ------------------------------- --- Scroll bars - -foreign import stdcall "windows.h SetScrollInfo" c_SetScrollInfo :: HWND -> Int32 -> Ptr SCROLLINFO -> BOOL -> IO BOOL - -foreign import stdcall "windows.h GetScrollInfo" c_GetScrollInfo :: HWND -> Int32 -> Ptr SCROLLINFO -> IO Int32 - -setScrollInfo wnd bar si = withSCROLLINFO si $ \p -> c_SetScrollInfo wnd bar p True - -getScrollInfo wnd bar = withSCROLLINFO (SCROLLINFO sIF_ALL 0 0 0 0 0) $ \p -> do - c_GetScrollInfo wnd bar p - readSCROLLINFO p - -data SCROLLINFO = SCROLLINFO { fMask :: Word32, nMin :: Int32, nMax :: Int32, nPage :: Word32, nPos :: Int32, nTrackPos :: Int32 } deriving (Eq, Show) - -withSCROLLINFO :: SCROLLINFO -> (Ptr SCROLLINFO -> IO t) -> IO t -withSCROLLINFO si f = do - fp <- mallocForeignPtrBytes 28 - withForeignPtr fp $ \p -> do - pokeByteOff p 0 (28 :: Word32) - pokeByteOff p 4 (fMask si) - pokeByteOff p 8 (nMin si) - pokeByteOff p 12 (nMax si) - pokeByteOff p 16 (nPage si) - pokeByteOff p 20 (nPos si) - pokeByteOff p 24 (nTrackPos si) - f p - -readSCROLLINFO :: Ptr SCROLLINFO -> IO SCROLLINFO -readSCROLLINFO p = do - fMask <- peekByteOff p 4 - nMin <- peekByteOff p 8 - nMax <- peekByteOff p 12 - nPage <- peekByteOff p 16 - nPos <- peekByteOff p 20 - nTrackPos <- peekByteOff p 24 - return (SCROLLINFO fMask nMin nMax nPage nPos nTrackPos) - -sB_HORZ :: Int32 -sB_HORZ = 0 - -sB_VERT :: Int32 -sB_VERT = 1 - -sB_CTL :: Word32 -sB_CTL = 2 - -sIF_ALL :: Word32 -sIF_ALL = 31 - -sB_PAGEDOWN :: Word32 -sB_PAGEDOWN = 3 - -sB_PAGEUP :: Word32 -sB_PAGEUP = 2 - -sB_LINEUP :: Word32 -sB_LINEUP = 0 - -sB_LINEDOWN :: Word32 -sB_LINEDOWN = 1 - -sB_BOTTOM :: Word32 -sB_BOTTOM = 7 - -sB_TOP :: Word32 -sB_TOP = 6 - -sB_THUMBPOSITION :: Word32 -sB_THUMBPOSITION = 4 - -sB_THUMBTRACK :: Word32 -sB_THUMBTRACK = 5 - -loWord x = x .&. 65535 - -hiWord x = shiftR x 16 - -foreign import stdcall "windows.h CallWindowProcW" callWindowProc :: FunPtr WindowClosure -> HWND -> UINT -> WPARAM -> LPARAM -> IO LRESULT - -gWLP_WNDPROC :: Int32 -gWLP_WNDPROC = -4 - -gWLP_WNDPARENT :: Int32 -gWLP_WNDPARENT = -8 - -gWLP_ID :: Int32 -gWLP_ID = -12 - -gWLP_USERDATA :: Int32 -gWLP_USERDATA = -21 - -gWLP_STYLE :: Int32 -gWLP_STYLE = -16 - -cB_ADDSTRING :: Word32 -cB_ADDSTRING = 323 - -cB_GETCURSEL :: Word32 -cB_GETCURSEL = 327 - -cB_SETCURSEL :: Word32 -cB_SETCURSEL = 334 - --- ... - -sIF_RANGE :: Word32 -sIF_RANGE = 1 - -sIF_POS :: Word32 -sIF_POS = 2 - -sIF_PAGE :: Word32 -sIF_PAGE = 4 - --------------------------------- --- System colors - -foreign import stdcall "windows.h GetSysColorBrush" getSysColorBrush :: Word32 -> IO HBRUSH - -foreign import stdcall "windows.h GetSysColor" getSysColor :: Word32 -> IO Word32 - -foreign import stdcall "windows.h GetDeviceCaps" getDeviceCaps :: HDC -> Int32 -> IO Int32 - -lOGPIXELSX :: Int32 -lOGPIXELSX = 88 - -lOGPIXELSY :: Int32 -lOGPIXELSY = 90 - -dLGC_WANTCHARS :: Int32 -dLGC_WANTCHARS = 128 - -dLGC_WANTARROWS :: Int32 -dLGC_WANTARROWS = 1 - -dLGC_DEFPUSHBUTTON :: Int32 -dLGC_DEFPUSHBUTTON = 16 - -wM_CTLCOLORBTN :: Word32 -wM_CTLCOLORBTN = 309 - -wM_CTLCOLORSTATIC :: Word32 -wM_CTLCOLORSTATIC = 312 - ------------------------------- --- Threads - -foreign import stdcall "windows.h GetCurrentThreadId" getCurrentThreadId :: IO DWORD - -foreign import stdcall "windows.h PostThreadMessageW" postThreadMessage :: DWORD -> UINT -> WPARAM -> LPARAM -> IO Bool - -foreign import stdcall "windows.h MsgWaitForMultipleObjects" c_MsgWaitForMultipleObjects :: DWORD -> Ptr HANDLE -> Bool -> DWORD -> DWORD -> IO DWORD - -msgWaitForMultipleObjects :: [HANDLE] -> Bool -> DWORD -> DWORD -> IO DWORD -msgWaitForMultipleObjects handles b n1 n2 = do - fp <- mallocForeignPtrBytes (4 * length handles) - withForeignPtr fp $ \p -> do - mapM_ (\(n, hdl) -> pokeByteOff p n hdl) (zip [0,4..] handles) - c_MsgWaitForMultipleObjects (fromIntegral $ length handles) p b n1 n2 - -wAIT_TIMEOUT :: DWORD -wAIT_TIMEOUT = 258 - -pM_NOREMOVE :: DWORD -pM_NOREMOVE = 0 - -pM_REMOVE :: DWORD -pM_REMOVE = 1 - -pM_NOYIELD :: DWORD -pM_NOYIELD = 2 - -qS_ALLEVENTS :: DWORD -qS_ALLEVENTS = 1215 - ------------------------------- --- Common dialog boxes - -foreign import stdcall "windows.h ChooseColorW" c_ChooseColor :: Ptr () -> IO Bool - -cC_ANYCOLOR :: Word32 -cC_ANYCOLOR = 256 - -cC_FULLOPEN :: Word32 -cC_FULLOPEN = 2 - -cC_PREVENTFULLOPEN :: Word32 -cC_PREVENTFULLOPEN = 4 - -cC_RGBINIT :: Word32 -cC_RGBINIT = 1 - -cC_SHOWHELP :: Word32 -cC_SHOWHELP = 8 - -cC_SOLIDCOLOR :: Word32 -cC_SOLIDCOLOR = 128 - -type CHOOSECOLOR = () - -foreign import ccall "wrapper" mkFinalizer :: (Ptr a -> IO ()) -> IO (FinalizerPtr a) - -allocaChooseColor :: Word32 -> Word32 -> IO (ForeignPtr CHOOSECOLOR) -allocaChooseColor clr flags = do - hdl <- getModuleHandle Nothing - cc <- mallocForeignPtrBytes 36 - p2 <- mallocBytes 64 - withForeignPtr cc $ \p -> do - pokeByteOff p 0 (36 :: Word32) - pokeByteOff p 4 (0 :: Word32) - pokeByteOff p 8 hdl - pokeByteOff p 12 clr - pokeByteOff p 16 p2 - pokeByteOff p 20 flags - pokeByteOff p 24 (0 :: Word32) - pokeByteOff p 28 (0 :: Word32) - pokeByteOff p 32 (0 :: Word32) - fin <- mkFinalizer (\_ -> free p2) - addForeignPtrFinalizer fin cc - return cc - --- | Open a choose colour dialog. Use 'allocaChooseColor' to create the parameter structure. -chooseColor :: HWND -> ForeignPtr CHOOSECOLOR -> IO (Maybe COLORREF) -chooseColor wnd fp = do - withForeignPtr fp $ \p -> do - b <- c_ChooseColor p - if b then do - clr <- peekByteOff p 12 - return (Just clr) - else - return Nothing - -type OPENFILENAME = () - -foreign import stdcall "windows.h GetOpenFileNameW" getOpenFileName :: Ptr OPENFILENAME -> IO Bool - -foreign import stdcall "windows.h GetSaveFileNameW" getSaveFileName :: Ptr OPENFILENAME -> IO Bool - -oFN_ALLOWMULTISELECT :: Word32 -oFN_ALLOWMULTISELECT = 512 - -oFN_CREATEPROMPT :: Word32 -oFN_CREATEPROMPT = 8192 - -oFN_DONTADDTORECENT :: Word32 -oFN_DONTADDTORECENT = 33554432 - -oFN_EXPLORER :: Word32 -oFN_EXPLORER = 524288 - -oFN_FILEMUSTEXIST :: Word32 -oFN_FILEMUSTEXIST = 4096 - -oFN_HIDEREADONLY :: Word32 -oFN_HIDEREADONLY = 4 - -oFN_OVERWRITEPROMPT :: Word32 -oFN_OVERWRITEPROMPT = 2 ---etc.. - -data Action = Open | Save deriving Eq - --- | Open or save a file. -fileOpenOrSave :: Action -> HWND -> String -> String -> IO (Maybe String) -fileOpenOrSave action wnd filter extension = do - hdl <- getModuleHandle Nothing - fp <- mallocForeignPtrBytes 76 - fp2 <- mallocForeignPtrBytes 1000 - withForeignPtr fp $ \p -> - withForeignPtr fp2 $ \p2 -> - withTString filter $ \flt -> - withTString extension $ \ext -> do - pokeByteOff p2 0 (0 :: Word16) - pokeByteOff p 0 (76 :: Word32) - pokeByteOff p 4 wnd - pokeByteOff p 8 hdl - pokeByteOff p 12 flt - pokeByteOff p 16 nullPtr - pokeByteOff p 24 (1 :: Word32) - pokeByteOff p 28 p2 - pokeByteOff p 32 (1000 :: Word32) - pokeByteOff p 36 nullPtr - pokeByteOff p 44 nullPtr - pokeByteOff p 48 nullPtr - pokeByteOff p 52 (oFN_EXPLORER .|. if action == Open then oFN_FILEMUSTEXIST else oFN_OVERWRITEPROMPT) - pokeByteOff p 60 ext - b <- (if action == Open then getOpenFileName else getSaveFileName) p - if b then do - liftM Just (peekTString p2) - else - return Nothing - -fileOpen = fileOpenOrSave Open - -fileSave = fileOpenOrSave Save - --- | Display a message box. This fixes the Win32 package MessageBox. -messageBox' :: HWND -> String -> String -> MBStyle -> IO MBStatus -messageBox' wnd text caption style = - withTString text $ \ c_text -> - withTString caption $ \ c_caption -> - failIfZero "MessageBox" $ c_MessageBox' wnd c_text c_caption style -foreign import stdcall safe "windows.h MessageBoxW" - c_MessageBox' :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus - ------------------------------- --- Printing - -foreign import stdcall "windows.h GlobalUnlock" globalUnlock' :: HANDLE -> IO Bool - -foreign import stdcall "windows.h OpenPrinterW" openPrinter :: LPTSTR -> Ptr HANDLE -> Ptr () -> IO Bool - -foreign import stdcall "windows.h DocumentPropertiesW" documentProperties :: HWND -> HANDLE -> LPTSTR -> Ptr () -> Ptr () -> Word32 -> IO LONG - -foreign import stdcall "windows.h CreateDCW" createDC :: LPCTSTR -> LPCTSTR -> LPCSTR -> Ptr () -> IO HDC - -foreign import stdcall "windows.h StartDocW" startDoc :: HDC -> Ptr () -> IO Int32 - -foreign import stdcall "windows.h EndDoc" endDoc :: HDC -> IO Int32 - -foreign import stdcall "windows.h StartPage" startPage :: HDC -> IO Int32 - -foreign import stdcall "windows.h EndPage" endPage :: HDC -> IO Int32 - -foreign import stdcall "windows.h ClosePrinter" closePrinter :: HANDLE -> IO Bool - -foreign import stdcall "windows.h GetDefaultPrinterW" getDefaultPrinter :: LPTSTR -> Ptr DWORD -> IO Bool - -dM_OUT_BUFFER :: Word32 -dM_OUT_BUFFER = 2 - -dM_IN_PROMPT :: Word32 -dM_IN_PROMPT = 4 --- etc.. - -foreign import stdcall "windows.h PostMessageW" postMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO Bool - -eN_GETSEL :: Word32 -eN_GETSEL = 176 - -eN_SETSEL :: Word32 -eN_SETSEL = 177 - -eN_UPDATE :: Word32 -eN_UPDATE = 1024 - -cBN_EDITUPDATE :: Word32 -cBN_EDITUPDATE = 6 - -cBN_SELENDOK :: Word32 -cBN_SELENDOK = 9 - -lBN_SELCHANGE :: Word32 -lBN_SELCHANGE = 1 - -bN_PUSHED :: Word32 -bN_PUSHED = 2 - -bN_CLICKED :: Word32 -bN_CLICKED = 0 - -hTBOTTOM :: Word32 -hTBOTTOM = 15 - -hTBOTTOMLEFT :: Word32 -hTBOTTOMLEFT = 16 - -hTBOTTOMRIGHT :: Word32 -hTBOTTOMRIGHT = 17 - -hTCAPTION :: Word32 -hTCAPTION = 2 - -hTLEFT :: Word32 -hTLEFT = 10 - -hTRIGHT :: Word32 -hTRIGHT = 11 - -hTTOP :: Word32 -hTTOP = 12 - -hTTOPLEFT :: Word32 -hTTOPLEFT = 13 - -hTTOPRIGHT :: Word32 -hTTOPRIGHT = 14 - -hTCLOSE :: Word32 -hTCLOSE = 20 - -hTMAXBUTTON :: Word32 -hTMAXBUTTON = 9 - -hTMINBUTTON :: Word32 -hTMINBUTTON = 8 - -foreign import stdcall "windows.h SetCapture" setCapture :: HWND -> IO HWND - -foreign import stdcall "windows.h ReleaseCapture" releaseCapture :: IO Bool - -sS_OWNERDRAW :: Word32 -sS_OWNERDRAW = 13 - -foreign import stdcall "windows.h EnableWindow" - enableWindow' :: HWND -> Bool -> IO Bool - ------------------------------- --- Menus - --- | Fixes TrackPopupMenu to supply the selection as a return value. -foreign import stdcall "windows.h TrackPopupMenu" trackPopupMenu' :: HMENU -> UINT -> LONG -> LONG -> LONG -> HWND -> Ptr RECT -> IO LONG - ------------------------------- --- Common controls - -wC_LISTVIEW = "SysListView32" - -lVS_REPORT :: Word32 -lVS_REPORT = 1 - -lVS_SINGLESEL :: Word32 -lVS_SINGLESEL = 4 - -wC_TREEVIEW = "SysTreeView32" - -lVM_FIRST :: Word32 -lVM_FIRST = 4096 - -lVM_GETITEMCOUNT = lVM_FIRST + 4 - -lVM_DELETEITEM = lVM_FIRST + 8 - -lVM_INSERTITEM = lVM_FIRST + 77 - -lVM_GETITEMSTATE = lVM_FIRST + 44 - -lVM_GETITEMTEXT = lVM_FIRST + 45 - -lVM_SETITEMTEXT = lVM_FIRST + 116 - -lVM_GETCOLUMN = lVM_FIRST + 95 - -lVM_DELETECOLUMN = lVM_FIRST + 28 - -lVM_INSERTCOLUMN = lVM_FIRST + 97 - -lVM_SETCOLUMN = lVM_FIRST + 26 - -lVIF_STATE :: Word32 -lVIF_STATE = 8 - -lVIF_TEXT :: Word32 -lVIF_TEXT = 1 - -lVCF_TEXT :: Word32 -lVCF_TEXT = 4 - -lVCF_WIDTH :: Word32 -lVCF_WIDTH = 2 - -lVIS_SELECTED :: Word32 -lVIS_SELECTED = 2 - -tVM_FIRST :: Word32 -tVM_FIRST = 4352 - -tVM_INSERTITEM = tVM_FIRST + 50 - -tVM_DELETEITEM = tVM_FIRST + 1 - -tVM_GETNEXTITEM = tVM_FIRST + 10 - -tVM_GETITEM = tVM_FIRST + 62 - -tVM_SETITEM = tVM_FIRST + 63 - -tVGN_NEXT :: Word32 -tVGN_NEXT = 1 - -tVGN_CHILD :: Word32 -tVGN_CHILD = 4 - -tVIF_TEXT :: Word32 -tVIF_TEXT = 1 - -tVIF_HANDLE :: Word32 -tVIF_HANDLE = 16 - -tVS_HASLINES :: Word32 -tVS_HASLINES = 2 - -foreign import stdcall "windows.h InitCommonControls" initCommonControls :: IO () - -foreign import stdcall "windows.h TranslateAccelerator" translateAccelerator :: HGLOBAL -> HWND -> LPMSG -> IO Bool - -foreign import stdcall "windows.h GetWindowLongW" c_GetWindowLong :: HWND -> LONG -> IO LONG - -type LPCTBBUTTON = Ptr () - -tb_addbuttons_size :: UINT -tb_addbuttons_size = 20 - -tB_ADDBITMAP :: UINT -tB_ADDBITMAP = wM_USER + 19 - -tB_ADDBUTTONSA :: UINT -tB_ADDBUTTONSA = wM_USER + 20 - -tB_INSERTBUTTONA :: UINT -tB_INSERTBUTTONA = wM_USER + 21 - -tB_DELETEBUTTON :: UINT -tB_DELETEBUTTON = wM_USER + 22 - -tB_REPLACEBITMAP :: UINT -tB_REPLACEBITMAP = wM_USER + 46 - -tB_BUTTONSTRUCTSIZE :: UINT -tB_BUTTONSTRUCTSIZE = wM_USER + 30 - -tB_SETBUTTONSIZE :: UINT -tB_SETBUTTONSIZE = wM_USER + 31 - -tB_SETBITMAPSIZE :: UINT -tB_SETBITMAPSIZE = wM_USER + 32 - -tB_AUTOSIZE :: UINT -tB_AUTOSIZE = wM_USER + 33 - -tB_BUTTONCOUNT :: UINT -tB_BUTTONCOUNT = wM_USER + 24 - -tB_SETIMAGELIST :: UINT -tB_SETIMAGELIST = wM_USER + 48 - -tB_GETTOOLTIPS :: UINT -tB_GETTOOLTIPS = wM_USER + 35 - -tB_SETTOOLTIPS :: UINT -tB_SETTOOLTIPS = wM_USER + 36 - -foreign import stdcall "mmsystem.h timeBeginPeriod" timeBeginPeriod :: UINT -> IO UINT - -foreign import stdcall "mmsystem.h timeEndPeriod" timeEndPeriod :: UINT -> IO UINT - -foreign import stdcall "mmsystem.h timeSetEvent" timeSetEvent :: UINT -> UINT -> LPVOID -> UINT -> UINT -> IO UINT - -foreign import stdcall "windows.h CreateEventW" createEvent :: LPVOID -> BOOL -> BOOL -> LPTSTR -> IO HANDLE - -tIMER_ONESHOT :: UINT -tIMER_ONESHOT = 1 - -tIMER_PERIODIC :: UINT -tIMER_PERIODIC = 64 - -tIME_CALLBACK_FUNCTION :: UINT -tIME_CALLBACK_FUNCTION = 0 - -tIME_CALLBACK_EVENT_SET :: UINT -tIME_CALLBACK_EVENT_SET = 16 - -tIME_CALLBACK_EVENT_PULSE :: UINT -tIME_CALLBACK_EVENT_PULSE = 32 - ---- The following functions are utilities, not part of the Win32 API. - --- | Helper to add buttons from a bitmap already present. -{- -addExistingBitmaps :: HWND -> [(LONG, UINT, BYTE)] -> IO () -addExistingBitmaps toolbar whichbuttons = do - let nButtons = length whichbuttons - fp <- mallocForeignPtrBytes (8 `max` (nButtons * tb_addbuttons_size)) - withForeignPtr fp $ \p -> do - mapM_ (\(i, (n, id, state)) -> do - pokeByteOff p i n - pokeByteOff p (i + 4) id - pokeByteOff p (i + 8) 0 - pokeByteOff (castPtr p) (i + 8) state - pokeByteOff p (i + 16) 0) - whichbuttons - sendMessage toolbar tB_ADDBUTTONSA nButtons (toLPARAM p) - sendMessage toolbar tB_AUTOSIZE 0 0 - -addButtonsFromModule :: HINSTANCE -> HWND -> HRESOURCE -> [(LONG, UINT, BYTE)] -> IO () -addButtonsFromModule mod toolbar bitmap whichbuttons = do - sendMessage toolbar tB_BUTTONSTRUCTSIZE tb_addbuttons_size 0 - fp <- mallocForeignPtrBytes 8 - withForeignPtr fp $ \p => do - pokeByteOff p 0 mod - pokeByteoff p 4 bitmap - sendMessage toolbar tB_ADDBITMAP (maximum whichbuttons + 1) (toLPARAM p) - addExistingButtons toolbar whichbuttons clearToolbar - --- | Add buttons to a toolbar directly out of a resource. The elements of the third --- parameter indicate for each button, its position in the bitmap, its control ID, --- and its button state respectively. -addButtons :: HWND -> HRESOURCE -> [(LONG, UINT, BYTE)] -> IO () -addButtons toolbar bitmap whichbuttons = do - mod <- getModuleHandle nullPtr - addButtonsFromModule mod toolbar bitmap whichbuttons - --- | Remove all buttons from a toolbar. -clearToolbar toolbar = whileM_ (return ()) (liftM (/=0) $ sendMessage toolbar tB_DELETEBUTTON 0 0) - --- | Add toolbar buttons from an imagelist. Returns the former imagelist. -setImageList :: HWND -> HIMAGELIST -> [(LONG, UINT, BYTE)] -> IO HIMAGELIST -setImageList toolbar imagelist whichbuttons = do - sendMessage toolbar tB_BUTTONSTRUCTSIZE tb_addbuttons_size 0 - clearToolbar toolbar - oldlist <- sendMessage toolbar tS_SETIMAGELIST 0 imagelist - addExistingButtons toolbar whichbuttons - return oldlist-} - --- | Create a frame window with reasonable defaults. A null background brush is used to prevent flicker. -frameWindow icon menu parent title closure = do - hdl <- getModuleHandle Nothing - cursor <- loadCursor Nothing iDC_ARROW - null <- getStockBrush nULL_BRUSH - let name = mkClassName "Frame" - registerClass (0, hdl, icon, Just cursor, Just null, Nothing, name) - createWindowEx 0 name title (wS_OVERLAPPEDWINDOW .|. wS_VISIBLE .|. wS_CLIPCHILDREN) Nothing Nothing Nothing Nothing Nothing menu parent closure -