diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,15 @@ +dist +docs +wiki +TAGS +tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# +.cabal-sandbox +cabal.sandbox.config diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Animations.hs b/examples/Animations.hs new file mode 100644 --- /dev/null +++ b/examples/Animations.hs @@ -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 diff --git a/examples/Collections.hs b/examples/Collections.hs new file mode 100644 --- /dev/null +++ b/examples/Collections.hs @@ -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 diff --git a/examples/FrpZoo.hs b/examples/FrpZoo.hs new file mode 100644 --- /dev/null +++ b/examples/FrpZoo.hs @@ -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 diff --git a/examples/Widgets.hs b/examples/Widgets.hs new file mode 100644 --- /dev/null +++ b/examples/Widgets.hs @@ -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 + diff --git a/reflex-gloss-scene.cabal b/reflex-gloss-scene.cabal new file mode 100644 --- /dev/null +++ b/reflex-gloss-scene.cabal @@ -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 diff --git a/src/Reflex/Gloss/Random.hs b/src/Reflex/Gloss/Random.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Gloss/Random.hs @@ -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) diff --git a/src/Reflex/Gloss/Scene.hs b/src/Reflex/Gloss/Scene.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Gloss/Scene.hs @@ -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) diff --git a/src/Reflex/Gloss/Vector.hs b/src/Reflex/Gloss/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Gloss/Vector.hs @@ -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 +