~jack/misc

8640a931eb806864bfc24e04c24b64be2e336cdf — Jack Kelly 2 years ago 1cd6b68
OMG
M consengine/consengine.cabal => consengine/consengine.cabal +15 -1
@@ 19,20 19,34 @@ extra-source-files:  CHANGELOG.md

library
  exposed-modules:     App
                     , CONS.BufferObject
                     , CONS.Host
                     , CONS.Shader
                     , CONS.VertexArray
                     , Data.IntMap.Misc
  ghc-options:         -Wall
  -- other-modules:
  -- other-extensions:
  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-sum ^>= 0.4
                     , dlist ^>= 0.8.0.6
                     , gl ^>= 0.8
                     , glow ^>= 0
                     , lens ^>= 4.17.1
                     , linear ^>= 1.20.9
                     , mtl ^>= 2.2.2
                     , ref-tf ^>= 0.4.0.1
                     , reflex ^>= 0.6
                     , reflex-basic-host ^>= 0.1
                     , reflex-basic-host ^>= 0.2
                     , reflex-sdl2 ^>= 0.3
                     , text ^>= 1.2.3.1
                     , these ^>= 0.7.6
                     , vector ^>= 0.12.0.3
                     , witherable ^>= 0.3.1
  hs-source-dirs:      src
  default-language:    Haskell2010


