Commit 75a867 initial

15 files Merged and Committed by Richard Marko 2 years ago
initial

    
1 @@ -0,0 +1,2 @@
2 + .stack-work
3 + attic
 1 @@ -0,0 +1,30 @@
 2 + Copyright (c) 2017, Richard Marko
 3 + 
 4 + All rights reserved.
 5 + 
 6 + Redistribution and use in source and binary forms, with or without
 7 + modification, are permitted provided that the following conditions are met:
 8 + 
 9 +     * Redistributions of source code must retain the above copyright
10 +       notice, this list of conditions and the following disclaimer.
11 + 
12 +     * Redistributions in binary form must reproduce the above
13 +       copyright notice, this list of conditions and the following
14 +       disclaimer in the documentation and/or other materials provided
15 +       with the distribution.
16 + 
17 +     * Neither the name of Anthony Cowley nor the names of other
18 +       contributors may be used to endorse or promote products derived
19 +       from this software without specific prior written permission.
20 + 
21 + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27 + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31 + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 1 @@ -0,0 +1,32 @@
 2 + Liveplot
 3 + ========
 4 + 
 5 + Live plotting with OpenGL. This Haskell library allows feeding live data via Pipes to
 6 + OpenGL plots.
 7 + 
 8 + Currently only 2D line plot is supported. Multiple plots can be run simultaneously,
 9 + layout description interface needs work though.
