dd19df8149e27765350b3e4f6dfffe1d88c948d3 — Jack Kelly a month ago 4161ae9 master
Remove reflex-gl-demo (send to qfpl)
27 files changed, 0 insertions(+), 988 deletions(-)

D reflex-gl-demo/.dir-locals.el
D reflex-gl-demo/CHANGELOG.md
D reflex-gl-demo/LICENCE
D reflex-gl-demo/Setup.hs
D reflex-gl-demo/bin/Main.hs
D reflex-gl-demo/dat/fragment.glsl
D reflex-gl-demo/dat/vertex.glsl
D reflex-gl-demo/default.nix
D reflex-gl-demo/doctest/Main.hs
D reflex-gl-demo/nix/codex.json
D reflex-gl-demo/nix/codex.nix
D reflex-gl-demo/nix/nixpkgs.nix
D reflex-gl-demo/nix/reflex-basic-host.json
D reflex-gl-demo/nix/reflex-basic-host.nix
D reflex-gl-demo/reflex-gl-demo.cabal
D reflex-gl-demo/reflex-gl-demo.nix
D reflex-gl-demo/shell.nix
D reflex-gl-demo/src/App.hs
D reflex-gl-demo/src/BufferObject.hs
D reflex-gl-demo/src/Camera.hs
D reflex-gl-demo/src/Data/Clamped.hs
D reflex-gl-demo/src/Data/Wraparound.hs
D reflex-gl-demo/src/Reflex/FSNotify.hs
D reflex-gl-demo/src/Shader.hs
D reflex-gl-demo/src/Uniform.hs
D reflex-gl-demo/src/VertexArray.hs
D reflex-gl-demo/talk-blurb.md
D reflex-gl-demo/.dir-locals.el => reflex-gl-demo/.dir-locals.el +0 -7
@@ 1,7 0,0 @@-(("src" . ((nil . ((dante-target . "lib:reflex-gl-demo")))))
-  ("app" . ((nil . ((dante-target . "exe:reflex-gl-demo")))))
-  ("doctest" . ((nil . ((dante-target . "doctest")))))
-  ;("test" . ((nil . ((dante-target . "codeworld-raycaster-test")))))
-  (nil . ((dante-repl-command-line
-           . ("nix-shell" "--run"
- (concat "cabal new-repl " dante-target " --builddir=dist/dante"))))))

D reflex-gl-demo/CHANGELOG.md => reflex-gl-demo/CHANGELOG.md +0 -5
@@ 1,5 0,0 @@-# Revision history for reflex-gl-demo
- 
- ## 0.1.0.0 -- 2019-09-02
- 
- * First version. Released on an unsuspecting world.

D reflex-gl-demo/LICENCE => reflex-gl-demo/LICENCE +0 -31
@@ 1,31 0,0 @@-Copyright (c) 2019, Commonwealth Scientific and Industrial Research Organisation
- (CSIRO) ABN 41 687 119 230.
- 
- 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 Data61 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.

D reflex-gl-demo/Setup.hs => reflex-gl-demo/Setup.hs +0 -2
@@ 1,2 0,0 @@-import Distribution.Simple
- main = defaultMain

D reflex-gl-demo/bin/Main.hs => reflex-gl-demo/bin/Main.hs +0 -3
@@ 1,3 0,0 @@-module Main (main) where
- 
- import App (main)

D reflex-gl-demo/dat/fragment.glsl => reflex-gl-demo/dat/fragment.glsl +0 -8
@@ 1,8 0,0 @@-#version 410
- 
- in vec3 color;
- out vec4 frag_color;
- 
- void main() {
-   frag_color = vec4(color, 1.0);
- }

D reflex-gl-demo/dat/vertex.glsl => reflex-gl-demo/dat/vertex.glsl +0 -10
@@ 1,10 0,0 @@-#version 410
- 
- in vec3 vp;
- uniform mat4 proj;
- out vec3 color;
- 
- void main() {
-   gl_Position = proj * vec4(vp, 1.0);
-   color = vec3((vp.x + 6)/12, (vp.y + 10)/20, 0.5);
- }

D reflex-gl-demo/default.nix => reflex-gl-demo/default.nix +0 -36
@@ 1,36 0,0 @@-{ nixpkgs ? import ./nix/nixpkgs.nix {}
- , compiler ? "default"
- , doBenchmark ? false
- }:
- 
- let
-   inherit (nixpkgs) pkgs;
- 
-   codex = import ./nix/codex.nix;
- 
-   baseHaskellPackages = if compiler == "default"
-                        then pkgs.haskellPackages
-                        else pkgs.haskell.packages.${compiler};
- 
-   haskellPackages = baseHaskellPackages.override {
-     overrides = self: super: with pkgs.haskell.lib; {
-       reflex = overrideCabal super.reflex (drv: {
-         broken = false;
-         doCheck = false;
-       });
- 
-       reflex-sdl2 = overrideCabal super.reflex-sdl2 (drv: {
-         broken = false;
-         jailbreak = true;
-       });
- 
-       glow = super.callCabal2nix "glow" "${codex}/glow" {};
-       ptrdiff = super.callCabal2nix "ptrdiff" "${codex}/ptrdiff" {};
-       reflex-basic-host = super.callCabal2nix "reflex-basic-host"
-         (import ./nix/reflex-basic-host.nix) {};
-     };
-   };
- 
-   variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
- in
-   variant (haskellPackages.callPackage ./reflex-gl-demo.nix {})

D reflex-gl-demo/doctest/Main.hs => reflex-gl-demo/doctest/Main.hs +0 -6
@@ 1,6 0,0 @@-module Main where
- 
- import Test.DocTest
- 
- main :: IO ()
- main = doctest ["-isrc", "src/Data/Clamped.hs", "src/Data/Wraparound.hs"]