M consengine/consengine.nix => consengine/consengine.nix +7 -4
@@ 1,5 1,7 @@
{ mkDerivation, base, bytestring, gl, GLFW-b, glow, linear, reflex
, reflex-basic-host, reflex-sdl2, stdenv, text, vector
{ mkDerivation, base, bytestring, containers, dependent-map
, dependent-sum, dlist, gl, GLFW-b, glow, lens, linear, mtl, ref-tf
, reflex, reflex-basic-host, reflex-sdl2, StateVar, stdenv, text
, these, vector, witherable
}:
mkDerivation {
  pname = "consengine";


@@ 8,8 10,9 @@ mkDerivation {
  isLibrary = true;
  isExecutable = true;
  libraryHaskellDepends = [
    base bytestring gl GLFW-b glow linear reflex reflex-basic-host
    reflex-sdl2 text vector
    base bytestring containers dependent-map dependent-sum dlist gl
    GLFW-b glow lens linear mtl ref-tf reflex reflex-basic-host
    reflex-sdl2 StateVar text these vector witherable
  ];
  executableHaskellDepends = [ base ];
  license = stdenv.lib.licenses.gpl3;

M consengine/default.nix => consengine/default.nix +0 -3
@@ 12,7 12,6 @@ let
                       then pkgs.haskellPackages
                       else pkgs.haskell.packages.${compiler};


  haskellPackages = baseHaskellPackages.override {
    overrides = self: super: with pkgs.haskell.lib; {
      reflex = overrideCabal super.reflex (drv: {


@@ 29,8 28,6 @@ let
      ptrdiff = super.callCabal2nix "ptrdiff" "${codex}/ptrdiff" {};
      reflex-basic-host = super.callCabal2nix "reflex-basic-host"
        (import ./nix/reflex-basic-host.nix) {};

#      sdl2 = doJailbreak super.sdl2;
    };
  };


M consengine/nix/reflex-basic-host.json => consengine/nix/reflex-basic-host.json +3 -3
@@ 1,7 1,7 @@
{
  "url": "https://github.com/qfpl/reflex-basic-host",
  "rev": "009354c2751fcbe3d798d756f548f2bcf767aaaa",
  "date": "2019-05-17T13:22:29+10:00",
  "sha256": "1ng3mfx0qa4wdw7vc9aihbkzf6cs7n7if53rg5jnxfj57h2xd3gl",
  "rev": "8526a9ca34e652dbc7bbb6202a770cd373a230bd",
  "date": "2019-06-28T10:13:47+10:00",
  "sha256": "1cizchnlwqxzjwyqgrdmn6847sbdfr5ghlrqdm7jsqvi67d2apcl",
  "fetchSubmodules": false
}

M consengine/src/App.hs => consengine/src/App.hs +140 -86
@@ 1,41 1,128 @@
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedLists     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module App where

import           Prelude hiding (filter)

import           CONS.BufferObject
import           CONS.Shader
import           CONS.VertexArray
import           Control.Applicative
import           Control.Lens
import           Control.Monad
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Cont
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.Ref
import           Data.Bits
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import           Data.Foldable
import           Data.Functor
import           Data.Functor.Misc (Const2(..))
import qualified Data.List.NonEmpty as NE
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.StateVar
import qualified Data.Text as T
import qualified Data.Text.Foreign as T
import qualified Data.Text.IO as T
import           Data.Vector.Storable (Vector)
import qualified Data.Vector.Storable as VS
import           Foreign.Marshal
import           Data.Witherable
import           Foreign.Marshal hiding (void)
import           Foreign.Ptr
import           Foreign.Storable
import           Graphics.GL.Core45
import           Graphics.GL.Types
import qualified Graphics.Glow as Glow
import           Graphics.Glow hiding (Program)
import qualified Graphics.UI.GLFW as GLFW
import           Linear.V3
import           Reflex
import           Reflex.Host.Basic (BasicGuest, BasicGuestConstraints, basicHostWithQuit)
import           System.Exit
import           System.Exit (exitFailure)

main :: IO ()
main = basicHostWithQuit guest
main = do
  window <- setupGL
  basicHostWithQuit (guest window)
  GLFW.terminate

guest :: BasicGuestConstraints t m => BasicGuest t m ((), Event t ())
guest = do
  postBuildE <- getPostBuild
  performEvent_ $ postBuildE $> liftIO crap
  pure ((), never)
guest
  :: BasicGuestConstraints t m
  => GLFW.Window
  -> BasicGuest t m (Event t ())
guest window = do
  (quitE, quitF) <- newTriggerEvent

  ticks <- tickLossyFromPostBuildTime $ 1 / 60
  eInputs <- performEventAsync $ ticks $> pumpInput window quitF
  let eInputs' = filter (not . null) eInputs

  ePostBuild <- getPostBuild

  dPoints <- holdDyn
    ( StaticDraw
    , [ V3 0.0 0.5 0.0
      , V3 0.5 (-0.5) 0.0
      , V3 (-0.5) (-0.5) 0.0
      ] :: Vector (V3 GLfloat)
    ) $
    eInputs' $> ( StaticDraw
    , [ V3 0.0 (-0.5) 0.0
      , V3 0.5 0.5 0.0
      , V3 (-0.5) 0.5 0.0
      ] :: Vector (V3 GLfloat)
    )
  performEvent_ $ liftIO . print <$> updated dPoints
  vbo <- bufferObject ArrayBufferTarget $ dPoints

  vs <- compile VertexShader $ ePostBuild $> B.pack (unlines
    [ "#version 410"
    , "in vec3 vp;"
    , "void main() {"
    , "  gl_Position = vec4(vp, 1.0);"
    , "}"
    ])
  performEvent_ $ updated (_sShader vs) <&> liftIO . print
  performEvent_ $ _sError vs <&> \e ->
    liftIO . B.putStrLn $ "Vertex shader error: " <> e

  fs <- compile FragmentShader $ ePostBuild $> B.pack (unlines
    [ "#version 410"
    , "out vec4 frag_color;"
    , "void main() {"
    , "  frag_color = vec4(0.5, 0.0, 0.5, 1.0);"
    , "}"
    ])
  performEvent_ $ updated (_sShader fs) <&> liftIO . print
  performEvent_ $ _sError fs <&> \e ->
    liftIO . B.putStrLn $ "Fragment shader error: " <> e

  prog <- link
    (catMaybes . updated $ _sShader vs)
    (catMaybes . updated $ _sShader fs)
  performEvent_ $ _pError prog <&> \e ->
    liftIO . B.putStrLn $ "Program link error: " <> e
  performEvent_ $ updated (_pProgram prog) <&>
    liftIO . print

  vao <- vertexArray . constDyn $ Map.fromList
    [ ( 0,
        ( Just . SomeBuffer $ _boBuffer vbo
        , Layout 3 GL_FLOAT False 0 nullPtr
        )
      )
    ]

  performEvent_ $ leftmost [ePostBuild, void $ updated $ dPoints, void $ updated $ _pProgram prog] $> draw window (_vaArray vao) (_pProgram prog)

  pure quitE

setupGL :: IO GLFW.Window
setupGL = do


@@ 50,35 137,54 @@ setupGL = do
     , GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
     ] :: [GLFW.WindowHint])

  GLFW.createWindow 640 480 "Hello Triangle!" Nothing Nothing >>= \case
  win <- GLFW.createWindow 640 480 "Hello Triangle!" Nothing Nothing >>= \case
    Nothing ->
      putStrLn "GLFW createWindow failed" *> GLFW.terminate *> exitFailure
    Just win -> GLFW.makeContextCurrent (Just win) *> pure win

  glEnable GL_DEPTH_TEST
  stateBits $~ depthFunc .~ DepthFuncLEqual

  pure win

pumpInput
  :: (MonadIO m, MonadRef m, Ref m ~ Ref IO)
  => GLFW.Window
  -> (() -> IO ()) -- ^ Fire quit event
  -> (Map GLFW.Key GLFW.KeyState -> IO ()) -- ^ Fire input event
  -> m ()
pumpInput window fireQuit fireInput = liftIO $ do
  shouldQuit <- GLFW.windowShouldClose window
  if shouldQuit
    then fireQuit ()
    else liftIO $ newRef Map.empty >>= \keysR -> do
      let keyCallback keymapR _ key _ state _ =
            modifyRef keymapR $ Map.insert key state

      GLFW.setKeyCallback window . Just $ keyCallback keysR
      GLFW.pollEvents
      readRef keysR >>= fireInput

draw
  :: (MonadIO m, MonadSample t m, Reflex t)
  => GLFW.Window
  -> Glow.VertexArray
  -> Dynamic t (Maybe Glow.Program)
  -> m ()
draw win vao dmProg = do
  mProg <- sample $ current dmProg
  liftIO . for_ mProg $ \prog -> do
    glClear $ GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT
    currentProgram $= prog
    withVertexArray vao $ glDrawArrays GL_TRIANGLES 0 3
    GLFW.swapBuffers win

crap :: IO ()
crap = do
  win <- setupGL

  renderer <- glGetString GL_RENDERER >>= B.packCString . castPtr
  B.putStrLn $ "Renderer: " <> renderer
  version <- glGetString GL_VERSION >>= B.packCString . castPtr
  B.putStrLn $ "Version: " <> version

  glEnable GL_DEPTH_TEST
  glDepthFunc GL_LESS

  vbo <- alloca $ \ptr -> glGenBuffers 1 ptr *> peek ptr
  glBindBuffer GL_ARRAY_BUFFER vbo
  let
    vertices :: Vector (V3 GLfloat)
    vertices = [ V3 0.0 0.5 0.0
               , V3 0.5 (-0.5) 0.0
               , V3 (-0.5) (-0.5) 0.0
               ]
    vSize = sizeOf (VS.head vertices) * VS.length vertices

  VS.unsafeWith vertices $ \ptr ->
    glBufferData GL_ARRAY_BUFFER (fromIntegral vSize) (castPtr ptr) GL_STATIC_DRAW

  vao <- alloca $ \ptr -> glGenVertexArrays 1 ptr *> peek ptr
  glBindVertexArray vao


@@ 87,61 193,11 @@ crap = do
  glVertexAttribPointer 0 3 GL_FLOAT GL_FALSE 0 nullPtr

  let
    vertexShader = T.pack $ unlines
      [ "#version 410"
      , "in vec3 vp;"
      , "void main() {"
      , "  gl_Position = vec4(vp, 1.0);"
      , "}"
      ]

    fragmentShader = T.pack $ unlines
      [ "#version 410"
      , "out vec4 frag_color;"
      , "void main() {"
      , "  frag_color = vec4(0.5, 0.0, 0.5, 1.0);"
      , "}"
      ]

  vs <- glCreateShader GL_VERTEX_SHADER
  T.withCStringLen vertexShader $ \(str, len) ->
    with str $ \strPtr ->
      with (fromIntegral len) $ \lenPtr ->
        glShaderSource vs 1 strPtr lenPtr
  glCompileShader vs
  alloca $ \ptr -> do
    glGetShaderiv vs GL_COMPILE_STATUS ptr
    stat <- peek ptr
    when (stat == GL_FALSE) $ allocaBytes 4096 $ \bytesP ->
      alloca $ \lenP -> do
        glGetShaderInfoLog vs 4096 lenP bytesP
        len <- peek lenP
        T.peekCStringLen (bytesP, fromIntegral len) >>= T.putStrLn

  fs <- glCreateShader GL_FRAGMENT_SHADER
  T.withCStringLen fragmentShader $ \(str, len) ->
    with str $ \strPtr ->
      with (fromIntegral len) $ \lenPtr ->
        glShaderSource fs 1 strPtr lenPtr
  glCompileShader fs
  alloca $ \ptr -> do
    glGetShaderiv fs GL_COMPILE_STATUS ptr
    stat <- peek ptr
    when (stat == GL_FALSE) $ putStrLn "fs compile fail"

  prog <- glCreateProgram
  glAttachShader prog fs
  glAttachShader prog vs
  glLinkProgram prog
  glDeleteShader fs
  glDeleteShader vs

  let
    loop = do
      close <- GLFW.windowShouldClose win
      unless close $ do
        glClear $ GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT
        glUseProgram prog
        glUseProgram undefined
        glBindVertexArray vao
        glDrawArrays GL_TRIANGLES 0 3
        GLFW.pollEvents


@@ 149,6 205,4 @@ crap = do
        loop

  loop

  GLFW.terminate
  pure ()

A consengine/src/CONS/BufferObject.hs => consengine/src/CONS/BufferObject.hs +46 -0
@@ 0,0 1,46 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell  #-}

module CONS.BufferObject where

import           Control.Lens.TH (makeLenses)
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

data BufferObject t a = BufferObject
  { _boBuffer :: Buffer a
  , _boUpdated :: Event t (BufferUsage, a)
    -- ^ Fires after the OpenGL buffer object updates, which may be in
    -- later frame than your argument to 'bufferObject'.
  }

$(makeLenses ''BufferObject)

bufferObject
  :: ( BufferData a
     , MonadIO m
     , MonadIO (Performable m)
     , MonadSample t m
     , PerformEvent t m
     )
  => BufferTarget
  -> Dynamic t (BufferUsage, a)
  -> m (BufferObject t 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
  eUpdates <- performEvent $ updated dXs <&> \xs -> liftIO $ do
    Glow.withBoundBufferAt target buf $ Glow.bufferData target $= xs
    pure xs

  pure $ BufferObject buf eUpdates
\ No newline at end of file

A consengine/src/CONS/Host.hs => consengine/src/CONS/Host.hs +121 -0
@@ 0,0 1,121 @@
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TypeFamilies               #-}

module CONS.Host where

import           Control.Concurrent.Chan
import           Control.Monad (unless)
import           Control.Monad.Fix (MonadFix)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Ref
import           Data.DList (DList)
import qualified Data.DList as DList
import           Data.Dependent.Sum ((==>))
import           Data.Foldable (fold, for_, traverse_)
import           Data.Functor ((<&>))
import           Data.IORef
import           Data.Kind (Type)
import           Data.List.NonEmpty (NonEmpty, nonEmpty)
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Witherable
import qualified Graphics.UI.GLFW as GLFW
import           Reflex
import           Reflex.Host.Class
import           System.Exit (exitFailure)

newtype Guest t (m :: Type -> Type) a
  = Guest { unGuest :: PostBuildT t (PerformEventT t m) a }
  deriving (Functor, Applicative, Monad, MonadFix)

instance (ReflexHost t, Monad m) => PostBuild t (Guest t m) where
  getPostBuild = Guest getPostBuild

newtype GuestInputs t = GuestInputs
  { _giKeys :: Event t (Map GLFW.Key GLFW.KeyState)
  }

newtype GuestOutputs t = GuestOutputs
  { _goQuit :: Event t ()
  }

type GuestConstraints t (m :: Type -> Type) =
  ( ReflexHost t
  , Monad m
  )

host
  :: ( forall t m . GuestConstraints t m
     => GuestInputs t
     -> Guest t m (GuestOutputs t)
     )
  -> IO ()
host makeGuest = do
  window <- setupGL
  keysR <- newRef mempty
  GLFW.setKeyCallback window (Just $ keyCallback keysR)
  quitR <- newRef False

  (quitH, keysTRef, fire) <- runSpiderHost $ do
    (postBuildE, postBuildTRef) <- newEventWithTriggerRef
    (keysE, keysTRef) <- newEventWithTriggerRef

    let Guest guest = makeGuest $ GuestInputs keysE
    (outputs, FireCommand fire) <-
      hostPerformEventT (runPostBuildT guest postBuildE)

    quitH <- subscribeEvent $ _goQuit outputs

    fireEventRefAndRead postBuildTRef () quitH
      >>= traverse_ (\_ -> writeRef quitR True)

    pure (quitH, keysTRef, fire)

  let
    loop = do
      quit <- readRef quitR
      glfwQuit <- GLFW.windowShouldClose window
      unless (quit || glfwQuit) $ do
        GLFW.pollEvents

        keys <- readRef keysR
        keysT <- readRef keysTRef

        quitM <- runSpiderHost $ do
          let firings = catMaybes
                [ keysT <&> (==> keys)
                ]
          fire firings $ readEvent quitH >>= sequenceA
        for_ quitM $ \_ -> liftIO $ writeRef quitR True

        loop

  loop
  GLFW.terminate

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])

  GLFW.createWindow 640 480 "Hello Triangle!" Nothing Nothing >>= \case
    Nothing ->
      putStrLn "GLFW createWindow failed" *> GLFW.terminate *> exitFailure
    Just win -> GLFW.makeContextCurrent (Just win) *> pure win

keyCallback :: IORef (Map GLFW.Key GLFW.KeyState) -> GLFW.KeyCallback
keyCallback keymapR _ key _ state _ = modifyRef keymapR $ Map.insert key state

A consengine/src/CONS/Shader.hs => consengine/src/CONS/Shader.hs +111 -0
@@ 0,0 1,111 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE PatternSynonyms  #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TupleSections    #-}

module CONS.Shader
  ( -- * Shaders
    Shader(..)
  , compile
    -- * Compiled Programs
  , Program(..)
  , link

    -- * Lenses
    -- * @Shader@
  , sError
  , sShader
    -- * @Program@
  , pError
  , pProgram
  ) where

import           Control.Applicative (liftA2)
import           Control.Lens (pattern Strict, makeLenses)
import           Control.Monad.Fix (MonadFix)
import           Control.Monad.IO.Class (MonadIO)
import           Data.ByteString (ByteString)
import           Data.Foldable (traverse_)
import           Data.Functor ((<&>))
import           Data.StateVar (($=))
import           Data.Witherable (catMaybes)
import           Graphics.Glow (ShaderType)
import qualified Graphics.Glow as Glow
import           Reflex

data Shader t = Shader
  { _sError :: Event t ByteString
  , _sShader :: Dynamic t (Maybe Glow.Shader)
  }

$(makeLenses ''Shader)

data Program t = Program
  { _pError :: Event t ByteString
  , _pProgram :: Dynamic t (Maybe Glow.Program)
  }

$(makeLenses ''Program)

-- | Create and compile a shader each time the event fires. When the
-- input event fires, mark the current shader for deletion and create
-- a new one.
compile
  :: (MonadHold t m, MonadIO m, PerformEvent t m, MonadIO (Performable m))
  => ShaderType
  -> Event t ByteString
  -> m (Shader t)
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 $ Shader (filterLeft eeShader) dShader

-- | Link a shader program after each event has fired at least
-- once. Recompiling is done by deleting the old program and
-- generating a new one.
link
  :: (MonadFix m, MonadHold t m, MonadIO (Performable m), PerformEvent t m)
  => Event t Glow.Shader -- ^ Vertex Shader
  -> Event t Glow.Shader -- ^ Fragment Shader
  -> m (Program t)
link eVs eFs = do
  dVs <- holdDyn Nothing $ Just <$> eVs
  dFs <- holdDyn Nothing $ Just <$> eFs

  dmdShaders <- maybeDyn $ zipDynWith (liftA2 (,)) dVs dFs
  eShaders <- switchHoldPromptly never . fmap updated . catMaybes $
    updated dmdShaders

  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

  dProgram <- holdDyn Nothing . fmap Just . filterRight $ eeProgram

  -- When we get a new program, delete the old one
  performEvent_ $ traverse_ Glow.delete <$> current dProgram <@ updated dProgram

  pure $ Program (filterLeft eeProgram) dProgram

A consengine/src/CONS/VertexArray.hs => consengine/src/CONS/VertexArray.hs +83 -0
@@ 0,0 1,83 @@
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}

