initial commit

6 files changed, 325 insertions, 0 deletions

diff --git a/GtkHello.hs b/GtkHello.hs
new file mode 100644
index 0000000..9b29ba7
--- /dev/null
+++ b/GtkHello.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import qualified GI.Gtk                        as Gtk
+import           GI.Gtk.Declarative
+import           GI.Gtk.Declarative.App.Simple
+
+import qualified Data.Map as Map
+import qualified Data.Vector as V
+
+import LambdaCube.GL as LambdaCubeGL -- renderer
+import LambdaCube.GL.Mesh as LambdaCubeGL
+
+import Codec.Picture as Juicy
+
+import Data.Aeson
+import qualified Data.ByteString as SB
+
+type State = ()
+
+data Event = Closed
+
+view' :: State -> AppView Gtk.Window Event
+view' _ = bin
+    Gtk.Window
+    [ #title := "LambdaCube 3D DSL Hello World"
+    , on #deleteEvent $ {- GI.Gdk.Unions.Event.Event -> (Bool, Event) -} \_ -> (True,Closed)
+    ]
+    $ widget Gtk.Label [#label := "Hello, World!"]
+
+update' :: State -> Event -> Transition State Event
+update' _ Closed = Exit
+
+main :: IO ()
+main = do
+    Just pipelineDesc <- decodeStrict <$> SB.readFile "hello.json"
+
+    run App
+        -- :: App Gtk.Window State Event
+        { view         = view'
+        , update       = update'
+        , inputs       = []
+        , initialState = ()
+        }
diff --git a/Hello-glfw.hs b/Hello-glfw.hs
new file mode 100644
index 0000000..c93136b
--- /dev/null
+++ b/Hello-glfw.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-}
+import "GLFW-b" Graphics.UI.GLFW as GLFW
+import qualified Data.Map as Map
+import qualified Data.Vector as V
+
+import LambdaCube.GL as LambdaCubeGL -- renderer
+import LambdaCube.GL.Mesh as LambdaCubeGL
+
+import Codec.Picture as Juicy
+
+import Data.Aeson
+import qualified Data.ByteString as SB
+
+----------------------------------------------------
+--  See:  http://lambdacube3d.com/getting-started
+----------------------------------------------------
+
+main :: IO ()
+main = do
+    Just pipelineDesc <- decodeStrict <$> SB.readFile "hello.json"
+
+    win <- initWindow "LambdaCube 3D DSL Hello World" 640 640
+
+    -- setup render data
+    let inputSchema = makeSchema $ do
+          defObjectArray "objects" Triangles $ do
+            "position"  @: Attribute_V2F
+            "uv"        @: Attribute_V2F
+          defUniforms $ do
+            "time"           @: Float
+            "diffuseTexture" @: FTexture2D
+
+    storage <- LambdaCubeGL.allocStorage inputSchema
+
+    -- upload geometry to GPU and add to pipeline input
+    LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
+    LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
+
+    -- load image and upload texture
+    Right img <- Juicy.readImage "logo.png"
+    textureData <- LambdaCubeGL.uploadTexture2DToGPU img
+
+    -- allocate GL pipeline
+    renderer <- LambdaCubeGL.allocRenderer pipelineDesc
+    LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility
+      Just err -> putStrLn err
+      Nothing  -> loop
+        where loop = do
+                -- update graphics input
+                GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
+                LambdaCubeGL.updateUniforms storage $ do
+                  "diffuseTexture" @= return textureData
+                  "time" @= do
+                              Just t <- GLFW.getTime
+                              return (realToFrac t :: Float)
+                -- render
+                LambdaCubeGL.renderFrame renderer
+                GLFW.swapBuffers win
+                GLFW.pollEvents
+
+                let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k
+                escape <- keyIsPressed Key'Escape
+                if escape then return () else loop
+
+    LambdaCubeGL.disposeRenderer renderer
+    LambdaCubeGL.disposeStorage storage
+    GLFW.destroyWindow win
+    GLFW.terminate
+
+-- geometry data: triangles
+triangleA :: LambdaCubeGL.Mesh
+triangleA = Mesh
+    { mAttributes   = Map.fromList
+        [ ("position",  A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])
+        , ("uv",        A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])
+        ]
+    , mPrimitive    = P_Triangles
+    }
+
+triangleB :: LambdaCubeGL.Mesh
+triangleB = Mesh
+    { mAttributes   = Map.fromList
+        [ ("position",  A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])
+        , ("uv",        A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])
+        ]
+    , mPrimitive    = P_Triangles
+    }
+
+initWindow :: String -> Int -> Int -> IO Window
+initWindow title width height = do
+    GLFW.init
+    GLFW.defaultWindowHints
+    mapM_ GLFW.windowHint
+      [ WindowHint'ContextVersionMajor 3
+      , WindowHint'ContextVersionMinor 3
+      , WindowHint'OpenGLProfile OpenGLProfile'Core
+      , WindowHint'OpenGLForwardCompat True
+      ]
+    Just win <- GLFW.createWindow width height title Nothing Nothing
+    GLFW.makeContextCurrent $ Just win
+    return win
diff --git a/Hello-glut.hs b/Hello-glut.hs
new file mode 100644
index 0000000..9ffa92c
--- /dev/null
+++ b/Hello-glut.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-}
+import Control.Concurrent
+
+-- import "GLFW-b" Graphics.UI.GLFW as GLFW
+import qualified Graphics.UI.GLUT as GLFW -- lie
+import qualified Graphics.UI.GLUT as GLUT -- truth
+import Graphics.UI.GLUT (Window)
+import qualified Data.Map as Map
+import qualified Data.Vector as V
+
+import LambdaCube.GL as LambdaCubeGL -- renderer
+import LambdaCube.GL.Mesh as LambdaCubeGL
+
+import Codec.Picture as Juicy
+
+import Data.Aeson
+import qualified Data.ByteString as SB
+
+----------------------------------------------------
+--  See:  http://lambdacube3d.com/getting-started
+----------------------------------------------------
+
+main :: IO ()
+main = do
+    Just pipelineDesc <- decodeStrict <$> SB.readFile "hello.json"
+
+    win <- initWindow "LambdaCube 3D DSL Hello World" 640 640
+
+    -- setup render data
+    let inputSchema = makeSchema $ do
+          defObjectArray "objects" Triangles $ do
+            "position"  @: Attribute_V2F
+            "uv"        @: Attribute_V2F
+          defUniforms $ do
+            "time"           @: Float
+            "diffuseTexture" @: FTexture2D
+
+    storage <- LambdaCubeGL.allocStorage inputSchema
+
+    -- upload geometry to GPU and add to pipeline input
+    LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
+    LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
+
+    -- load image and upload texture
+    Right img <- Juicy.readImage "logo.png"
+    textureData <- LambdaCubeGL.uploadTexture2DToGPU img
+
+    -- allocate GL pipeline
+    renderer <- LambdaCubeGL.allocRenderer pipelineDesc
+    LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility
+      Just err -> putStrLn err
+      Nothing  -> do qsig <- newMVar False
+                     GLUT.keyboardMouseCallback GLUT.$= Just (keyCB qsig)
+                     loop qsig
+        where loop qsig = do
+                -- update graphics input
+                -- GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
+                GLUT.get GLUT.windowSize >>= \(GLUT.Size w h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
+                LambdaCubeGL.updateUniforms storage $ do
+                  "diffuseTexture" @= return textureData
+                  "time" @= do
+                              -- Just t <- GLFW.getTime
+                              Just t <- Just . (* (1000.0 :: Double)) . fromIntegral <$> GLUT.elapsedTime
+                              return (realToFrac t :: Float)
+                -- render
+                LambdaCubeGL.renderFrame renderer
+                -- GLFW.swapBuffers win
+                GLUT.swapBuffers
+                -- GLFW.pollEvents
+                GLUT.mainLoopEvent
+
+                -- let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k
+                -- escape <- keyIsPressed Key'Escape
+                escape <- withMVar qsig return
+                if escape then return () else loop qsig
+
+              keyCB :: MVar Bool -> GLUT.KeyboardMouseCallback
+              keyCB qsig key keyState mods pos= do
+                cw <- GLUT.get GLUT.currentWindow
+                case (keyState,key,cw) of
+                    (GLUT.Down,GLUT.Char 'q',Just cw) -> do
+                        modifyMVar_ qsig (const $ return True)
+                        GLUT.destroyWindow cw
+                    (GLUT.Down,_,_)-> GLUT.postRedisplay Nothing
+                    _ -> return ()
+
+    LambdaCubeGL.disposeRenderer renderer
+    LambdaCubeGL.disposeStorage storage
+    GLFW.destroyWindow win
+    -- GLFW.terminate
+
+-- geometry data: triangles
+triangleA :: LambdaCubeGL.Mesh
+triangleA = Mesh
+    { mAttributes   = Map.fromList
+        [ ("position",  A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])
+        , ("uv",        A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])
+        ]
+    , mPrimitive    = P_Triangles
+    }
+
+triangleB :: LambdaCubeGL.Mesh
+triangleB = Mesh
+    { mAttributes   = Map.fromList
+        [ ("position",  A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])
+        , ("uv",        A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])
+        ]
+    , mPrimitive    = P_Triangles
+    }
+
+initWindow :: String -> Int -> Int -> IO Window
+initWindow title width height = do
+    {-
+    GLFW.init
+    GLFW.defaultWindowHints
+    mapM_ GLFW.windowHint
+      [ WindowHint'ContextVersionMajor 3
+      , WindowHint'ContextVersionMinor 3
+      , WindowHint'OpenGLProfile OpenGLProfile'Core
+      , WindowHint'OpenGLForwardCompat True
+      ]
+    Just win <- GLFW.createWindow width height title Nothing Nothing
+    GLFW.makeContextCurrent $ Just win
+    -}
+    (progname,args) <- GLUT.getArgsAndInitialize
+    win <- GLUT.createWindow title
+    GLUT.actionOnWindowClose GLUT.$=! GLUT.MainLoopReturns
+    return win
+
diff --git a/Tut.hs b/Tut.hs
new file mode 100644
index 0000000..0ae5494
--- /dev/null
+++ b/Tut.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedLists   #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import qualified GI.Gtk                        as Gtk
+import           GI.Gtk.Declarative
+import           GI.Gtk.Declarative.App.Simple
+
+type State = ()
+
+data Event = Closed
+
+view' :: State -> AppView Gtk.Window Event
+view' _ = bin
+    Gtk.Window
+    [ #title := "Demo"
+    , on #deleteEvent $ {- GI.Gdk.Unions.Event.Event -> (Bool, Event) -} \_ -> (True,Closed)
+    ]
+    $ widget Gtk.Label [#label := "Hello, World!"]
+
+update' :: State -> Event -> Transition State Event
+update' _ Closed = Exit
+
+main :: IO ()
+main = run App
+    -- :: App Gtk.Window State Event
+    { view         = view'
+    , update       = update'
+    , inputs       = []
+    , initialState = ()
+    }
diff --git a/hello.json b/hello.json
new file mode 100644
index 0000000..22f3ff1
--- /dev/null
+++ b/hello.json
@@ -0,0 +1 @@
+{"textures":[],"commands":[{"tag":"SetRenderTarget","arg0":0},{"tag":"ClearRenderTarget","arg0":[{"tag":"ClearImage","clearValue":{"tag":"VV4F","arg0":{"w":1,"z":0.4,"x":0.0,"y":0.0}},"imageSemantic":{"tag":"Color"}}]},{"tag":"SetProgram","arg0":0},{"tag":"SetSamplerUniform","arg0":"diffuseTexture","arg1":0},{"tag":"SetRasterContext","arg0":{"arg3":{"tag":"LastVertex"},"tag":"TriangleCtx","arg0":{"tag":"CullNone"},"arg1":{"tag":"PolygonFill"},"arg2":{"tag":"NoOffset"}}},{"tag":"SetAccumulationContext","arg0":{"accViewportName":null,"tag":"AccumulationContext","accOperations":[{"tag":"ColorOp","arg0":{"tag":"NoBlending"},"arg1":{"tag":"VV4B","arg0":{"w":true,"z":true,"x":true,"y":true}}}]}},{"tag":"RenderSlot","arg0":0}],"slots":[{"tag":"Slot","slotPrimitive":{"tag":"Triangles"},"slotStreams":{"uv":{"tag":"V2F"},"position":{"tag":"V2F"}},"slotName":"objects","slotUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}},"slotPrograms":[0]}],"programs":[{"programInTextures":{"diffuseTexture":{"tag":"FTexture2D"}},"tag":"Program","programOutput":[{"tag":"Parameter","ty":{"tag":"V4F"},"name":"f0"}],"programStreams":{"vi2":{"tag":"Parameter","ty":{"tag":"V2F"},"name":"uv"},"vi1":{"tag":"Parameter","ty":{"tag":"V2F"},"name":"position"}},"fragmentShader":"#version 330 core\nvec4 texture2D(sampler2D s\n              ,vec2 uv) {\n    return texture(s,uv);\n}\nuniform sampler2D diffuseTexture;\nsmooth in vec2 vo1;\nout vec4 f0;\nvoid main() {\n    f0 = texture2D (diffuseTexture\n                   ,vo1);\n}","vertexShader":"#version 330 core\nvec4 texture2D(sampler2D s\n              ,vec2 uv) {\n    return texture(s,uv);\n}\nuniform float time;\nin vec2 vi1;\nin vec2 vi2;\nsmooth out vec2 vo1;\nmat4 rotMatrixZ(float z0) {\n    return mat4 (vec4 (cos (z0)\n                      ,sin (z0)\n                      ,0.0\n                      ,0.0)\n                ,vec4 ((0.0) - (sin (z0))\n                      ,cos (z0)\n                      ,0.0\n                      ,0.0)\n                ,vec4 (0.0,0.0,1.0,0.0)\n                ,vec4 (0.0,0.0,0.0,1.0));\n}\nvoid main() {\n    gl_Position = (rotMatrixZ\n        (time)) * (vec4 ((vi1).x\n                        ,(vi1).y\n                        ,-1.0\n                        ,1.0));\n    vo1 = vi2;\n}","geometryShader":null,"programUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}}}],"samplers":[],"tag":"Pipeline","backend":{"tag":"OpenGL33"},"streams":[],"targets":[{"tag":"RenderTarget","renderTargets":[{"tag":"TargetItem","targetSemantic":{"tag":"Color"},"targetRef":{"tag":"Framebuffer","arg0":{"tag":"Color"}}}]}],"info":"generated by lambdacube-compiler 0.5.0.0"}
\ No newline at end of file
diff --git a/hello.lc b/hello.lc
new file mode 100644
index 0000000..5837a82
--- /dev/null
+++ b/hello.lc
@@ -0,0 +1,16 @@
+makeFrame (time :: Float)
+          (texture :: Texture)
+          (prims :: PrimitiveStream Triangle (Vec 2 Float, Vec 2 Float))
+
+    = imageFrame ((emptyColorImage (V4 0 0 0.4 1)))
+  `overlay`
+      prims
+    & mapPrimitives (\(p,uv) -> (rotMatrixZ time *. (V4 p%x p%y (-1) 1), uv))
+    & rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) ((Smooth))
+    & mapFragments (\((uv)) -> ((texture2D (Sampler PointFilter MirroredRepeat texture) uv)))
+    & accumulateWith ((ColorOp NoBlending (V4 True True True True)))
+
+main = renderFrame $
+   makeFrame (Uniform "time")
+             (Texture2DSlot "diffuseTexture")
+             (fetch "objects" (Attribute "position", Attribute "uv"))