First working version

Author: Simre1

LambdaGL.cabal

@@ -0,0 +1,67 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: f73f63d782e90ba60475dcbed3119c57dae075854d91e89730b10b494e3c20da
+
+name: LambdaGL
+version: 0.1.0.0
+category: Web
+homepage: https://github.com/Simre1/LambdaGL#readme
+author: Author name here
+maintainer: example@example.com
+copyright: 2020 Author name here
+license: BSD3
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ README.md
+
+library
+ exposed-modules:
+ Data.HList
+ Data.SizedVector
+ Data.StateAction
+ Graphics.LambdaGL.Buffer
+ Graphics.LambdaGL.Draw
+ Graphics.LambdaGL.Program
+ Graphics.LambdaGL.Shader
+ Graphics.LambdaGL.Texture
+ Graphics.LambdaGL.Types.List
+ Graphics.LambdaGL.Types.Shared
+ Graphics.LambdaGL.Uniform
+ Graphics.LambdaGL.Utility
+ other-modules:
+ Paths_LambdaGL
+ hs-source-dirs:
+ src
+ default-extensions: OverloadedStrings GADTs TypeFamilies DataKinds TypeOperators PatternSynonyms FlexibleInstances FlexibleContexts MultiParamTypeClasses RankNTypes ScopedTypeVariables FunctionalDependencies TypeApplications OverloadedLists PolyKinds UndecidableInstances GeneralisedNewtypeDeriving StandaloneDeriving FunctionalDependencies ConstraintKinds
+ build-depends:
+ OpenGL
+ , StateVar
+ , base >=4.7 && <5
+ , bytestring
+ , text
+ , vector
+ default-language: Haskell2010
+
+executable example
+ main-is: Main.hs
+ other-modules:
+ Example01
+ Paths_LambdaGL
+ hs-source-dirs:
+ example
+ default-extensions: OverloadedStrings GADTs TypeFamilies DataKinds TypeOperators PatternSynonyms FlexibleInstances FlexibleContexts MultiParamTypeClasses RankNTypes ScopedTypeVariables FunctionalDependencies TypeApplications OverloadedLists PolyKinds UndecidableInstances GeneralisedNewtypeDeriving StandaloneDeriving FunctionalDependencies ConstraintKinds
+ build-depends:
+ LambdaGL
+ , OpenGL
+ , StateVar
+ , base >=4.7 && <5
+ , bytestring
+ , sdl2
+ , text
+ , vector
+ default-language: Haskell2010

README.md

@@ -1,2 +1,19 @@
-# typed-gl
-Experimental wrapper for opengl in haskell.
+# LambdaGL
+
+LambdaGL tries to simplify the task of interfacing with OpenGL less difficult by utilising advanced types.
+
+Right now, this project is in its infancy and not usable for any serious application. 
+
+Feel free to check out the code as well as the example.
+
+## Build & Execute Example
+
+I am using stack as my build tool. 
+
+``
+git clone https://github.com/Simre1/LambdaGL.git
+
+stack build
+
+stack exec example
+``

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

example/Example01.hs