D reflex-gl-demo/nix/codex.json => reflex-gl-demo/nix/codex.json +0 -7
@@ 1,7 0,0 @@-{
-   "url": "https://github.com/ekmett/codex",
-   "rev": "9e6f74454fa727e16cf1fb3fd812fa675face601",
-   "date": "2019-06-19T17:32:13+02:00",
-   "sha256": "1pg827wnmd6kmq0ywa0mqvvm374nkzqy4n90cg30xsqak8m3dpzr",
-   "fetchSubmodules": false
- }

D reflex-gl-demo/nix/codex.nix => reflex-gl-demo/nix/codex.nix +0 -9
@@ 1,9 0,0 @@-let
-   codexPin = builtins.fromJSON (builtins.readFile ./codex.json);
- 
-   codex = builtins.fetchGit {
-     inherit (codexPin) url rev;
-     ref = "master";
-   };
- in
-   codex

D reflex-gl-demo/nix/nixpkgs.nix => reflex-gl-demo/nix/nixpkgs.nix +0 -4
@@ 1,4 0,0 @@-import (fetchTarball {
-   url = "https://github.com/NixOS/nixpkgs/archive/b7347338e2729ab5b85f49e632b56661ae06a7a2.tar.gz";
-   sha256 = "14brxlbbc1lq8rgizlwksv6m1vpy6r8bp4vl72s9l2c1jn34f1fn";
- })

D reflex-gl-demo/nix/reflex-basic-host.json => reflex-gl-demo/nix/reflex-basic-host.json +0 -7
@@ 1,7 0,0 @@-{
-   "url": "https://github.com/qfpl/reflex-basic-host",
-   "rev": "8526a9ca34e652dbc7bbb6202a770cd373a230bd",
-   "date": "2019-06-28T10:13:47+10:00",
-   "sha256": "1cizchnlwqxzjwyqgrdmn6847sbdfr5ghlrqdm7jsqvi67d2apcl",
-   "fetchSubmodules": false
- }

D reflex-gl-demo/nix/reflex-basic-host.nix => reflex-gl-demo/nix/reflex-basic-host.nix +0 -10
@@ 1,10 0,0 @@-let
-   reflex-basic-hostPin = builtins.fromJSON
-     (builtins.readFile ./reflex-basic-host.json);
- 
-   reflex-basic-host = builtins.fetchGit {
-     inherit (reflex-basic-hostPin) url rev;
-     ref = "master";
-   };
- in
-   reflex-basic-host

D reflex-gl-demo/reflex-gl-demo.cabal => reflex-gl-demo/reflex-gl-demo.cabal +0 -67
@@ 1,67 0,0 @@-cabal-version:       2.0
- name:                reflex-gl-demo
- version:             0.1.0.0
- synopsis:            Wire Reflex and OpenGL together
- license:             BSD3
- license-file:        LICENCE
- author:              Jack Kelly
- maintainer:          jack.kelly@data61.csiro.au
- copyright:           Copyright (c) 2019, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230.
- category:            Game
- build-type:          Simple
- extra-source-files:  CHANGELOG.md
- 
- library
-   exposed-modules:     App
-                      , BufferObject
-                      , Camera
-                      , Data.Clamped
-                      , Data.Wraparound
-                      , Reflex.FSNotify
-                      , Shader
-                      , Uniform
-                      , VertexArray
-   ghc-options:         -Wall
-   build-depends:       base ^>= 4.12
-                      , GLFW-b ^>= 3.2.1
-                      , StateVar ^>= 1.1.1.1
-                      , bytestring ^>= 0.10.8.2
-                      , containers ^>= 0.6.0.1
-                      , dependent-map ^>= 0.2.4
-                      , dependent-sum ^>= 0.4
-                      , dependent-sum-template ^>= 0.0.0.6
-                      , directory ^>= 1.3.3.0
-                      , fsnotify ^>= 0.3.0.1
-                      , gl ^>= 0.8
-                      , glow ^>= 0
-                      , lens ^>= 4.17.1
-                      , linear ^>= 1.20.9
-                      , mtl ^>= 2.2.2
-                      , path ^>= 0.6.1
-                      , ref-tf ^>= 0.4.0.1
-                      , reflex ^>= 0.6
-                      , reflex-basic-host ^>= 0.2
-                      , these ^>= 0.7.6
-                      , time ^>= 1.8.0.2
-                      , witherable ^>= 0.3.1
-   hs-source-dirs:      src
-   default-language:    Haskell2010
- 
- executable reflex-gl-demo
-   main-is:             Main.hs
-   ghc-options:         -Wall -threaded
-   build-depends:       base ^>= 4.12
-                      , reflex-gl-demo
-   hs-source-dirs:      bin
-   default-language:    Haskell2010
- 
- test-suite doctests
-   type:                exitcode-stdio-1.0
-   main-is:             Main.hs
-   ghc-options:         -Wall -threaded
-   build-depends:       base ^>= 4.12
-                      , QuickCheck ^>= 2.12.6.1
-                      , reflex-gl-demo
-                      , doctest ^>= 0.16.0.1
-   hs-source-dirs:      doctest
-   default-language:    Haskell2010

D reflex-gl-demo/reflex-gl-demo.nix => reflex-gl-demo/reflex-gl-demo.nix +0 -23
@@ 1,23 0,0 @@-{ mkDerivation, base, bytestring, containers, dependent-map
- , dependent-sum, dependent-sum-template, directory, doctest
- , fsnotify, gl, GLFW-b, glow, lens, linear, mtl, path, QuickCheck
- , ref-tf, reflex, reflex-basic-host, StateVar, stdenv, these, time
- , witherable
- }:
- mkDerivation {
-   pname = "reflex-gl-demo";
-   version = "0.1.0.0";
-   src = ./.;
-   isLibrary = true;
-   isExecutable = true;
-   libraryHaskellDepends = [
-     base bytestring containers dependent-map dependent-sum
-     dependent-sum-template directory fsnotify gl GLFW-b glow lens
-     linear mtl path ref-tf reflex reflex-basic-host StateVar these time
-     witherable
-   ];
-   executableHaskellDepends = [ base ];
-   testHaskellDepends = [ base doctest QuickCheck ];
-   description = "Wire Reflex and OpenGL together";
-   license = stdenv.lib.licenses.bsd3;
- }

