packages feed

reflex-gloss-scene (empty) → 0.1

raw patch · 13 files changed

+962/−0 lines, 13 filesdep +MonadRandomdep +basedep +containerssetup-changed

Dependencies added: MonadRandom, base, containers, dependent-sum, gloss, gloss-rendering, lens, linear, mtl, profunctors, random, reflex, reflex-animation, reflex-gloss, reflex-gloss-scene, reflex-transformers, semigroups, transformers, tuple, vector-space

Files

+ .gitignore view
@@ -0,0 +1,15 @@+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox+cabal.sandbox.config
+ .travis.yml view
@@ -0,0 +1,27 @@+sudo: false+cache:+  directories:+    - $HOME/hlint+before_install:+ - travis_retry cabal-$CABALVER update+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/happy/1.19.5/bin:/opt/alex/3.1.4/bin:~/hlint/bin:$PATH+ - travis/install-hlint.sh+install:+ - cabal-$CABALVER sandbox init+ - git clone -b develop https://github.com/ryantrinkle/reflex reflex+ - cabal-$CABALVER sandbox add-source $PWD/reflex+ - cabal-$CABALVER install -v --only-dependencies --enable-tests --enable-benchmarks -j++script:+ - travis/script.sh+ - hlint src++matrix:+  allow_failures:+   - env: CABALVER=head GHCVER=head +  include:+    - env: CABALVER=1.22 GHCVER=7.10.2+      addons: {apt: {packages: [freeglut3-dev, cabal-install-1.22, ghc-7.10.2, alex-3.1.4, happy-1.19.5],sources: [hvr-ghc]}}+    - env: CABALVER=head GHCVER=head+      addons: {apt: {packages: [cabal-install-head, ghc-head, alex-3.1.4, happy-1.19.5],  sources: [hvr-ghc]}}+  fast_finish: true
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Jeffrey Rosenbluth++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Jeffrey Rosenbluth nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,7 @@+reflex-gloss-scene [![Build Status](https://secure.travis-ci.org/Saulzar/reflex-gloss-scene.png?branch=master)](http://travis-ci.org/Saulzar/reflex-gloss-scene)+====================+++A scenegraph library using gloss and gloss-reflex, with support for picking, +continuous time animations and monad based switching. An example of a framework +created using the reflex-transformers package
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Animations.hs view
@@ -0,0 +1,68 @@+-- {-# LANGUAGE RecursiveDo #-}++module Main where++import Reflex+import Reflex.Gloss.Scene+-- import Reflex.Monad.Time+-- import Reflex.Animation+++-- import Reflex.Monad++import Graphics.Gloss++++-- import Control.Applicative hiding (optional)++import Widgets++    ++-- data Track time = Rotation Float | Position Vector deriving Ord+-- +-- +-- newtype Tracks time = Tracks { unTracks :: [Track time] }++--     +--     +--     +--     +-- bounce :: PictureAnimation+-- bounce = repeat (half (sine 0.5))+  +  +  +additive :: Reflex t => Scene t ()+additive = do+  +  translation (-60, 0) $ do+    (_, bounceClick) <- translation (0, 80) $ toggleButton (pure "Bounce") (pure (80, 30)) never+    (_, wiggleClick) <- translation (0, 30) $ toggleButton (pure "Wiggle") (pure (80, 30)) never+    +    return ()+    +  translation (60, 0) $ +    render $ square <$> pure green+  +  +  where+    +    square c = color c $ rectangleSolid 40 40++ ++widget :: Reflex t => Scene t  ()+widget = do+  additive+  +  return ()++++main = playSceneGraph display background frequency widget+  where +    display = InWindow "Animations example" (600, 600) (0, 0)+    background = white+    frequency = 30
+ examples/Collections.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE RecursiveDo #-}++module Main where++import Reflex+import Reflex.Gloss.Scene+import Reflex.Gloss.Random+import Reflex.Monad.Time+import Reflex.Animation++import Graphics.Gloss++import Data.Monoid+import Data.Maybe++import qualified Data.Map as Map++import Control.Applicative hiding (optional)++import Widgets++    +    +      +randomCircle :: RandomGen g => Rand g (Color, Point, Float) +randomCircle = do+  c <- getRandomR (makeColor 0 0 0 1, makeColor 1 1 1 1)+  p <- getRandomR ((-200, -200), (200, 200))+  r <- getRandomR (40, 100)+  return (c, p, r)++  +fadeFrom :: Color -> Clip Time Color+fadeFrom from = keyframes from [(0.5, withAlpha 0 from)]++flashRed :: Color -> Clip Time Color+flashRed c = keyframes c [(0.4, red), (0.4, c)]+++makeCircle :: (Reflex t) => (Color, Point, Float) ->  Scene t ((), Event t ())  +makeCircle (c, p, radius) = translation p $ do +  e <- chain (Chain active >-> Chain quitting) ()+  return ((), e)+  +  where+  +    quitting currentCol = do+      (col, done) <- playClamp (fadeFrom currentCol)+      renderCircle col+      return done++    active () =  do+      target <- targetCircle (constant radius)+      (rightClick, _) <- clicked RightButton target+      +      (enter, leave) <- mouseOver target+      rec +        (flashing, _) <- playOn (gate (isNothing <$> flashing) $ flashRed c <$ enter)++      let col = fromMaybe c <$> flashing+      renderCircle col++      return (tag col rightClick)+    +    renderCircle currentCol = render (renderBody <$> currentCol)    +    renderBody c = color c $ circleSolid radius    +    +    +    ++ ++widget :: Reflex t => Scene t ()+widget = do+  +  click <- translation (200, 200) $ +           rotation 40 $+      button (constant "New") (constant (80, 30))+  +  degrees <- integrate 0 (constant 4)++  activeRotation degrees $ do+    newItems <- fmap makeCircle <$> foldRand (mkStdGen 0) randomCircle click  +    circles <- holdMapDyn =<< collection [] (pure <$> newItems) +    render $ centreText . show . Map.size <$> current circles+++  return ()++++main = playSceneGraph display background frequency widget+  where +    display = InWindow "Collections example" (600, 600) (0, 0)+    background = white+    frequency = 30
+ examples/FrpZoo.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE RecursiveDo #-}++module Main where++import Reflex+import Reflex.Gloss.Scene++import Graphics.Gloss+import Data.Monoid+import Data.Maybe+import Data.Bifunctor++import Control.Applicative hiding (optional)+import Widgets++foldMerge :: MonadReflex t m => a -> [Event t (a -> a)] -> m (Dynamic t a)+foldMerge initial events = foldDyn ($) initial (mergeWith (.) events) ++buttonPair :: (Reflex t) => Behavior t Int -> Scene t (Event t (), Event t ())+buttonPair b = mdo+  inc    <- translation (0, 20) $ button (show <$> b) (pure (80, 30))+  toggle <- translation (0, -20) $ button (pure "Toggle") (pure (80, 30))+  return (inc, toggle) ++resetButtons :: (Reflex t) => Scene t ()+resetButtons = mdo+  (inc, toggle) <- buttonPair (fromMaybe (-1) <$> current d) +  d <- foldMerge (Just 0) [fmap (+1) <$  inc, reset <$ toggle] +  return ()+    where+      reset Nothing  = Just 0+      reset (Just n) = Nothing  +  +toggleButtons :: (Reflex t) => Scene t ()+toggleButtons = do+  rec (inc, toggle) <- buttonPair ((\(n, b) -> if b then n else (-1)) <$> current d) +      d <- foldMerge (0, True) [first (+1) <$ inc, second not <$ toggle]+  return ()+  +widget :: Reflex t => Scene t  ()+widget = do+  translation (-100, 0) resetButtons +  translation (0, 0)    toggleButtons +  translation (100, 0)  toggleButtons +++main = playSceneGraph display background frequency widget+  where +    display = InWindow "Reflex Frp-zoo" (300, 200) (0, 0)+    background = white+    frequency = 60
+ examples/Widgets.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE RecursiveDo #-}++module Widgets +  ( centreText+  +  , renderButton+  , button+  +  , toggleButton+  ) where++import Reflex+import Reflex.Gloss.Scene+import Graphics.Gloss++++smallText :: String -> Picture+smallText str = scale 0.1 0.1 $ text str++centreText :: String -> Picture+centreText str = translate (-x) (-y) $ smallText str where+  x = fromIntegral (length str) * charWidth * 0.5+  y = charHeight * 0.5+  +  (charWidth, charHeight) = (6, 10)+  +renderButton :: Color -> Bool -> Bool -> String -> Vector -> Picture+renderButton c isHovering isPressing str (sx, sy) = mconcat +    [ color fill $ rectangleSolid sx sy+    , centreText str+    , if isHovering then rectangleWire sx sy else mempty+    ] where+    +    fill = if isHovering && isPressing then dark c else c +++coloredButton :: Reflex t => Behavior t Color -> Behavior t String -> Behavior t Vector -> Scene t (Event t ())+coloredButton col str size = do+  +  target <- targetRect size+  (click, pressing) <- clicked LeftButton target+  +  render $ renderButton <$> col <*> hovering target+            <*> pressing <*> str <*> size+  return click+  ++button :: Reflex t => Behavior t String -> Behavior t Vector -> Scene t (Event t ())+button = coloredButton (pure $ light azure)+  +  +toggleButton :: Reflex t => Behavior t String -> Behavior t Vector -> Event t Bool -> Scene t (Dynamic t Bool, Event t Bool)+toggleButton str size setter = do+  rec +    click <- coloredButton (currentColor <$> current down) str size+    let clickDown = tag (not <$> current down) click+    +    down <- holdDyn False $ leftmost [clickDown, setter]+  +  return (down, clickDown)++  where+    currentColor d = if d then orange else light azure+
+ reflex-gloss-scene.cabal view
@@ -0,0 +1,95 @@+name:                reflex-gloss-scene+version:             0.1+synopsis:            A simple scene-graph using reflex and gloss+description:         A scenegraph library using gloss and gloss-reflex, with support for picking, +                     continuous time animations and monad based switching. An example of a framework +                     created using the reflex-transformers package.++homepage:            https://github.com/saulzar/reflex-gloss-scene+bug-reports:         https://github.com/saulzar/reflex-gloss-scene/issues+license:             BSD3+license-file:        LICENSE++author:              Oliver Batchelor+maintainer:          saulzar@gmail.com+copyright:           2015 Oliver Batchelor+category:            FRP+build-type:          Simple+cabal-version:       >=1.10+++extra-source-files:  +  examples/Widgets.hs+  .gitignore+  .travis.yml+  README.md++source-repository head+  type: git+  location: https://github.com/saulzar/reflex-gloss-scene.git++executable animations+  hs-source-dirs:      examples+  default-language:    Haskell2010+  main-is:             Animations.hs+  build-depends:       base, gloss, reflex, reflex-transformers, reflex-gloss-scene,  reflex-animation, transformers, mtl, linear, lens, containers+  default-extensions:  MultiParamTypeClasses ScopedTypeVariables RankNTypes FlexibleContexts TypeFamilies+++executable collections+  hs-source-dirs:      examples+  default-language:    Haskell2010+  main-is:             Collections.hs+  build-depends:       base, gloss, reflex, reflex-transformers, reflex-gloss-scene,  reflex-animation, transformers, mtl, linear, lens, containers+  default-extensions:  MultiParamTypeClasses ScopedTypeVariables RankNTypes FlexibleContexts TypeFamilies++executable frpzoo+  hs-source-dirs:      examples+  default-language:    Haskell2010+  main-is:             FrpZoo.hs+  build-depends:       base, gloss, reflex, reflex-transformers, reflex-animation, reflex-gloss-scene, transformers, mtl, linear, lens, containers+  default-extensions:  MultiParamTypeClasses ScopedTypeVariables RankNTypes FlexibleContexts TypeFamilies+++library+  exposed-modules:     Reflex.Gloss.Scene+                       Reflex.Gloss.Random++  other-modules:       Reflex.Gloss.Vector+  +  build-depends:       base >=4.6 && <4.9,+                       gloss >= 1.9.2.1 && < 1.10,+                       gloss-rendering >= 1.9.2.1,+                       reflex-gloss >= 0.1.0.1 && < 0.2.0,+                       reflex >=0.2 && <0.4,+                       reflex-transformers >= 0.1 && < 1.0, +                       reflex-animation >= 0.1 && < 1.0, +                       dependent-sum >= 0.2.1 && < 0.3,+                       transformers >= 0.4.2 && < 0.5, +                       +                       mtl,+                       vector-space,+                       lens,+                       random,+                       MonadRandom,+                       tuple,+                       semigroups,+                       profunctors,+                       containers++  default-extensions:+    FlexibleInstances+    TupleSections+    FlexibleContexts+    StandaloneDeriving+    FunctionalDependencies+    TypeFamilies+    GeneralizedNewtypeDeriving+    MultiParamTypeClasses+    RecursiveDo+    ScopedTypeVariables+    RankNTypes+    GADTs                       +                       +  hs-source-dirs:      src+  default-language:    Haskell2010
+ src/Reflex/Gloss/Random.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Reflex.Gloss.Random +  ( module Control.Monad.Random+  , module System.Random+  , foldGen+  , foldRandoms+  , foldRandomRs+  , foldRand+  )+  +  where++import Control.Monad.Fix +import Control.Monad.State++import Control.Applicative+import Graphics.Gloss  ++import System.Random+import Control.Monad.Random++import Data.Tuple.All+import Data.Bifunctor++import Reflex+++-- | Reflex.Gloss.Random+-- A module for using random number state with reflex. Not really related to gloss, but the examples use it!+  +  ++-- These should really be in base!+instance (Random a, Random b) => Random (a, b) where +  randomR ((a, b), (a', b'))  = runState (liftA2 (,) (state $ randomR (a, a')) (state $ randomR (b, b'))) +  random        = runState (liftA2 (,) (state random) (state random)) +  ++instance (Random a, Random b, Random c) => Random (a, b, c) where +  randomR ((a, b, c), (a', b', c'))  = runState (liftA3 (,,) (state $ randomR (a, a')) (state $ randomR (b, b')) (state $ randomR (c, c'))) +  random        = runState (liftA3 (,,) (state random) (state random) (state random)) ++  +instance (Random a, Random b, Random c, Random d) => Random (a, b, c, d) where +  randomR ((a, b, c, d), (a', b', c', d'))  = runState ((,,,) <$> state (randomR (a, a')) <*> state (randomR (b, b'))  <*> state (randomR (c, c')) <*> state (randomR (d, d')))+  random        = runState ((,,,) <$> state random  <*> state random <*> state random <*> state random)  ++-- and these should be in gloss!++instance Random Color where+  random = first (uncurryN makeColor) . randomR ((0, 0, 0, 0), (1, 1, 1, 1))+  randomR (a, a') = first (uncurryN makeColor) . randomR (rgbaOfColor a, rgbaOfColor a')+  +++foldGen :: (Reflex t, MonadHold t m, MonadFix m) => s -> (s -> (a, s)) -> Event t () -> m (Event t a)+foldGen initialState f input = do+  rec+    curState <- hold initialState newState+    let (outputs, newState) = splitE $ f <$> tag curState input  +  return outputs++  +foldRandoms :: (Reflex t, MonadHold t m, MonadFix m, Random a) => Int -> Event t () -> m (Event t a)+foldRandoms seed = foldGen (mkStdGen seed) random+++foldRandomRs :: (Reflex t, MonadHold t m, MonadFix m, Random a) => Int -> (a, a) -> Event t () -> m (Event t a)+foldRandomRs seed range = foldGen (mkStdGen seed) (randomR range)++foldRand :: (Reflex t, MonadHold t m, MonadFix m, RandomGen g) => g -> Rand g a -> Event t () -> m (Event t a)+foldRand g f = foldGen g (runRand f)
+ src/Reflex/Gloss/Scene.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes       #-}+{-# LANGUAGE TemplateHaskell  #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE UndecidableInstances  #-}+++-- | Reflex.Gloss.Scene+-- A simple scene graph implementation rendered using gloss. Contains functionality for picking and transformations.+-- Implements interfaces for MonadSwitch (see reflex-transformers) and MonadTime (see reflex-animations) for switching, and animation support respectively.+++module Reflex.Gloss.Scene+  ( playSceneGraph+  , rotation+  , activeRotation+  +  , translation+  , activeTranslation+  +  , render+  , Scene+  +  , Time+  +  , targetRect+  , targetCircle+  , makeTarget+  , hovering+  , Target+   +  , mouseUp+  , mouseDown+  , clicked+  +  , mouseOver+  +  , MouseButton(..)+  , SpecialKey (..)+  , Input (..)+  +  , module Reflex.Monad+  +  )+  where++import Control.Monad.Fix      +import Control.Monad.Reader++import Control.Lens hiding ((<.>), transform)+import Control.Applicative++import Data.Monoid+import Data.List+import Data.List.NonEmpty (nonEmpty)+++import Reflex+import Reflex.Gloss++import Reflex.Monad.Time++import Graphics.Gloss.Interface.IO.Game hiding (Event, KeyDown, KeyUp)+import qualified Graphics.Gloss.Interface.IO.Game as G+++import Reflex.Monad+import Reflex.Monad.ReaderWriter+import Reflex.Monad.ReflexM++import Reflex.Gloss.Vector++-- | Input data type more covenient for splitting than the Gloss Input type  +data Input = MouseDown MouseButton +           | MouseUp MouseButton+           | CharDown Char+           | CharUp Char+           | SpecialUp SpecialKey+           | SpecialDown SpecialKey  +--            | MouseOver +--            | MouseOut+  deriving (Show, Eq, Ord)+        +-- | Time is just a float!        +type Time = Float+        +data SceneNode t = SceneNode +  { _sceneTime          :: Behavior t Time +  , _sceneTick          :: Event t Time+  , _sceneMousePosition :: Behavior t Vector+  , _sceneTransform     :: Behavior t Matrix33+  , _sceneEvents        :: Event t Input+  , _sceneWindowSize      :: Behavior t Vector+  }+  +$(makeLenses ''SceneNode)+$(makePrisms ''Input)+++$(makePrisms ''G.Event)+$(makePrisms ''G.Key)++-- | Scene Monad, passes down the scene graph a SceneNode, passes back up the scene graph renderings (Behavior t Picture)+-- Implements MonadSwitch and MonadTime abstractions.+newtype Scene t a = Scene { runScene :: ReaderWriterT (SceneNode t) [Behavior t Picture] (ReflexM t) a } +                        deriving (Monad, Functor, Applicative, MonadFix)+++deriving instance Reflex t => MonadSample t (Scene t)+deriving instance Reflex t => MonadHold t (Scene t)+deriving instance Reflex t => MonadWriter [Behavior t Picture] (Scene t)+deriving instance Reflex t => MonadReader (SceneNode t) (Scene t)++  + + +instance Reflex t => MonadSwitch t (Scene t) where+  switchM     u  =  Scene $ switchM (runScene <$> u)+  switchMapM  um =  Scene $ switchMapM (runScene <$> um)+++  +  +toVector :: Integral a => (a, a) -> Vector+toVector (a, b) = (fromIntegral a, fromIntegral b)+++toInput :: (Key, KeyState, a, b) -> Input+toInput (key, d, _, _) = case (key, d) of                       +    (MouseButton b, Down) -> MouseDown b+    (MouseButton b, Up)   -> MouseUp b+    +    (Char c, Down) -> CharDown c+    (Char c, Up)   -> CharUp c+    +    (SpecialKey k, Down) -> SpecialDown k+    (SpecialKey k, Up)   -> SpecialUp k++    +    +            +previewF ::  FunctorMaybe f => Getting (First b) s b -> f s -> f b+previewF getter = fmapMaybe (preview getter) +            +        +runSceneGraph :: forall t m. (Reflex t, MonadHold t m, MonadFix m) => Vector -> Scene t () -> Event t Float -> Event t InputEvent -> m (Behavior t Picture)+runSceneGraph initialSize scene tick inputs = do+  time <- foldDyn (+) 0 tick  +  mousePosition <- hold (1/0, 1/0) $ previewF _EventMotion inputs+  windowSize <- hold initialSize (toVector <$> previewF _EventResize inputs)+  +  let rootNode = SceneNode +        { _sceneTime          = current time+        , _sceneTick          = tick+        , _sceneMousePosition   = mousePosition+        , _sceneEvents = toInput <$> previewF _EventKey inputs +        , _sceneTransform = constant identityMat +        , _sceneWindowSize = windowSize+        }+  +  runSceneGraph' rootNode scene++      +  +runSceneGraph' :: (Reflex t, MonadHold t m, MonadFix m) => SceneNode t -> Scene t a -> m (Behavior t Picture)+runSceneGraph' node = fmap mconcat . runReflexM . flip execReaderWriterT node . runScene+++-- | Run a scenegraph in IO+playSceneGraph :: Display -> Color -> Int ->  (forall t. Reflex t => Scene t  ()) -> IO ()+playSceneGraph display col frequency scene = playReflex display col frequency (runSceneGraph (displaySize display) scene) where+  displaySize (InWindow _ s _) = toVector s+  displaySize (FullScreen s) = toVector s+  +  +-- | Render a picture in the current widget+render :: Reflex t => Behavior t Picture -> Scene t ()+render r = tell [r]++    +    +-- | Local mouse position relative to the widget+localMouse :: Reflex t => Scene t (Behavior t Point)+localMouse = asks sceneLocalMouse+++-- | Get the global mouse position in the window+globalMouse :: Reflex t => Scene t (Behavior t Point)+globalMouse = asks _sceneMousePosition++-- | Rotate a child widget using a constant+rotation :: Reflex t => Float -> Scene t a -> Scene t a +rotation degrees child = localRender (fmap $ G.Rotate degrees) $ +    localTransform (rotationMat degrees) child++-- | Rotate a child widget actively using a Behavior+activeRotation :: Reflex t => Behavior t Float -> Scene t a -> Scene t a +activeRotation degrees child = localRender (G.Rotate <$> degrees <*>) $   +    localTransformDyn (rotationMat <$> degrees) child+  +-- | Translate a child widget using a constant+translation :: Reflex t =>  Vector -> Scene t a -> Scene t a +translation (x, y) child = localRender (fmap $ G.Translate x y) $ +    localTransform (translationMat (-x, -y)) child++-- | Translate a child widget actively using a Behavior+activeTranslation :: Reflex t => Behavior t Vector -> Scene t a -> Scene t a +activeTranslation v child = localRender (uncurry G.Translate <$> v <*>) $   +    localTransformDyn (translationMat . negate <$> v) child  ++  +-- | Type for picking targets+data Target t = Target +  { targetNode  :: SceneNode t   +  , hovering    :: Behavior t Bool+  }  +  +  +  +-- | Make a target from an intersection function  +makeTarget :: Reflex t => Behavior t (Vector -> Bool) -> Scene t (Target t) +makeTarget intersects = do+  node  <- ask+  mouse <- localMouse+  return  Target +    { targetNode = node+    , hovering   = intersects <*> mouse+    }  +  ++intersectRect :: Vector -> Vector -> Bool+intersectRect (sizeX, sizeY) (x, y) = x >= -sx && x <= sx && y >= -sy && y <= sy  where+    sx = sizeX * 0.5+    sy = sizeY * 0.5++intersectCircle :: Float -> Vector -> Bool+intersectCircle radius (x, y) = x * x + y * y < radius * radius    +    +    +-- | Make a circular picking target    +targetCircle :: Reflex t => Behavior t Float -> Scene t (Target t) +targetCircle size = makeTarget (intersectCircle <$> size)+++-- | Make a rectangular picking target    +targetRect :: Reflex t => Behavior t Vector -> Scene t (Target t) +targetRect size = makeTarget (intersectRect <$> size)+++-- Match a particular kind of mouse or key event+nodeEvent :: Reflex t => Input -> SceneNode t -> Event t ()+nodeEvent input node = match input $ node ^. sceneEvents  +++-- | Mouse down event on a picking target+mouseDown :: Reflex t => MouseButton -> Target t -> Event t ()+mouseDown button target = gate (hovering target) $ nodeEvent (MouseDown button) (targetNode target)+ +-- | Mouse up event on a picking target+mouseUp :: Reflex t => MouseButton -> Target t -> Event t ()+mouseUp button target = gate (hovering target) $ nodeEvent (MouseUp button) (targetNode target)+++-- | Mouse over event on a picking target, returns events for (entering, leaving)+mouseOver :: (Reflex t, MonadTime t time m) => Target t -> m (Event t (), Event t ())+mouseOver target = do+  ov <- observeChanges (hovering target)+  return (match True ov, match False ov)++-- | Mouse click event for picking target, returns click event and behavior indicating current clicking+clicked :: (Reflex t, MonadHold t m) => MouseButton -> Target t -> m (Event t (), Behavior t Bool)+clicked button target = do+  pressing <- hold False $ leftmost +    [ False <$ nodeEvent (MouseUp button) (targetNode target)+    , True <$ mouseDown button target  +    ]+    +  return (void $ gate pressing (mouseUp button target), pressing)++getTick :: Reflex t => Scene t (Event t Float)+getTick = asks _sceneTick++++instance Reflex t => MonadTime t Time (Scene t) where++  --observe :: MonadTime t m => Behavior t a -> m (Event t a)+  observe b = tag b <$> getTick  ++  --integrate :: (VectorSpace v, Scalar v ~ Time, MonadReflex t m) => v -> Behavior t v -> Scene t (Behavior t v)+  integrate x dx  = do+    frame <- attachWith (^*) dx <$> getTick+    current <$> foldDyn (^+^) x frame+    ++  --after :: MonadReflex t m => Time -> Scene t (Event t ())+  after t = do+    time <- foldDyn (+) 0 =<< getTick+    onceE $ matchBy (>= t) (updated time)+    +    +  getTime = asks _sceneTime+    +    +  -- | Delay an Event by a time period+  --delay :: MonadReflex t m => Event t (a, Time) ->  Scene t (Event t [a])+  delay e = do+    tick  <- asks _sceneTick+    time  <- getTime++    rec+      b <- hold [] waiting+    +      let next = leftmost [new, tag b tick]+          (waiting, firing) = split $ +            attachWith (\t -> partition ((> t) . snd)) time next++          new = pushFor e $ \(a, p) -> do+            now <- sample time+            existing <- sample b+            return ((a, now + p) : existing)+            +    return (fmapMaybe (nonEmpty . fmap fst) firing)  +++    +-- Internal utility functions for Scene Node transformations+localRender :: Reflex t => (Behavior t Picture -> Behavior t Picture) -> Scene t a -> Scene t a +localRender f = censor (pure . f . mconcat) +++transformNode :: (Reflex t) => Matrix33 -> SceneNode t -> SceneNode t+transformNode transform node = node & sceneTransform %~ fmap (transform `mm3`)++  +transformNodeDyn :: (Reflex t) => Behavior t Matrix33 -> SceneNode t -> SceneNode t+transformNodeDyn transform node = node & sceneTransform %~ liftA2 (flip mm3) transform+  +localTransform :: Reflex t => Matrix33 -> Scene t a -> Scene t a +localTransform transform = local (transformNode transform)+   +    +localTransformDyn :: Reflex t => Behavior t Matrix33 -> Scene t a -> Scene t a +localTransformDyn transform = local (transformNodeDyn transform)+    +sceneLocalMouse :: Reflex t => SceneNode t -> Behavior t Point+sceneLocalMouse node = liftA2 transformPoint (_sceneTransform node) (_sceneMousePosition node)
+ src/Reflex/Gloss/Vector.hs view
@@ -0,0 +1,85 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Reflex.Gloss.Vector +  ( mv3+  , mm3+  , rotationMat+  , identityMat+  , translationMat+  , transformPoint+  +  , Matrix33, Vector3+  , module Data.VectorSpace+  +  ) where+  +  +import Graphics.Gloss.Rendering++import Data.VectorSpace+++type Vector3 = (Float, Float, Float)+type Matrix33 = (Vector3, Vector3, Vector3)+++mv3 :: Matrix33 -> Vector3 -> Vector3+mv3  (a, b, c) v = (a <.> v, b <.> v, c <.> v)+++vm3 :: Vector3 -> Matrix33 -> Vector3+vm3 (x, y, z) (a, b, c) = x *^ a ^+^ y *^ b ^+^ z *^ c++++mm3 :: Matrix33 -> Matrix33 -> Matrix33+mm3 (a, b, c) m = (a `vm3` m, b `vm3` m, c `vm3` m) +++rotationMat :: Float -> Matrix33+rotationMat deg = + ( (ca, -sa,   0)+ , (sa,  ca,   0)+ , (0,    0,   1))+  +  where+    a = deg * pi / 180.0 +    ca = cos a+    sa = sin a+    +    +identityMat ::  Matrix33+identityMat = +  ( (1,    0,   0)+  , (0,    1,   0)+  , (0,    0,   1)) ++    +translationMat :: Vector -> Matrix33+translationMat (dx, dy) =  +  ( (1,    0,  dx)+  , (0,    1,  dy)+  , (0,    0,  1)) +  +                                   ++transformPoint :: Matrix33 -> Point -> Point+transformPoint transform (x, y) = (x', y') ^* (1 / w) where+  (x', y', w) = transform `mv3` (x, y, 1)  +  +  +instance AdditiveGroup Color where+    zeroV = makeColor 0 0 0 0+    c ^+^ c' = makeRawColor (r + r') (g + g') (b + b') (a + a')+      where  (r, g, b, a) = rgbaOfColor c+             (r', g', b', a') = rgbaOfColor c'+    negateV c = makeRawColor (-r) (-g) (-b) (-a)+      where (r, g, b, a) = rgbaOfColor c+++instance VectorSpace Color where+    type Scalar Color = Float+  +    s *^ c  = makeRawColor (r * s) (g * s) (b * s) (a * s) +      where (r, g, b, a) = rgbaOfColor c+