@@ -0,0 +1,80 @@
+module Example01 where
+
+import qualified Data.ByteString as B
+import qualified Data.Vector.Storable as VS
+import Data.IORef
+
+import Data.SizedVector
+import Data.HList
+
+import Graphics.LambdaGL.Buffer
+import Graphics.LambdaGL.Program
+import Graphics.LambdaGL.Draw
+import Graphics.LambdaGL.Shader
+import Graphics.LambdaGL.Texture
+import Graphics.LambdaGL.Uniform
+import Graphics.LambdaGL.Types.Shared
+
+example01 :: IO (IO ())
+example01 = do
+ -- Timer to use as a uniform.
+ timer <- newIORef 0
+ draw <- createDrawAction
+ pure $ readIORef timer >>= draw >> modifyIORef timer (+1)
+
+createDrawAction :: IO (Int -> IO ())
+createDrawAction = do
+ vertexBuffer :: Buffer '[(D2, Float)] <- createBuffer
+ writeBuffer vertexBuffer $ VS.fromList $ [HostData (V2 (-1) (-1)) <:> Nil, HostData (V2 (1) (-1)) <:> Nil, HostData (V2 1 1) <:> Nil, HostData (V2 (-1) 1) <:> Nil, HostData (V2 (-1) (-1)) <:> Nil]
+
+ vertexShader :: CompiledShader 'Vertex '[] '[] '[(D2, Float)] '[(D2, Float)] <- compileShader $ Shader $ ShaderSource vertexShader
+
+ fragmentShader :: CompiledShader 'Fragment '[Named "time" Float] '[Texture NoMipMap TextureNormal D2 RGBA8] '[(D2, Float)] '[] <- compileShader $ Shader $ ShaderSource fragmentShader
+
+ texture <- newTexture @NoMipMap @TextureNormal @D2 @RGBA8
+ 
+ bindTexture texture $ do
+ writeTexture (V2 2 2) $ VS.fromList [V4 0 0 0 255, V4 255 255 255 255, V4 255 255 255 255, V4 0 0 0 255]
+
+ program <- createProgram $ TwoShader vertexShader fragmentShader
+
+ let uniforms x =
+ (makeDrawUniform $ (Named x :: Named "time" Float))
+
+ let initial = toDrawInput vertexBuffer 0
+ drawObj <- createDraw program (uniforms 0) initial
+ pure $ \i -> do
+ let pI = skipDrawInput @'[(D2, Float)]
+ runDrawEnv $ do
+ clearColor $ V4 1 1 1 1
+ bindLastTexture texture $
+ draw drawObj (uniforms $ fromIntegral i) pI (DrawOptions TriangleStrip 0 5)
+ pure ()
+
+fragmentShader :: B.ByteString
+fragmentShader =
+ mconcat . fmap (<> "\n") $
+ [ "#version 450 core",
+ "in vec2 fragCoord;",
+ "out vec4 fragColor;",
+ "uniform float time;",
+ "uniform sampler2D tex;",
+ "void main()",
+ "{",
+ "vec4 c = texture(tex, fragCoord);",
+ "fragColor = vec4(abs(fragCoord) * (sin(time/21) * sin(time/13) + abs(vec2(sin(time/47)))), c.z, 1.0);",
+ "}"
+ ]
+
+vertexShader :: B.ByteString
+vertexShader =
+ mconcat . fmap (<> "\n") $
+ [ "#version 430 core",
+ "layout(location = 0) in vec2 vPosition;",
+ "out vec2 fragCoord;",
+ "void main()",
+ "{",
+ "gl_Position = vec4(vPosition, 1, 1);",
+ "fragCoord = vPosition;",
+ "}"
+ ]

example/Main.hs