D reflex-gl-demo/shell.nix => reflex-gl-demo/shell.nix +0 -13
@@ 1,13 0,0 @@-{ nixpkgs ? import ./nix/nixpkgs.nix {}
- , compiler ? "default"
- , doBenchmark ? false
- }:
- let
-   inherit (nixpkgs) pkgs;
-   env = (import ./default.nix { inherit nixpkgs compiler doBenchmark; }).env;
- in
-   env.overrideAttrs (oldAttrs: {
-     buildInputs = with pkgs.haskellPackages; oldAttrs.buildInputs ++ [
-       cabal-install cabal2nix ghcid
-     ];
-   })

D reflex-gl-demo/src/App.hs => reflex-gl-demo/src/App.hs +0 -241
@@ 1,241 0,0 @@-{-# LANGUAGE FlexibleContexts    #-}
- {-# LANGUAGE LambdaCase          #-}
- {-# LANGUAGE OverloadedLists     #-}
- {-# LANGUAGE OverloadedStrings   #-}
- {-# LANGUAGE QuasiQuotes         #-}
- {-# LANGUAGE RecursiveDo         #-}
- {-# LANGUAGE ScopedTypeVariables #-}
- {-# LANGUAGE TypeFamilies        #-}
- 
- module App where
- 
- import           Prelude hiding (filter)
- 
- import           BufferObject
- import           Camera
- import           Shader
- import           Uniform
- import           VertexArray
- 
- import           Control.Lens.Operators
- import           Control.Monad (unless)
- import           Control.Monad.IO.Class (MonadIO(..))
- import           Control.Monad.Ref (modifyRef, newRef, readRef)
- import           Data.Bits ((.|.))
- import           Data.Dependent.Sum ((==>))
- import           Data.Foldable (for_, traverse_)
- import           Data.Functor (($>))
- import           Data.Functor.Misc (Const2(..))
- import           Data.List (genericLength)
- import           Data.List.NonEmpty (NonEmpty(..), nonEmpty)
- import           Data.Map (Map)
- import qualified Data.Map as Map
- import           Data.StateVar (($~), ($=))
- import           Data.Traversable (for)
- import           Foreign.Ptr (nullPtr)
- import           Graphics.GL.Core45
- import           Graphics.GL.Types (GLenum, GLint, GLsizei)
- import qualified Graphics.Glow as Glow
- import           Graphics.Glow hiding (Program)
- import qualified Graphics.UI.GLFW as GLFW
- import           Linear (V2(..), V3(..), _xy)
- import           Path (parseAbsDir, relfile)
- import           Reflex
- import           Reflex.Host.Basic
- import           System.Directory (canonicalizePath)
- import           System.Exit (exitFailure)
- import qualified System.FSNotify as FS
- 
- main :: IO ()
- main = do
-   window <- setupGL
-   FS.withManager $ \manager -> basicHostWithQuit (guest window manager)
-   GLFW.terminate
- 
- guest
-   :: forall t m . BasicGuestConstraints t m
-   => GLFW.Window
-   -> FS.WatchManager
-   -> BasicGuest t m (Event t ())
- guest window manager = do
-   (quitE, quitF) <- newTriggerEvent
- 
-   eTick <- tickLossyFromPostBuildTime $ 1 / 60
-   ePumpedInputs <- performEventAsync $ eTick $> pumpInput window quitF
- 
-   -- Construct `bInputs`, a `Behavior (Map GLFW.Key ())` that has a value
-   -- at each key only for the keys currently being pressed.
-   --
-   -- This slightly strange structure lets us use `fanMap` later to
-   -- efficiently split out events for each key press.
-   let
-     toChange :: (GLFW.Key, GLFW.KeyState) -> Map GLFW.Key () -> Map GLFW.Key ()
-     toChange (k, GLFW.KeyState'Pressed) = Map.insert k ()
-     toChange (k, GLFW.KeyState'Released) = Map.delete k
-     toChange (_, GLFW.KeyState'Repeating) = id
- 
-     eInputChanges :: Event t (Map GLFW.Key () -> Map GLFW.Key ())
-     eInputChanges = foldr1 (.) . fmap toChange <$> ePumpedInputs
-   bInputs <- current <$> foldDyn ($) Map.empty eInputChanges
- 
-   -- We sample `bInputs` on each tick, and then use `fanMap` to get
-   -- events for each key that fire once per tick while they are held
-   -- down.
-   let
-     eInputs = bInputs <@ eTick
-     eInputSelector = fanMap eInputs
- 
-     key k = eInputSelector `select` Const2 k
- 
-     eForward = key GLFW.Key'W
-     eStrafeLeft = key GLFW.Key'A
-     eBack = key GLFW.Key'S
-     eStrafeRight = key GLFW.Key'D
-     eLeft = key GLFW.Key'Left
-     eRight = key GLFW.Key'Right
-     eUp = key GLFW.Key'Up
-     eDown = key GLFW.Key'Down
- 
-   -- Set up the camera. The `rec` block lets use the camera's position
-   -- and facing to determine the movement vectors, which we feed into
-   -- the camera config to geet the camera position. This is possible
-   -- due to laziness and `MonadFix` magic.
-   rec
-     let
-       moveSize = 0.1
-       -- `mkDynPure` is a Template Haskell QuasiQuoter that lets us
-       -- write complex expressions involving `Dynamic`s without having
-       -- to make a tangle of `Applicative` operators.
-       moveVec :: Float -> Dynamic t Vec2
-       moveVec offset = [mkDynPure|
-         moveSize * V2
-           (cos ($(cam ^. cdYaw) + offset))
-           (sin ($(cam ^. cdYaw) + offset))
-       |]
- 
-       eMoves = mergeWith (.) $ fmap (_xy +~) <$>
-         [ current (moveVec 0) <@ eForward
-         , current (moveVec pi) <@ eBack
-         , current (moveVec $ pi / 2) <@ eStrafeLeft
-         , current (moveVec $ 3 * pi / 2) <@ eStrafeRight
-         ]
-       ePitches = mergeWith (.)
-         [ eUp $> subtract 0.05
-         , eDown $> (+ 0.05)
-         ]
-       eYaws = mergeWith (.)
-         [ eLeft $> (+ 0.05)
-         , eRight $> subtract 0.05
-         ]
- 
-       camconf = CameraConfig (V3 (-20) 0 10) 0 0 ePitches eYaws eMoves
-     cam <- camera camconf
- 
-   let
-     haskellLogo :: [[Vec3]]
-     haskellLogo =
-       [ [ V3 0 0 0, V3 (-5) 5 0, V3 (-4) 5 0, V3 1 0 0 ]
-       , [ V3 0 0 0, V3 1 0 0, V3 (-4) (-5) 0, V3 (-5) (-5) 0 ]
-       , [ V3 7 (-5) 0, V3 (-3) 5 0, V3 (-2) 5 0, V3 8 (-5) 0 ]
-       , [ V3 2 0 0, V3 3 0 0, V3 (-2) (-5) 0, V3 (-3) (-5) 0 ]
-       , [ V3 2.5 1 0, V3 8 1 0, V3 8 0.5 0, V3 3 0.5 0 ]
-       , [ V3 3.5 0 0, V3 8 0 0, V3 8 (-0.5) 0, V3 4 (-0.5) 0 ]
-       ]
- 
-   -- Construct a vertex buffer for each row of points.
-   vertexBuffers <- for haskellLogo $ \points -> do
-     vbo <- bufferObject ArrayBufferTarget $ constDyn (StaticDraw, points)
-     pure (vbo, genericLength points)
- 
-   -- Construct the VAOs, which tell OpenGL how to use each VBO and
-   -- use their contents.
-   vaos <- for vertexBuffers $ \(vbo, _) -> vertexArray . constDyn $ Map.fromList
-     [ (0, (Just $ SomeBuffer vbo, Layout 3 GL_FLOAT False 0 nullPtr)) ]
- 
-   -- Build and link our shader program, and store it in `bmProg`.
-   dataDir <- liftIO $ canonicalizePath "dat" >>= parseAbsDir
-   eProg <- watchShaderProgram manager
-     dataDir [relfile|vertex.glsl|] [relfile|fragment.glsl|]
-   bmProg <- hold Nothing $ Just <$> eProg
- 
-   -- Build `bDraws`, our list of things to draw each frame. It is
-   -- sampled each time `eTick` fires and redrawn by `draw`.
-   let
-     bDraws :: Behavior t [Draw]
-     bDraws = do
-       matrix <- current $ cam ^. cdProjectionMatrix
-       mProg <- bmProg
-       -- Draw from each VAO, using the length of each VBO.
-       let drawWithProgram p = zip vaos vertexBuffers <&> \(vao, (_, size)) ->
-             Draw
-               p
-               vao
-               (Map.fromList [("proj", Mat4 ==> matrix)])
-               GL_TRIANGLE_FAN
-               0
-               size
- 
-       pure $ foldMap drawWithProgram mProg
-   draw window $ bDraws <@ eTick
- 
-   pure quitE
- 
- data Draw = Draw Glow.Program Glow.VertexArray Uniforms GLenum GLint GLsizei
- 
- setupGL :: IO GLFW.Window
- setupGL = do
-   ok <- GLFW.init
-   unless ok $ putStrLn "GLFW init failed" *> exitFailure
- 
-   traverse_ GLFW.windowHint
-     ([ GLFW.WindowHint'ClientAPI GLFW.ClientAPI'OpenGL
-      , GLFW.WindowHint'ContextVersionMajor 4
-      , GLFW.WindowHint'ContextVersionMinor 1
-      , GLFW.WindowHint'OpenGLForwardCompat True
-      , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
-      ] :: [GLFW.WindowHint])
- 
-   win <- GLFW.createWindow 800 600 "Hello Compose!" Nothing Nothing >>= \case
-     Nothing ->
-       putStrLn "GLFW createWindow failed" *> GLFW.terminate *> exitFailure
-     Just win -> GLFW.makeContextCurrent (Just win) $> win
- 
-   glEnable GL_DEPTH_TEST
-   stateBits $~ depthFunc .~ DepthFuncLEqual
- 
-   pure win
- 
- -- | Poll OpenGL for events, and fire the relevant reflex event
- -- triggers.
- pumpInput
-   :: MonadIO m
-   => GLFW.Window
-   -> (() -> IO ()) -- ^ Trigger quit event
-   -> (NonEmpty (GLFW.Key, GLFW.KeyState) -> IO ()) -- ^ Trigger input event
-   -> m ()
- pumpInput window triggerQuit triggerInput = liftIO $ do
-   shouldQuit <- GLFW.windowShouldClose window
-   if shouldQuit
-     then triggerQuit ()
-     else liftIO $ newRef [] >>= \keysR -> do
-       let keyCallback _ key _ state _ =
-             modifyRef keysR ((key, state):)
-       GLFW.setKeyCallback window . Just $ keyCallback
-       GLFW.pollEvents
-       readRef keysR >>= \keys ->
-         traverse_ triggerInput (nonEmpty $ reverse keys)
- 
- -- | Redraw the screen with a new '[Draw]' each time it fires.
- draw
-   :: (MonadIO m, PerformEvent t m, MonadIO (Performable m), Reflex t)
-   => GLFW.Window
-   -> Event t [Draw]
-   -> m ()
- draw win eDraws = performEvent_ $ eDraws <&> \draws ->
-   liftIO $ do
-     glClear $ GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT
-     for_ draws $ \(Draw prog vao uni prim start n) -> do
-       currentProgram $= prog
-       applyUniforms prog uni
-       withVertexArray vao $ glDrawArrays prim start n
-     GLFW.swapBuffers win

D reflex-gl-demo/src/BufferObject.hs => reflex-gl-demo/src/BufferObject.hs +0 -37
@@ 1,37 0,0 @@-{-# LANGUAGE FlexibleContexts #-}
- 
- module BufferObject (bufferObject) where
- 
- import           Control.Monad.IO.Class (MonadIO(..))
- import           Data.Functor ((<&>))
- import           Data.StateVar (($=))
- import           Graphics.Glow (Buffer, BufferData, BufferTarget, BufferUsage)
- import qualified Graphics.Glow as Glow
- import           Reflex
- 
- -- | Create a buffer object, fed by a 'Dynamic'. The input 'Dynamic'
- -- is sampled on construction, and its updates cause the entire buffer
- -- to be repopulated.
- bufferObject
-   :: ( BufferData a
-      , MonadIO m
-      , MonadIO (Performable m)
-      , MonadSample t m
-      , PerformEvent t m
-      )
-   => BufferTarget
-   -> Dynamic t (BufferUsage, a)
-   -> m (Buffer a)
- bufferObject target dXs = do
-   buf <- Glow.gen
- 
-   -- Populate the buffer
-   initialXs <- sample $ current dXs
-   liftIO . Glow.withBoundBufferAt target buf $
-     Glow.bufferData target $= initialXs
- 
-   -- Update the buffer
-   performEvent_ $ updated dXs <&> \xs -> liftIO $
-     Glow.withBoundBufferAt target buf $ Glow.bufferData target $= xs
- 
-   pure buf

D reflex-gl-demo/src/Camera.hs => reflex-gl-demo/src/Camera.hs +0 -78
@@ 1,78 0,0 @@-{-# LANGUAGE GADTs               #-}
- {-# LANGUAGE QuasiQuotes         #-}
- {-# LANGUAGE ScopedTypeVariables #-}
- {-# LANGUAGE TemplateHaskell     #-}
- {-# LANGUAGE ViewPatterns        #-}
- 
- module Camera where
- 
- import Control.Lens (over, view)
- import Control.Lens.Operators
- import Control.Lens.TH (makeLenses)
- import Control.Monad.Fix (MonadFix)
- import Data.Clamped (clamped, mkClamped)
- import Data.Wraparound (mkWraparound, wraparound)
- import Graphics.Glow (Mat4, Vec3)
- import Linear.Matrix ((!*!))
- import Linear.Projection (lookAt, perspective)
- import Linear.Quaternion (axisAngle, rotate)
- import Linear.V3 (V3(..), cross)
- import Reflex
- 
- data CameraConfig t = CameraConfig
-   { _ccInitialEye :: Vec3
-   , _ccInitialPitch :: Float
-   , _ccInitialYaw :: Float
-   , _ccePitch :: Event t (Float -> Float)
-   , _cceYaw :: Event t (Float -> Float)
-   , _cceTranslate :: Event t (Vec3 -> Vec3)
-   }
- 
- $(makeLenses ''CameraConfig)
- 
- data Camera t = Camera
-   { _cdEye :: Dynamic t Vec3
-   , _cdFocus :: Dynamic t Vec3
-   , _cdPitch :: Dynamic t Float
-   , _cdYaw :: Dynamic t Float
-   , _cdProjectionMatrix :: Dynamic t Mat4
-   }
- 
- $(makeLenses ''Camera)
- 
- camera
-   :: forall t m . (MonadFix m, MonadHold t m, Reflex t)
-   => CameraConfig t
-   -> m (Camera t)
- camera cc = do
-   dEye <- foldDyn ($) (_ccInitialEye cc) $ _cceTranslate cc
- 
-   dPitch <- foldDyn ($)
-     (mkClamped (negate (pi / 2 - 0.01)) (pi / 2 - 0.01) $ _ccInitialPitch cc)
-     (over clamped <$> _ccePitch cc)
- 
-   dYaw <- foldDyn ($) (mkWraparound 0 (2 * pi) $ _ccInitialYaw cc) $
-     over wraparound <$> _cceYaw cc
- 
-   let
-     up = V3 0 0 1 :: Vec3
-     dYawQ = axisAngle up . view wraparound <$> dYaw
- 
-     dPitchAxis = dYaw <&>
-       cross up . (\(view wraparound -> yaw) -> V3 (cos yaw) (sin yaw) 0)
-     dPitchQ = axisAngle <$> dPitchAxis <*> (view clamped <$> dPitch)
- 
-     dFocus :: Dynamic t Vec3
-     dFocus = [mkDynPure| $dEye + rotate ($dPitchQ * $dYawQ) (V3 1 0 0) |]
- 
-     dViewMatrix :: Dynamic t Mat4
-     dViewMatrix = lookAt <$> dEye <*> dFocus <*> pure up
- 
-     perspectiveMatrix = perspective (pi/3) (640/480) 1 100
- 
-   pure $ Camera
-     dEye
-     dFocus
-     (view clamped <$> dPitch)
-     (view wraparound <$> dYaw)
-     ((perspectiveMatrix !*!) <$> dViewMatrix)

D reflex-gl-demo/src/Data/Clamped.hs => reflex-gl-demo/src/Data/Clamped.hs +0 -29
@@ 1,29 0,0 @@-module Data.Clamped (Clamped, clamped, mkClamped) where
- 
- import Control.Lens (Lens')
- 
- -- $setup
- -- >>> import Control.Lens ((^.), (.~))
- -- >>> import Data.Function ((&))
- 
- data Clamped a = Clamped a a a
- 
- -- | Lens into the clamped value. Writes through the lens are clamped.
- --
- -- prop> (lo :: Int) < hi ==> (mkClamped lo hi a & clamped .~ b) ^. clamped >= lo
- -- prop> (lo :: Int) < hi ==> (mkClamped lo hi a & clamped .~ b) ^. clamped <= hi
- clamped :: Ord a => Lens' (Clamped a) a
- clamped f (Clamped lo hi a) = Clamped lo hi . clamp lo hi <$> f a
- 
- -- | Create a clamped value.
- --
- -- prop> (lo :: Int) < hi ==> mkClamped lo hi a ^. clamped >= lo
- -- prop> (lo :: Int) < hi ==> mkClamped lo hi a ^. clamped <= hi
- mkClamped :: Ord a => a -> a -> a -> Clamped a
- mkClamped lo hi a = Clamped lo hi $ clamp lo hi a
- 
- clamp :: Ord a => a -> a -> a -> a
- clamp lo hi a
-   | a < lo = lo
-   | a > hi = hi
-   | otherwise = a

D reflex-gl-demo/src/Data/Wraparound.hs => reflex-gl-demo/src/Data/Wraparound.hs +0 -47
@@ 1,47 0,0 @@-module Data.Wraparound where
- 
- import Control.Lens (Lens')
- 
- -- $setup
- -- >>> import Control.Lens ((^.), (.~))
- -- >>> import Data.Function ((&))
- -- >>> import Test.QuickCheck
- 
- -- | Like a 'Data.Clamped.Clamped' value, but if you go off either end
- -- you wrap around and come in on the other side.
- data Wraparound a = Wraparound a a a
- 
- -- | Lens into the wrapping value. Writes through the lens wrap around.
- --
- -- >>> :{
- --   quickCheck $ \lo hi a b n -> (lo :: Int) < hi
- --     ==> (mkWraparound lo hi a & wraparound .~ b) ^. wraparound
- --     === (mkWraparound lo hi a & wraparound .~ (b + n * (hi - lo))) ^. wraparound
- -- :}
- -- +++ OK, passed 100 tests...
- wraparound :: (Num a, Ord a) => Lens' (Wraparound a) a
- wraparound f (Wraparound lo hi a) = Wraparound lo hi . wrap lo hi <$> f a
- 
- -- | Create a wrapping value.
- --
- -- Wraparounds are bounded by @lo@ and @hi@, just like 'Data.Clamped.Clamped':
- -- prop> (lo :: Int) < hi ==> mkWraparound lo hi a ^. wraparound >= lo
- -- prop> (lo :: Int) < hi ==> mkWraparound lo hi a ^. wraparound < hi
- --
- -- But they also loop around:
- -- >>> :{
- --   quickCheck $ \lo hi a n -> (lo :: Int) < hi
- --     ==> mkWraparound lo hi a ^. wraparound
- --     === mkWraparound lo hi (a + n * (hi - lo)) ^. wraparound
- -- :}
- -- +++ OK, passed 100 tests...
- mkWraparound :: (Num a, Ord a) => a -> a -> a -> Wraparound a
- mkWraparound lo hi a = Wraparound lo hi $ wrap lo hi a
- 
- wrap :: (Num a, Ord a) => a -> a -> a -> a
- wrap lo hi a
-   | a < lo = wrap lo hi $ a + d
-   | a >= hi = wrap lo hi $ a - d
-   | otherwise = a
-   where
-     d = hi - lo

D reflex-gl-demo/src/Reflex/FSNotify.hs => reflex-gl-demo/src/Reflex/FSNotify.hs +0 -12
@@ 1,12 0,0 @@-{-# LANGUAGE GADTs           #-}
- 
- module Reflex.FSNotify (watchDir) where
- 
- import           Reflex
- import qualified System.FSNotify as FS
- 
- watchDir
-   :: TriggerEvent t m
-   => FS.WatchManager -> FilePath -> m (Event t FS.Event)
- watchDir manager path = newEventWithLazyTriggerWithOnComplete $ \fire ->
-   FS.watchDir manager path (\_ -> True) (\fsEvent -> fire fsEvent (pure ()))

D reflex-gl-demo/src/Shader.hs => reflex-gl-demo/src/Shader.hs +0 -160
@@ 1,160 0,0 @@-{-# LANGUAGE FlexibleContexts  #-}
- {-# LANGUAGE LambdaCase        #-}
- {-# LANGUAGE OverloadedStrings #-}
- {-# LANGUAGE PatternSynonyms   #-}
- 
- module Shader (compile, link, watchShaderProgram) where
- 
- import           Prelude hiding (filter)
- 
- import           Control.Applicative (liftA2)
- import           Control.Lens (pattern Strict, _1, view)
- import           Control.Monad.IO.Class (MonadIO(..))
- import           Data.ByteString (ByteString)
- import qualified Data.ByteString.Char8 as B
- import           Data.Foldable (traverse_)
- import           Data.Functor (($>), (<&>))
- import           Data.StateVar (($=))
- import           Data.Witherable (catMaybes, filter)
- import           Graphics.Glow (Program, Shader, ShaderType)
- import qualified Graphics.Glow as Glow
- import           Path
- import           Reflex
- import           Reflex.FSNotify
- import qualified System.FSNotify as FS
- 
- -- | Create and compile a shader each time the event fires. When a
- -- shader is successfully compiled, the previous shader is marked for
- -- deletion and a new one is created.
- compile
-   :: (MonadHold t m, MonadIO m, PerformEvent t m, MonadIO (Performable m))
-   => ShaderType
-   -> Event t ByteString
-   -> m (Event t (Either ByteString Shader))
- compile sType eCode = do
-   eeShader <- performEvent $ eCode <&> \c -> do
-     shader <- Glow.createShader sType
-     Glow.shaderSource shader $= Strict c
-     Glow.compileShader shader
-     Glow.compileStatus shader >>= \case
-       True -> pure $ Right shader
-       False -> do
-         err <- Glow.shaderInfoLog shader
-         Glow.delete shader
-         pure $ Left err
- 
-   dShader <- holdDyn Nothing . fmap Just . filterRight $ eeShader
- 
-   -- When we get a new shader, delete the old one
-   performEvent_ $ traverse_ Glow.delete <$> current dShader <@ updated dShader
- 
-   pure eeShader
- 
- -- | Link a shader program after each event has fired at least
- -- once. When a program is successfully linked, the old one is
- -- deleted.
- link
-   :: ( MonadHold t m
-      , MonadIO (Performable m)
-      , PerformEvent t m
-      )
-   => Event t Shader -- ^ Vertex Shader
-   -> Event t Shader -- ^ Fragment Shader
-   -> m (Event t (Either ByteString Program))
- link eVs eFs = do
-   dVs <- holdDyn Nothing $ Just <$> eVs
-   dFs <- holdDyn Nothing $ Just <$> eFs
- 
-   let
-     dmShaders = zipDynWith (liftA2 (,)) dVs dFs
-     eShaders = catMaybes $ updated dmShaders
- 
-   eeProgram <- performEvent $ eShaders <&> \(vs, fs) -> do
-     program <- Glow.gen
-     Glow.attachShader program vs
-     Glow.attachShader program fs
-     Glow.linkProgram program
-     Glow.linkStatus program >>= \case
-       True -> pure $ Right program
-       False -> do
-         err <- Glow.programInfoLog program
-         Glow.delete program
-         pure $ Left err
- 
-   let eProgram = filterRight eeProgram
-   dProgram <- holdDyn Nothing $ Just <$> eProgram
- 
-   -- When we get a new program, delete the old one
-   performEvent_ $ traverse_ Glow.delete <$> current dProgram <@ updated dProgram
- 
-   pure eeProgram
- 
- watchShaderProgram
-   :: ( MonadHold t m
-      , MonadIO m
-      , MonadIO (Performable m)
-      , PerformEvent t m
-      , PostBuild t m
-      , TriggerEvent t m
-      )
-   => FS.WatchManager
-   -> Path Abs Dir -- ^ Directory name
-   -> Path Rel File -- ^ Vertex shader name (relative to dir)
-   -> Path Rel File -- ^ Fragment shader name (relative to dir)
-   -> m (Event t Program)
- watchShaderProgram manager dir vsFileRel fsFileRel = do
-   ePostBuild <- getPostBuild
- 
-   let
-     vsFileAbs = toFilePath $ dir </> vsFileRel
-     fsFileAbs = toFilePath $ dir </> fsFileRel
- 
-   -- Read the initial sources
-   vsInitial <- liftIO $ B.readFile vsFileAbs
-   fsInitial <- liftIO $ B.readFile fsFileAbs
- 
-   -- Watch the dir for changes to the files we're interested in. In
-   -- this demo program, we only care about one of the constructors of
-   -- a 'FS.Event'. This means we can get away with
-   -- 'mapMaybe'.
-   --
-   -- Exercise: Learn how to use 'fan' to efficiently split an 'Event t
-   -- FS.Event' into four different 'Event's.
-   let
-     onlyModifications (FS.Modified path mtime isDir) = Just (path, mtime, isDir)
-     onlyModifications _ = Nothing
-   eDirChanges <- fmap (view _1) . mapMaybe onlyModifications
-     <$> watchDir manager (toFilePath dir)
- 
-   let
-     eVsChanges = filter (vsFileAbs ==) eDirChanges
-     eFsChanges = filter (fsFileAbs ==) eDirChanges
-   eVsUpdates <- performEvent $ liftIO . B.readFile <$> eVsChanges
-   eFsUpdates <- performEvent $ liftIO . B.readFile <$> eFsChanges
- 
-   -- Tie the shader sources together and compile
-   eeVs <- compile Glow.VertexShader $ leftmost
-     [ eVsUpdates
-     , ePostBuild $> vsInitial
-     ]
-   eeFs <- compile Glow.FragmentShader $ leftmost
-     [ eFsUpdates
-     , ePostBuild $> fsInitial
-     ]
- 
-   -- Report compile errors
-   let
-     (eVsError, eVs) = fanEither eeVs
-     (eFsError, eFs) = fanEither eeFs
-   performEvent_ $ eVsError <&> \err -> liftIO . B.putStrLn $
-     "Vertex Shader Compile Error: " <> err
-   performEvent_ $ eFsError <&> \err -> liftIO . B.putStrLn $
-     "Fragment Shader Compile Error: " <> err
- 
-   -- Link and report link errors
-   eeProg <- link eVs eFs
-   let (eLinkError, eProg) = fanEither eeProg
-   performEvent_ $ eLinkError <&> \err -> liftIO . B.putStrLn $
-     "Shader Link Error: " <> err
- 
-   pure eProg

D reflex-gl-demo/src/Uniform.hs => reflex-gl-demo/src/Uniform.hs +0 -45
@@ 1,45 0,0 @@-{-# OPTIONS_GHC -Wno-unused-matches #-}
- 
- {-# LANGUAGE GADTs                 #-}
- {-# LANGUAGE MultiParamTypeClasses #-}
- {-# LANGUAGE TemplateHaskell       #-}
- 
- module Uniform where
- 
- import           Control.Monad (unless)
- import           Control.Monad.IO.Class (MonadIO)
- import           Data.Dependent.Sum (DSum(..))
- import qualified Data.Dependent.Sum as DSum
- import           Data.Foldable (traverse_)
- import           Data.Functor.Identity (Identity(..))
- import           Data.GADT.Compare.TH (deriveGEq, deriveGCompare)
- import           Data.GADT.Show.TH (deriveGShow)
- import           Data.Map (Map)
- import qualified Data.Map as Map
- import           Data.StateVar (($=))
- import           Graphics.Glow (Mat4, Program)
- import qualified Graphics.Glow as Glow
- 
- data UniformKey a where
-   Mat4 :: UniformKey Mat4
- 
- $(deriveGEq ''UniformKey)
- $(deriveGCompare ''UniformKey)
- $(deriveGShow ''UniformKey)
- 
- instance DSum.EqTag UniformKey Identity where
-   eqTagged Mat4 Mat4 = (==)
- 
- -- | Set of uniforms to apply to a shader program.
- type Uniforms = Map String (DSum UniformKey Identity)
- 
- -- | Set the current program and apply a set of uniforms to it.
- applyUniforms :: MonadIO m => Program -> Uniforms -> m ()
- applyUniforms prog uniforms = do
-   Glow.currentProgram $= prog
-   traverse_ (uncurry applyUniform) $ Map.toList uniforms
-   where
-     applyUniform name uniform = do
-       loc <- Glow.uniformLocation prog name
-       unless (loc == -1) $ case uniform of
-         Mat4 :=> Identity m -> Glow.uniformMat4 loc m

D reflex-gl-demo/src/VertexArray.hs => reflex-gl-demo/src/VertexArray.hs +0 -66
@@ 1,66 0,0 @@-{-# LANGUAGE FlexibleContexts    #-}
- {-# LANGUAGE GADTs               #-}
- {-# LANGUAGE RankNTypes          #-}
- {-# LANGUAGE ScopedTypeVariables #-}
- {-# LANGUAGE TypeApplications    #-}
- 
- module VertexArray
-   ( VertexArrayConfig
-   , VertexArrayUpdates
-   , SomeBuffer(..)
-   , vertexArray
-   ) where
- 
- import           Control.Monad.IO.Class (MonadIO(..))
- import           Data.Functor ((<&>), void)
- import           Data.Map (Map)
- import qualified Data.Map as Map
- import           Data.Map.Misc (diffMap)
- import           Data.StateVar (($=))
- import           Data.Typeable
- import           Graphics.Glow (AttributeLocation)
- import qualified Graphics.Glow as Glow
- import           Reflex
- 
- data SomeBuffer where
-   SomeBuffer :: (Eq a, Typeable a) => Glow.Buffer a -> SomeBuffer
- 
- instance Eq SomeBuffer where
-   (SomeBuffer (a :: Glow.Buffer a)) == (SomeBuffer (b :: Glow.Buffer b))
-     = maybe False (\Refl -> a == b) $ eqT @a @b
- 
- type VertexArrayConfig = Map AttributeLocation (Maybe SomeBuffer, Glow.Layout)
- type VertexArrayUpdates = Map AttributeLocation
-   (Maybe (Maybe SomeBuffer, Glow.Layout))
- 
- vertexArray
-   :: (MonadIO m, MonadIO (Performable m), MonadSample t m, PerformEvent t m)
-   => Dynamic t VertexArrayConfig
-   -> m Glow.VertexArray
- vertexArray dConfig = do
-   let eDiffs = uncurry diffMap <$> attach (current dConfig) (updated dConfig)
-   vao <- Glow.gen
- 
-   -- Set up the VAO
-   initialState <- sample $ current dConfig
-   liftIO . Glow.withVertexArray vao . applyUpdates $ Just <$> initialState
- 
-   -- Update the VAO
-   performEvent_ $ eDiffs <&> \diff -> liftIO $
-     Glow.withVertexArray vao $ applyUpdates diff
- 
-   pure vao
- 
- applyUpdates :: VertexArrayUpdates -> IO ()
- applyUpdates updates = void . flip Map.traverseWithKey updates $ \loc mCfg ->
-   case mCfg of
-     Nothing -> Glow.setVertexAttribute loc $= Nothing
-     Just (mBuf, layout) ->
-       let
-         -- If we're reading from the buffer, bind it first
-         bindBufferFunc = case mBuf of
-           Nothing -> id
-           Just (SomeBuffer buf) ->
-             Glow.withBoundBufferAt Glow.ArrayBufferTarget buf
-       in
-         bindBufferFunc $ Glow.setVertexAttribute loc $= Just layout

D reflex-gl-demo/talk-blurb.md => reflex-gl-demo/talk-blurb.md +0 -25
@@ 1,25 0,0 @@-# Reflex Outside the Browser
- 
- Functional Reactive Programming (FRP) is often introduced by
- discussing events and behaviors, and how to transform and mix
- them. But once you understand the primitives, what do you do with
- them? Where do the first events come from, and how do you wire these
- parts into a larger whole?
- 
- FRP promises benefits in more domains than just user interfaces, so
- let's take a look at Reflex outside its most common habitat of web
- frontends. There's now a fairly up-to-date version of Reflex on
- Hackage, so we can play with it right away and leave GHCjs,
- Reflex-DOM, special build tools, and the custom nix frameworks for
- later.
- 
- An FRP network of events and behaviors runs inside a library called a
- "host", which interfaces between the FRP network and the outside
- world. Using an interactive OpenGL program as our example, we'll
- explore how a slightly larger reactive program hangs together, and how
- it uses the host's features to do what it needs to do.
- 
- ## Assumed Knowledge: Significant
- 
- Specifically, I'll need to be able to say things like "X is an
- Applicative" and not spend a whole lot of time on the details.