module CONS.VertexArray
  ( VertexArray (..)
  , VertexArrayConfig
  , VertexArrayUpdates
  , SomeBuffer(..)
  , vertexArray
    -- * Lenses
  , vaArray
  , vaUpdated
  ) where

import           Control.Lens.TH (makeLenses)
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))

data VertexArray t = VertexArray
  { _vaArray :: Glow.VertexArray
  , _vaUpdated :: Event t VertexArrayUpdates
  -- ^ Fires after the OpenGL vertex array finishes updating, which
  -- may be in a later frame than the frame where your dynamic
  -- updates.
  }

$(makeLenses ''VertexArray)

vertexArray
  :: (MonadIO m, MonadIO (Performable m), MonadSample t m, PerformEvent t m)
  => Dynamic t VertexArrayConfig
  -> m (VertexArray t)
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
  eUpdates <- performEvent $ eDiffs <&> \diff -> liftIO $ do
    Glow.withVertexArray vao $ applyUpdates diff
    pure diff

  pure $ VertexArray vao eUpdates

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

A consengine/src/Data/IntMap/Misc.hs => consengine/src/Data/IntMap/Misc.hs +17 -0
@@ 0,0 1,17 @@
{-# LANGUAGE LambdaCase #-}

module Data.IntMap.Misc (diffIntMap) where

import Data.Align (align)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.These (These(..))

-- Until it's in reflex proper
diffIntMap :: Eq a => IntMap a -> IntMap a -> IntMap (Maybe a)
diffIntMap olds news = flip IntMap.mapMaybe (align olds news) $ \case
  This _ -> Just Nothing
  These old new
    | old == new -> Nothing
    | otherwise -> Just $ Just new
  That new -> Just $ Just new