10 + 
11 + .. image:: demo.jpg
12 +    :width: 40pt
13 + 
14 + 
15 + Requires
16 + --------
17 + 
18 + - stack https://docs.haskellstack.org/en/stable/README/
19 + 
20 + 
21 + Building
22 + --------
23 + 
24 + ::
25 + 
26 +         stack build
27 +         stack exec liveplot # for demo app
28 + 
29 + 
30 + Examples
31 + --------
32 + 
33 + See `Graphics.Liveplot.Demo` for usage example.
1 @@ -0,0 +1,2 @@
2 + import Distribution.Simple
3 + main = defaultMain
1 @@ -0,0 +1,7 @@
2 + {-# LANGUAGE DataKinds, TypeOperators #-}
3 + 
4 + import Graphics.Liveplot
5 + import Graphics.Liveplot.Demo
6 + 
7 + main :: IO ()
8 + main = runDemo

Binary diffs cannot be rendered.

 1 @@ -0,0 +1,56 @@
 2 + name:                liveplot
 3 + version:             0.0.1
 4 + synopsis:            Liveplotting
 5 + 
 6 + description:         Live plotting with OpenGL. This Haskell library allows feeding live data via Pipes to OpenGL plots.
 7 + 
 8 + license:             BSD3
 9 + license-file:        LICENSE
10 + author:              Richard Marko
11 + maintainer:          srk@48.io
12 + copyright:           Copyright (C) 2017 Richard Marko
13 + category:            Graphics
14 + build-type:          Simple
15 + cabal-version:       >=1.10
16 + 
17 + library
18 +   hs-source-dirs:      src
19 +   exposed-modules:     Graphics.Liveplot
20 +                        Graphics.Liveplot.Demo
21 +                        Graphics.Liveplot.Line
22 +                        Graphics.Liveplot.Shaders
23 +                        Graphics.Liveplot.Types
24 +                        Graphics.Liveplot.Utils
25 +                        Graphics.Liveplot.Window
26 +   build-depends:       base >= 4.6 && < 5,
27 +                        andromeda,
28 +                        bytestring,
29 +                        containers,
30 +                        directory,
31 +                        filepath,
32 +                        GLFW-b,
33 +                        GLUtil,
34 +                        lens,
35 +                        linear,
36 +                        mvc,
37 +                        OpenGL,
38 +                        pipes,
39 +                        pipes-misc,
40 +                        pipes-extras,
41 +                        stm,
42 +                        time,
43 +                        transformers,
44 +                        Vec,
45 +                        vector,
46 +                        vinyl,
47 +                        vinyl-gl
48 + 
49 +   default-language:    Haskell2010
50 +   ghc-options:         -Wall
51 + 
52 + executable liveplot
53 +   main-is:             App.hs
54 +   hs-source-dirs:      app
55 +   build-depends:       base >= 4.6 && < 5,
56 +                        liveplot
57 +   default-language:    Haskell2010
 1 @@ -0,0 +1,21 @@
 2 + module Graphics.Liveplot (
 3 +     runLiveplot
 4 +   , named
 5 +   , initGraph
 6 +   , lineGraph
 7 +   , SensorReading(..)
 8 +   , GLApp
 9 +   , Event
10 +   , GLfloat
11 +   , rpad
12 +   , ogl) where
13 + 
14 + import MVC
15 + import Graphics.Liveplot.Window
16 + import Graphics.Liveplot.Types
17 + import Graphics.Liveplot.Utils
18 + import Graphics.Rendering.OpenGL (GLfloat)
19 + 
20 + runLiveplot :: Plottable a => Managed (View (Either (SensorReading a) GLApp), Controller (Either (SensorReading a) Event))  -> IO ()
21 + runLiveplot app = runMVC () (asPipe defaultPipe) app
22 + 
 1 @@ -0,0 +1,38 @@
 2 + module Graphics.Liveplot.Demo where
 3 + 
 4 + import MVC
 5 + import qualified MVC.Prelude as MVC
 6 + import qualified Pipes.Prelude as Pipes
 7 + import Control.Concurrent (threadDelay)
 8 + 
 9 + import Graphics.Liveplot
10 + 
11 + runDemo :: IO()
12 + runDemo = runLiveplot demo
13 + 
14 + demo :: Managed (View (Either (SensorReading GLfloat) GLApp),
15 +                  Controller (Either (SensorReading GLfloat) Event))
16 + demo = do
17 +   let inits = [ lineGraph "adc" (2, 1) (0, 0)
18 +               , lineGraph "dac" (2, 1) (1, 0)]
19 + 
20 +   (v, c) <- ogl inits
21 + 
22 +   dat <- MVC.producer (bounded 1) (sinedata 5 10 >-> named "adc")
23 +   dat2 <- MVC.producer (bounded 1) (sinedata 100 10 >-> named "dac")
24 +   return (v, fmap Left (dat <> dat2) <> fmap Right c)
25 + 
26 + sinedata :: Float -> Float -> Producer GLfloat IO ()
27 + sinedata hz divider =
28 +   hztick hz
29 +   >-> Pipes.map ((/2). (+1) . (sin) . (/divider))
30 + 
31 + moiredata :: Float -> Producer GLfloat IO ()
32 + moiredata hz =
33 +   hztick hz
34 +   >-> Pipes.map ((/2). (+1) . (sin) . (/2))
35 + 
36 + hztick :: (Num t, RealFrac t1) => t1 -> MVC.Proxy x' x () t IO b
37 + hztick hz = run 0
38 +   where
39 +     run n = yield n >> (lift $ threadDelay $ floor $ 1000000/hz) >> run (n+1)
 1 @@ -0,0 +1,89 @@
 2 + {-# LANGUAGE DataKinds #-}
 3 + {-# LANGUAGE TypeOperators #-}
 4 + {-# LANGUAGE RecordWildCards #-}
 5 + {-# LANGUAGE FlexibleInstances #-}
 6 + {-# OPTIONS_GHC -fno-warn-orphans #-}
 7 + module Graphics.Liveplot.Line where
 8 + import Data.Vinyl
 9 + import Graphics.GLUtil
10 + import Graphics.Rendering.OpenGL
11 + import Graphics.VinylGL
12 + import Linear (V1(..))
13 + import Control.Concurrent.STM
14 + 
15 + import Graphics.Liveplot.Shaders
16 + import Graphics.Liveplot.Types
17 + 
18 + type XPos = '("xCoord", V1 GLfloat)
19 + 
20 + xcoord :: SField XPos
21 + xcoord = SField
22 + 
23 + monoTex :: Int -> IO TextureObject
24 + monoTex len = do
25 +   t <- freshTextureFloat len 1 TexMono
26 +   textureFilter Texture2D $= ((Linear', Nothing), Linear')
27 +   texture2DWrap $= (Repeated, ClampToEdge)
28 +   return t
29 + 
30 + line :: GraphInfo -> IO (Maybe [GLfloat] -> GraphInfo -> IO ())
31 + line gi =
32 +   do s <- uncurry simpleShaderProgramBS lineShaders
33 + 
34 +      let nsamples = graph_samples gi
35 +          xResolution = graph_resolution gi
36 +          pResolution = graph_points gi
37 + 
38 +          isamples = fromIntegral nsamples
39 +          xCoords :: [GLfloat]
40 +          xCoords = take xResolution $ iterate (+ 2 / fromIntegral xResolution) (-1)
41 +          _pointCoords :: [GLfloat]
42 +          _pointCoords = take pResolution $ iterate (+ 2 / fromIntegral pResolution) (-1)
43 +          yCoords :: [GLfloat]
44 +          yCoords = replicate nsamples 0
45 + 
46 +      vb <- bufferVertices . map (xcoord =:) $ V1 <$> xCoords -- <*> [0.0]-- [-1.0,1.0] <*> [-1.0,1.0]
47 +      --_vp <- bufferVertices . map (xcoord =:) $ V1 <$> pointCoords
48 +      t <- monoTex nsamples
49 +      reloadTexture t (TexInfo isamples 1 TexMono yCoords)
50 +      -- need to set current program here or setUniforms fails
51 +      currentProgram $= Just (program s)
52 +      setUniforms s (texSampler =: 0)
53 + 
54 +      --let vp = withViewport (Position 10 10) (Size 1024 60)
55 + 
56 +      -- no idea why this can't use vp
57 +      pointsVAO <- makeVAO $ do enableVertices' s vb
58 +                                bindVertices vb
59 + 
60 +      linesVAO  <- makeVAO $ do enableVertices' s vb
61 +                                bindVertices vb
62 +      return $ \d GraphInfo{..} -> do
63 +        currentProgram $= Just (program s)
64 +        setUniforms s graph_appinfo
65 +        let withVP = withVP' graph_viewport graph_scale graph_offset
66 +        case d of
67 +           Just dat -> reloadTexture t (TexInfo isamples 1 TexMono dat)
68 +           Nothing -> return ()
69 +        withVP $ withVAO linesVAO . withTextures2D [t] $
70 +          drawArrays LineStrip 0 (fromIntegral xResolution)
71 + 
72 +        -- XXX: use point texture
73 +        withVP $ withVAO pointsVAO . withTextures2D [t] $
74 +          drawArrays Points 0 (fromIntegral pResolution)
75 + 
76 +   where
77 +     texSampler = SField :: SField '("tex", GLint)
78 +     withVP' (Position x y, Size w h) (xsc, ysc) (xoff, yoff) = withViewport
79 +       (Position (x + (fromIntegral yoff) * w')
80 +                 (y + (fromIntegral xoff) * h'))
81 +       (Size w' h')
82 +       where
83 +         w' = floor $ fromIntegral w / ysc
84 +         h' = floor $ fromIntegral h / xsc
85 + 
86 + instance Plottable GLfloat where
87 +   initplot gi = do
88 +     tvar <- atomically $ newTVar Nothing
89 +     draw <- line gi
90 +     return (tvar, bufferTVar (graph_name gi) (graph_samples gi) tvar, draw)
 1 @@ -0,0 +1,58 @@
 2 + module Graphics.Liveplot.Shaders where
 3 + 
 4 + import Data.Vec ((:.)(..), Vec3, Vec4)
 5 + 
 6 + import qualified Data.Vector.Storable as V
 7 + 
 8 + import qualified Data.ByteString.Char8 as BS
 9 + 
10 + import Andromeda.Simple.Expr
11 + import Andromeda.Simple.Type
12 + import Andromeda.Simple.GLSL
13 + import Andromeda.Simple.StdLib
14 + import Andromeda.Simple.Render.Compile
15 + 
16 + compileBS :: Statement () -> Statement () -> (BS.ByteString, BS.ByteString)
17 + compileBS vert frag =
18 +   let vStr = version ++ toGLSL vert
19 +       fStr = version ++ toGLSL frag
20 +   in (BS.pack vStr, BS.pack fStr)
21 +   where
22 +     version :: String
23 +     version = "#version 330 core\n"
24 + 
25 + test :: IO ()
26 + test =
27 +     let (vs, fs) = compileBS lineVertShader lineFragShader
28 +     in do
29 +       BS.putStrLn vs
30 +       BS.putStrLn fs
31 + 
32 + lineShaders :: (BS.ByteString, BS.ByteString)
33 + lineShaders = compileBS lineVertShader lineFragShader
34 + 
35 + positionColor :: (Expr (Vec4 Float), Expr (Vec4 Float))
36 + positionColor =
37 +   let xCoord = fetch "xCoord" (ScalarT SFloat)
38 +       cam = uniform "cam" (Matrix3T SFloat)
39 +       tex = uniform "tex" Sampler2DT
40 +       yCoord = (((texture tex
41 +                   (flt ((xCoord + 1)/2) +: flt 0.0)) ~> "r") - (flt 0.5)) * (flt 2.0)
42 + 
43 +       col = yCoord / 2.0 + 0.5
44 + 
45 +   in (((cam #* (flt xCoord +: flt yCoord +: flt 1.0)) +: flt 1.0)
46 +      ,(flt (yCoord/2 + 0.5) +: flt (1 - col) +: flt 0.0 +: flt 1.0))
47 + 
48 + lineVertShader :: Statement ()
49 + lineVertShader = do
50 +     "gl_Position" =: fst positionColor
51 +     out "fColor" $ snd positionColor
52 + 
53 + outColor :: Expr (Vec4 Float)
54 + outColor =
55 +     let f_color = fetch "fColor" (Vec4T SFloat)
56 +     in f_color
57 + 
58 + lineFragShader :: Statement ()
59 + lineFragShader = out "fragColor" outColor
  1 @@ -0,0 +1,101 @@
  2 + {-# LANGUAGE DataKinds #-}
  3 + {-# LANGUAGE Rank2Types #-}
  4 + {-# LANGUAGE FlexibleContexts #-}
  5 + {-# LANGUAGE FlexibleInstances #-}
  6 + module Graphics.Liveplot.Types where
  7 + 
  8 + import Linear (V2, M33)
  9 + import Data.Vinyl
 10 + import Graphics.Rendering.OpenGL (GLfloat, Position(..), Size(..))
 11 + import Graphics.GLUtil.Camera2D
 12 + import Graphics.UI.GLFW
 13 + import MVC (Pipe)
 14 + import Data.Set (Set)
 15 + import Control.Concurrent.STM
 16 + import qualified Pipes.Prelude as Pipes
 17 + 
 18 + import Graphics.Liveplot.Utils
 19 + 
 20 + -- OpenGL events
 21 + data Event =
 22 +     Timestep Double
 23 +   | Keys     (Set Key)
 24 +   | Buttons  (Set MouseButton)
 25 +   | MousePos (V2 Double)
 26 +   | WinSize  (V2 Int)
 27 +   | Quit
 28 +   deriving Show
 29 + 
 30 + -- A record each drawing function will receive.
 31 + type Viewport = (Position, Size)
 32 + type AppInfo = FieldRec '[ '("cam", M33 GLfloat) ]
 33 + 
 34 + data GLApp = GLApp AppInfo Viewport
 35 +   deriving Show
 36 + 
 37 + data SensorReading a = Reading String a
 38 +   deriving (Eq, Show)
 39 + 
 40 + instance Functor SensorReading where
 41 +   fmap f (Reading s v) = (Reading s (f v))
 42 + 
 43 + type PlotInit a = (TVar (Maybe [a]), (SensorReading a) -> IO (), Maybe [a] -> GraphInfo -> IO ())
 44 + 
 45 + class Plottable a where
 46 +   initplot :: GraphInfo -> IO (PlotInit a)
 47 + 
 48 + accepts :: String -> SensorReading t -> Bool
 49 + accepts n (Reading s' _) = n == s'
 50 + 
 51 + named :: Monad m => String -> Pipe a (SensorReading a) m r
 52 + named n = Pipes.map (\x -> Reading n x)
 53 + 
 54 + -- buffer value and values in TVar
 55 + bufferTVar :: Fractional a =>
 56 +              String -> Int -> TVar (Maybe [a]) -> SensorReading a -> IO ()
 57 + bufferTVar name buflen tvar sample@(Reading _ val) = do
 58 +   case accepts name sample of
 59 +     True -> atomically $ do
 60 +         mtvar <- readTVar tvar
 61 +         case mtvar of
 62 +           Just cval -> writeTVar tvar $ Just $ rpad buflen 0.0 $ take buflen $ val:cval
 63 +           Nothing -> writeTVar tvar $ Just $ replicate buflen 0.0
 64 +     _ -> return ()
 65 + 
 66 + data GraphColor = Red | Green
 67 +   deriving (Show, Eq, Ord)
 68 + 
 69 + data GraphInfo = GraphInfo {
 70 +       graph_name :: String
 71 +     , graph_appinfo :: AppInfo
 72 +     , graph_viewport :: Viewport
 73 +     , graph_samples :: Int
 74 +     , graph_resolution :: Int
 75 +     , graph_color :: GraphColor
 76 +     , graph_points :: Int
 77 +     , graph_scale :: (Float, Float)
 78 +     , graph_offset :: (Int, Int)
 79 +     }
 80 +   deriving (Show, Eq, Ord)
 81 + 
 82 + defaultCam :: Camera GLfloat
 83 + defaultCam = camera2D
 84 + 
 85 + defaultViewport :: Viewport
 86 + defaultViewport = (Position 0 0, Size 1920 1080)
 87 + 
 88 + defaultAppInfo :: AppInfo
 89 + defaultAppInfo = SField =: camMatrix defaultCam
 90 + 
 91 + defGI :: GraphInfo
 92 + defGI = GraphInfo {
 93 +       graph_name = "unnamed"
 94 +     , graph_appinfo = defaultAppInfo
 95 +     , graph_viewport = defaultViewport
 96 +     , graph_samples = 100
 97 +     , graph_resolution = 100
 98 +     , graph_color = Red
 99 +     , graph_points = 100
100 +     , graph_scale = (1, 1)
101 +     , graph_offset = (0, 0)
102 +    }
 1 @@ -0,0 +1,71 @@
 2 + module Graphics.Liveplot.Utils(
 3 +     dump
 4 +   , dbg
 5 +   , moveCam
 6 +   , cnf
 7 +   , cnfEndo
 8 +   , rpad
 9 +   ) where
10 + 
11 + import Prelude
12 + import Control.Concurrent.STM
13 + import Data.Monoid (All(..), Any(..))
14 + import Data.Foldable (Foldable, foldMap,foldl',fold)
15 + import Data.Set (Set)
16 + import qualified Data.Set as S
17 + 
18 + import Linear
19 + import MVC
20 + import Graphics.GLUtil.Camera2D
21 + import Graphics.GLUtil.Camera3D hiding (roll)
22 + import Graphics.UI.GLFW
23 + 
24 + dump :: View a
25 + dump = asSink (\_ -> return())
26 + 
27 + dbg :: (Show a) => View a
28 + dbg = asSink (\e -> (putStrLn $ show e) >> return())
29 + 
30 + -- | Evaluate a boolean formula in conjunctive normal form (CNF) by
31 + -- applying the predicate to each atom according to the logic of its
32 + -- nesting in the formula.
33 + cnf :: (Foldable s, Foldable t) => s (t Bool) -> Bool
34 + cnf = getAll . foldMap (All . getAny . foldMap Any)
35 + 
36 + -- | Perform a left fold over a set of guarded update functions,
37 + -- evaluating the guards left-to-right. For each guard that passes,
38 + -- its associated update function is composed into a final composite
39 + -- update function.
40 + cnfEndo :: (k -> s -> Bool) -> (k -> s -> s) -> [([[k]], a -> a)] -> s -> a -> a
41 + cnfEndo p del = go
42 +   where go [] _ = id
43 +         go ((k,f):fs) s | cnf (fmap (fmap (`p` s)) k) = go fs (delAll k s) . f
44 +                         | otherwise = go fs s
45 +         delAll k s = foldl' (flip del) s (fold k)
46 + 
47 + -- | Translate and rotate a 'Camera' based on 'UI' input.
48 + moveCam :: (Conjugate a, Epsilon a, RealFloat a) => Set Key -> Camera a -> Camera a
49 + moveCam keys = cnfEndo S.member S.delete 
50 +                   [ ([shift, [Key'Left]], roll na)
51 +                   , ([shift, [Key'Right]], roll pa)
52 +                   , ([[Key'Left]], track (V2 np 0))
53 +                   , ([[Key'Right]], track (V2 pp 0))
54 +                   , ([[Key'Up]], track (V2 0 pp))
55 +                   , ([[Key'Down]], track (V2 0 np))
56 +                   --- XXX: tilting instead of zooming, how to zoom in 2d with cam?
57 +                   -- maybe just switch to 3d cam
58 +                   , ([[Key'PageUp]], tilt (pa))
59 +                   , ([[Key'PageDown]], tilt (na))
60 +                   ]
61 +                   keys
62 +   where shift = [Key'LeftShift, Key'RightShift]
63 +         -- XXX: pass timeScale as well? (Normalize speeds to 60Hz update)
64 +         timeScale = 1 -- realToFrac $ timeStep ui * 60
65 +         pp = 0.08 * timeScale -- 1D speed
66 +         np = negate pp
67 +         pa = 2 * timeScale    -- angular step
68 +         na = negate pa
69 + 
70 + 
71 + rpad :: Int -> a -> [a] -> [a]
72 + rpad n x xs = xs ++ (take (n-(length xs)) $ repeat x)
  1 @@ -0,0 +1,201 @@
  2 + {-# LANGUAGE ScopedTypeVariables #-}
  3 + {-# LANGUAGE Rank2Types #-}
  4 + {-# LANGUAGE FlexibleContexts #-}
  5 + module Graphics.Liveplot.Window where
  6 + 
  7 + import Prelude hiding (init)
  8 + import Control.Monad
  9 + import Control.Lens ((^.), contains, _Left, _Right)
 10 + import Data.IORef
 11 + import Data.Maybe (isNothing)
 12 + import Data.Set (Set)
 13 + import qualified Data.Set as S
 14 + import Data.Time.Clock
 15 + import Graphics.UI.GLFW
 16 + import Linear
 17 + -- moi
 18 + import MVC
 19 + import qualified MVC.Prelude as MVC
 20 + import Graphics.Rendering.OpenGL
 21 + import Graphics.GLUtil.Camera2D
 22 + import Data.Vinyl
 23 + 
 24 + import Control.Concurrent (threadDelay)
 25 + import Control.Concurrent.STM
 26 + 
 27 + import Pipes.Extras ((+++))
 28 + 
 29 + import Graphics.Liveplot.Types
 30 + import Graphics.Liveplot.Utils
 31 + --- XXX: this has something to do with orphan instance in G.L.Line
 32 + import Graphics.Liveplot.Line
 33 + 
 34 + initGraph :: String -> (Float, Float) -> (Int, Int)-> GraphInfo
 35 + initGraph name scale' offset = defGI {
 36 +       graph_name = name
 37 +     , graph_offset = offset
 38 +     , graph_scale = scale'
 39 +     }
 40 + 
 41 + lineGraph :: String -> (Float, Float) -> (Int, Int) -> (GraphInfo, GLfloat)
 42 + lineGraph name scale' offset = (defGI
 43 +   { graph_name = name
 44 +   , graph_offset = offset
 45 +   , graph_scale = scale'
 46 +   }, 0)
 47 + 
 48 + -- add scroll input callback
 49 + -- http://www.glfw.org/docs/latest/input_guide.html#scrolling
 50 + ogl :: (Plottable a) => [(GraphInfo, a)]
 51 +        -> Managed (View (Either (SensorReading a) GLApp), Controller Event)
 52 + ogl parts = join $ managed $ \k -> do
 53 +   let simpleErrorCallback e s = putStrLn $ unwords [show e, show s]
 54 +   let width = 600
 55 +       height = 300
 56 +       windowTitle = "lala"
 57 +   setErrorCallback $ Just simpleErrorCallback
 58 +   r <- init
 59 +   when (not r) (error "Error initializing GLFW!")
 60 + 
 61 +   windowHint $ WindowHint'ClientAPI ClientAPI'OpenGL
 62 +   windowHint $ WindowHint'OpenGLForwardCompat True
 63 +   windowHint $ WindowHint'OpenGLProfile OpenGLProfile'Core
 64 +   windowHint $ WindowHint'ContextVersionMajor 3
 65 +   windowHint $ WindowHint'ContextVersionMinor 3
 66 + 
 67 +   m@(~(Just w)) <- createWindow width height windowTitle Nothing Nothing
 68 +   when (isNothing m) (error "Couldn't create window!")
 69 + 
 70 +   makeContextCurrent m
 71 + 
 72 +   kbState <- newIORef S.empty
 73 +   mbState <- newIORef S.empty
 74 +   mpState <- getCursorPos w >>= newIORef . uncurry V2
 75 +   wsState <- getWindowSize w >>= newIORef . uncurry V2
 76 +   lastTick <- getCurrentTime >>= newIORef
 77 +   setKeyCallback w (Just $ keyCallback kbState)
 78 +   setMouseButtonCallback w (Just $ mbCallback mbState)
 79 +   setCursorPosCallback w (Just $ mpCallback mpState)
 80 +   setWindowSizeCallback w $ Just $ \win x y -> do
 81 +     wsCallback wsState win x y
 82 +     viewport $= (Position 0 0, Size (fromIntegral x) (fromIntegral y))
 83 + 
 84 +   blend $= Enabled
 85 +   blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
 86 + 
 87 +   redraw <- atomically $ newTVar $ Just True
 88 + 
 89 +   inits <- flip mapM parts $ \(gi, (_init :: a)) -> initplot gi :: IO (PlotInit a)
 90 +   graphInfoTVars <- flip mapM parts $ \(gi, (_init :: a)) -> atomically $ newTVar gi -- :: IO (PlotInit a)
 91 +   --graphInfoTVars <- mapM (pure $ atomically $ newTVar defGI) parts
 92 +   let (dataTVars, storefns, drawfns) = unzip3 inits
 93 +   let tvars = zip dataTVars graphInfoTVars
 94 + 
 95 +   let setRedraw =  atomically $ writeTVar redraw $ Just True
 96 +   let resetRedraw =  atomically $ writeTVar redraw $ Nothing
 97 + 
 98 +   let tick = do pollEvents
 99 +                 t <- getCurrentTime
100 +                 dt <- realToFrac . diffUTCTime t <$> readIORef lastTick
101 +                 writeIORef lastTick t
102 + 
103 +                 keys <- readIORef kbState
104 +                 buttons <- readIORef mbState
105 +                 pos <- readIORef mpState
106 +                 wsize <- readIORef wsState
107 + 
108 +                 mredraw <- readTVarIO redraw
109 +                 case mredraw of
110 +                   Nothing -> threadDelay 100 >> return ()
111 +                   Just _ -> do
112 +                     clear [ColorBuffer, DepthBuffer]
113 +                     zipWithM_ (\draw (tvar, gtvar) -> do
114 +                       mdat <- readTVarIO tvar
115 +                       gi <- readTVarIO gtvar
116 +                       draw mdat gi
117 +                       ) drawfns tvars
118 +                     swapBuffers w
119 +                     threadDelay 10
120 +                     resetRedraw
121 + 
122 + 
123 +                 -- XXX: emit only changing values except for timestep?
124 +                 return $ [
125 +                     Timestep dt
126 +                   , Keys keys
127 +                   , Buttons buttons
128 +                   , MousePos pos
129 +                   , WinSize wsize
130 +                   ]
131 + 
132 +   let steptick :: Producer Event IO ()
133 +       steptick = forever $ lift tick >>= mapM_ yield
134 + 
135 +   let handleAppInfo :: View (GLApp)
136 +       handleAppInfo = asSink $ \(GLApp ai vp) -> do
137 +         let updategi = \x -> x {
138 +                 graph_appinfo = ai
139 +               , graph_viewport = vp
140 +               }
141 +         mapM_ (\v -> atomically $ modifyTVar v updategi) graphInfoTVars
142 +         setRedraw
143 + 
144 +   --let handleData :: (Plottable a) => View (SensorReading a)
145 +   let
146 +       handleData = asSink $ \dat -> do
147 +         mapM_ ($ dat) storefns
148 +         setRedraw
149 + 
150 +   k $ do
151 +     -- Event producer and drawing function
152 +     evts <- MVC.producer (bounded 1) (steptick)
153 +     -- Data and AppInfo handlers
154 +     let hdat = handles _Left handleData
155 +         hapi = handles _Right handleAppInfo
156 + 
157 +     return (hapi <> hdat, evts)
158 + 
159 + -- transform AppInfo and camera according to events from OpenGL
160 + campipe :: (Monad m)
161 +         => AppInfo
162 +         -> Camera GLfloat
163 +         -> Viewport
164 +         -> MVC.Proxy () (Event) () (GLApp) m ()
165 + campipe initai initcam initviewport = go initai initcam initviewport
166 +   where
167 +     fwd ai c vp = yield (GLApp ai vp) >> go ai c vp
168 +     go ai c vp = do
169 +       evt <- await
170 +       case evt of
171 +         Keys k | k ^. contains Key'Escape -> return ()
172 +                | k ^. contains Key'Q -> return ()
173 +                | otherwise -> do
174 +                    let newCam = moveCam k c
175 +                    let newAi = SField =: (camMatrix newCam)
176 +                    fwd newAi newCam vp
177 + 
178 +         WinSize (V2 sx sy) -> fwd ai c (fst vp, Size (fromIntegral sx) (fromIntegral sy))
179 +         _ -> go ai c vp
180 + 
181 + defaultCamPipe :: Monad m => MVC.Proxy () (Event) () (GLApp) m ()
182 + defaultCamPipe = campipe defaultAppInfo defaultCam defaultViewport
183 + 
184 + defaultPipe :: forall m a . (Monad m, Plottable a)
185 +     => Pipe (Either (SensorReading a) Event)
186 +             (Either (SensorReading a) GLApp) m ()
187 + defaultPipe = cat +++ defaultCamPipe
188 + 
189 + keyCallback :: IORef (Set Key) -> KeyCallback
190 + keyCallback keys _w k _ KeyState'Pressed _mods = modifyIORef' keys (S.insert k)
191 + keyCallback keys _w k _ KeyState'Released _mods = modifyIORef' keys (S.delete k)
192 + keyCallback _ _ _ _ _ _ = return ()
193 + 
194 + mbCallback :: IORef (Set MouseButton) -> MouseButtonCallback
195 + mbCallback mbs _w b MouseButtonState'Pressed _ = modifyIORef' mbs (S.insert b)
196 + mbCallback mbs _w b MouseButtonState'Released _ = modifyIORef' mbs (S.delete b)
197 + 
198 + mpCallback :: IORef (V2 Double) -> CursorPosCallback
199 + mpCallback mp _w x y = writeIORef mp (V2 x y)
200 + 
201 + wsCallback :: IORef (V2 Int) -> WindowSizeCallback
202 + wsCallback ws _w w h = writeIORef ws (V2 w h)
 1 @@ -0,0 +1,45 @@
 2 + # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html
 3 + 
 4 + # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
 5 + resolver: lts-8.9
 6 + 
 7 + # Local packages, usually specified by relative directory name
 8 + packages:
 9 + - '.'
10 + - location:
11 +     git: 'https://git.48.io/andromeda/'
12 +     commit: 26e8e1a5fcd5e3359dba6834fd4d929e92483c58
13 +   extra-dep: true
14 + - location:
15 +     git: 'https://git.48.io/mvc/'
16 +     commit: bf1401391096ebfa3089d8f4de2141d2c21ddea7
17 +   extra-dep: true
18 + 
19 + # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
20 + extra-deps:
21 + - GLUtil-0.9.1.1
22 + - serialport-0.4.6
23 + - vinyl-gl-0.3.0.1
24 +   #- mvc-1.1.3
25 + - Vec-1.0.5
26 + 
27 + # Override default flag values for local packages and extra-deps
28 + flags: {}
29 + 
30 + # Extra package databases containing global packages
31 + extra-package-dbs: []
32 + 
33 + # Require a specific version of stack, using version ranges
34 + # require-stack-version: -any # Default
35 + # require-stack-version: >= 1.0.0
36 + 
37 + # Override the architecture used by stack, especially useful on Windows
38 + # arch: i386
39 + # arch: x86_64
40 + 
41 + # Extra directories used by stack for building
42 + # extra-include-dirs: [/path/to/dir]
43 + # extra-lib-dirs: [/path/to/dir]
44 + 
45 + # Allow a newer minor version of GHC than the snapshot specifies
46 + # compiler-check: newer-minor