summaryrefslogtreecommitdiff
path: root/Lambda2.hs
blob: 7677464b6eb2587aa2fd2c20d2a2cc2abbb400a1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Lambda2 where

import qualified Graphics.Rendering.OpenGL as GL

import GI.Gtk.Objects (GLArea,gLAreaGetContext,widgetGetWindow)
import GI.Gdk.Objects.GLContext (GLContext, gLContextGetDebugEnabled,
                                 gLContextGetForwardCompatible,
                                 gLContextSetDebugEnabled,
                                 gLContextSetForwardCompatible,
                                 gLContextGetRequiredVersion,
                                 gLContextSetRequiredVersion,
                                 gLContextGetUseEs,
                                 getGLContextWindow,
                                 gLContextMakeCurrent)
import GI.Gdk.Objects.Window (windowCreateGlContext,windowGetWidth,windowGetHeight)

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
import Data.Char
import Text.Printf
import System.IO

import qualified Backend as RF

data State = State

initState :: IO State
initState = do
    return State

render :: State -> GLArea -> GLContext -> IO Bool
render st glarea gl = do
    cf <- GL.get GL.cullFace
    oldvp <- GL.get GL.viewport
    putStrLn $ "cullface = " ++ show cf
    putStrLn $ "viewport = " ++ show oldvp
    GL.cullFace GL.$= Nothing

    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)
                (wd,ht) <- do
                        Just win <- getGLContextWindow gl
                        wd <- windowGetWidth win
                        ht <- windowGetHeight win
                        print (wd,ht)
                        return (wd,ht)
                vp <- GL.get GL.viewport
                dr <- GL.get GL.depthRange
                mm <- GL.get GL.matrixMode
                mat <- GL.get (GL.matrix $ Just mm)
                cs <- GL.getMatrixComponents GL.RowMajor mat
                dc <- GL.get GL.depthClamp
                tms <- mapM (GL.get . GL.textureGenMode) [GL.S, GL.T, GL.R, GL.Q]
                mx <- GL.get GL.maxViewportDims
                print (vp,(wd,ht),dr,mm,dc)
                print (mat :: GL.GLmatrix Double, cs)
                print (tms,mx)
                return (wd,ht) >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
                LambdaCubeGL.updateUniforms storage $ do
                  "diffuseTexture" @= return textureData
                  "time" @= do
                              Just t <- return $ Just (1.0::Double) -- GLFW.getTime
                              return (realToFrac t :: Float)
                -- render
                -- GL.clearColor GL.$= GL.Color4 0 0 0 0
                -- GL.clear [GL.ColorBuffer,GL.DepthBuffer]
                putStrLn "LambdaCubeGL.renderFrame enter.."
                -- mapM_ print $ glCommands renderer
                RF.renderFrame renderer
                putStrLn "LambdaCubeGL.renderFrame ..exit"
                -- GL.clear [GL.ColorBuffer,GL.DepthBuffer]
                -- GLFW.swapBuffers win
                -- GLFW.pollEvents
                -- GL.flush

                let keyIsPressed k = return True -- fmap (==KeyState'Pressed) $ GLFW.getKey win k
                escape <- keyIsPressed () -- Key'Escape
                if escape then return () else loop

    LambdaCubeGL.disposeRenderer renderer
    -- LambdaCubeGL.disposeStorage storage -- XXX: not implemented
    -- GLFW.destroyWindow win
    -- GLFW.terminate
    return True

-- 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
    }

realize :: State -> GLArea -> IO ()
realize st glarea = do
    putStrLn "realize!"
    {-
    GL.debugMessageInsert (GL.DebugMessage GL.DebugSourceApplication
                                           GL.DebugTypeOther
                                           (GL.DebugMessageID 0)
                                           GL.DebugSeverityHigh
                                           "Hello2 world!")
    -}
    return ()

unrealize :: State -> GLArea -> IO ()
unrealize st glarea = do
    return ()

prettyDebug :: GL.DebugMessage -> String
prettyDebug (GL.DebugMessage src typ (GL.DebugMessageID mid) severity msg) = unwords ws
 where
    ws = [wsrc,wtyp,wmid,wseverity,msg]
    -- DebugSourceShaderCompiler DebugTypeOther 1 DebugSeverityNotification
    wsrc = filter isUpper $ drop 11 $ show src
    wtyp = take 2 $ drop 9 $ show typ
    wmid = printf "%03i" mid
    wseverity = drop 13 $ show severity

createContext :: State -> GLArea -> IO GLContext
createContext st glarea = do
    putStrLn "createContext!"
    -- gl <- gLAreaGetContext glarea -- Remember to bind signal with 'after' so that this is not nullPtr.
    Just win <- widgetGetWindow glarea
    gl <- windowCreateGlContext win
    (maj,min) <- gLContextGetRequiredVersion gl
    -- (vmaj,vmin) <- gLContextGetVersion gl -- must be realized
    -- islegacy <- gLContextIsLegacy gl -- must be realized
    -- v_es <-gLContextGetUseEs gl

    v_db <- gLContextGetDebugEnabled gl
    v_fw <- gLContextGetForwardCompatible gl
    v_es <- gLContextGetUseEs gl
    putStrLn $ unwords [ "debug:",show v_db
                       , "fw:",show v_fw
                       , "es:", show v_es
                       , "ver:", show (maj,min)
                       ]
    gLContextSetDebugEnabled gl True
    gLContextSetForwardCompatible gl False -- True
    gLContextSetRequiredVersion gl 3 3
    v_db <- gLContextGetDebugEnabled gl
    v_fw <- gLContextGetForwardCompatible gl
    (maj,min) <- gLContextGetRequiredVersion gl
    putStrLn $ unwords [ "debug:",show v_db
                       , "fw:",show v_fw
                       , "ver:", show (maj,min)
                       ]
    let pdebug m@(GL.DebugMessage src typ mid severity msg) = do
            putStrLn (">> " ++ prettyDebug m)
    gLContextMakeCurrent gl
    GL.debugOutput GL.$= GL.Enabled
    GL.debugOutputSynchronous GL.$= GL.Enabled
    GL.debugMessageControl (GL.MessageGroup Nothing Nothing Nothing) GL.$= GL.Enabled
    GL.debugMessageCallback GL.$= Just pdebug
    {-
    GL.debugMessageInsert (GL.DebugMessage GL.DebugSourceApplication
                                           GL.DebugTypeOther
                                           (GL.DebugMessageID 0)
                                           GL.DebugSeverityHigh
                                           "Hello world!")
    -}
    return gl