@@ -0,0 +1,56 @@
+module Main where
+
+import qualified SDL
+import qualified Data.StateVar as SV
+import qualified Data.Text as T
+import qualified Graphics.Rendering.OpenGL as GL
+import GHC.Clock
+import Control.Concurrent (threadDelay)
+import Control.Monad
+
+import Example01
+
+main :: IO ()
+main = do
+ -- Set up SDL window and GL context.
+ SDL.initializeAll
+ window <- SDL.createWindow (T.pack "My SDL Application") SDL.defaultWindow {SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL {SDL.glProfile = SDL.Core SDL.Debug 4 6}}
+ context <- SDL.glCreateContext window
+ GL.debugOutput SV.$= GL.Enabled
+ SDL.HintRenderScaleQuality SV.$= SDL.ScaleLinear 
+ renderQuality <- SV.get SDL.HintRenderScaleQuality 
+ when (renderQuality /= SDL.ScaleLinear) $ 
+ putStrLn "Warning: Linear texture filtering not enabled!"
+ 
+ -- Set up example01
+ drawExample <- example01
+
+ -- Start app loop
+ time <- getMonotonicTime
+ appLoop time drawExample window
+
+appLoop :: Double -> IO () -> SDL.Window -> IO ()
+appLoop time drawExample window = do
+
+ -- Poll events to determine if the app should exit.
+ events <- SDL.pollEvents
+ let checkForExitEvent event =
+ case SDL.eventPayload event of
+ SDL.KeyboardEvent keyboardEvent ->
+ SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed &&
+ SDL.keysymKeycode (SDL.keyboardEventKeysym keyboardEvent) == SDL.KeycodeEscape
+ SDL.WindowClosedEvent _ -> True
+ _ -> False
+ shouldExit = any checkForExitEvent events
+
+ -- Draw the given example.
+ drawExample
+
+ -- Calculate used time to loop at 60FPS
+ SDL.glSwapWindow window
+ time2 <- getMonotonicTime
+ threadDelay ((+) 16600 $ round $ (time - time2) * 1000000)
+ time3 <- getMonotonicTime
+
+ -- Continue unless quit button was pressed.
+ unless shouldExit (appLoop time3 drawExample window)

package.yaml

@@ -0,0 +1,54 @@
+name: LambdaGL
+version: 0.1.0.0
+#synopsis:
+#description:
+homepage: https://github.com/Simre1/LambdaGL#readme
+license: BSD3
+author: Author name here
+maintainer: example@example.com
+copyright: 2020 Author name here
+category: Web
+extra-source-files:
+- README.md
+
+dependencies:
+ - base >= 4.7 && < 5
+ - OpenGL
+ - text
+ - StateVar
+ - bytestring
+ - vector
+
+library:
+ source-dirs: src
+
+executables:
+ example:
+ source-dirs: example
+ main: Main.hs
+ dependencies:
+ - sdl2
+ - LambdaGL
+
+
+default-extensions:
+ - OverloadedStrings
+ - GADTs
+ - TypeFamilies
+ - DataKinds
+ - TypeOperators
+ - PatternSynonyms
+ - FlexibleInstances
+ - FlexibleContexts
+ - MultiParamTypeClasses
+ - RankNTypes
+ - ScopedTypeVariables
+ - FunctionalDependencies
+ - TypeApplications
+ - OverloadedLists
+ - PolyKinds
+ - UndecidableInstances
+ - GeneralisedNewtypeDeriving
+ - StandaloneDeriving
+ - FunctionalDependencies
+ - ConstraintKinds

src/Data/HList.hs

@@ -0,0 +1,34 @@
+module Data.HList where
+
+import Data.Proxy
+import GHC.TypeLits
+
+import Data.Functor.Identity
+
+import Foreign.Storable
+import Foreign.Ptr
+
+data HList f (things :: [*]) where
+ Nil :: HList f '[]
+ Cons :: f x -> HList f xs -> HList f (x ': xs)
+
+instance Storable (HList f '[]) where
+ sizeOf _ = 0
+ alignment _ = 0
+ peek _ = pure Nil
+ poke _ _ = pure ()
+
+instance (Storable (f x), Storable (HList f xs)) => Storable (HList f (x ': xs)) where
+ sizeOf _ = sizeOf (undefined :: f x) + sizeOf (undefined :: HList f xs)
+ alignment _ = alignment (undefined :: f x) + alignment (undefined :: HList f xs)
+ peek ptr = do
+ x <- peek (castPtr ptr) 
+ rest <- peek (castPtr (ptr `plusPtr` sizeOf (undefined :: f x)))
+ pure $ Cons x rest
+ poke ptr (Cons fx rest) = do
+ poke (castPtr ptr) fx
+ poke (ptr `plusPtr` sizeOf (undefined :: f x)) (rest :: HList f xs) 
+
+
+(<:>) = Cons
+infixr 8 <:>