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
|
{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, StandaloneDeriving, ViewPatterns #-}
import Control.Monad
import Data.Aeson
import Data.Vect (Mat4(..), Vec3(..), Vec4(..))
import Graphics.GL.Core33 as GL
import LambdaCube.GL as LambdaCubeGL
import LambdaCube.GL.Mesh as LambdaCubeGL
import Text.Printf
import "GLFW-b" Graphics.UI.GLFW as GLFW
import qualified Data.ByteString as SB
import qualified Data.Map as Map
import qualified Data.Vect as Vc
import qualified Data.Vector as V
import qualified Foreign as F
import qualified Foreign.C.Types as F
import qualified LambdaCube.GL.Type as LC
import qualified LambdaCube.Linear as LCLin
----------------------------------------------------
-- See: http://lambdacube3d.com/getting-started
----------------------------------------------------
screenDim :: (Int, Int)
screenDim = (800, 600)
(screenW, screenH) = screenDim
main :: IO ()
main = do
Just pipePickDesc <- decodeStrict <$> SB.readFile "pickInt.json"
Just pipeDrawDesc <- decodeStrict <$> SB.readFile "pickIntDraw.json"
win <- initWindow "LambdaCube 3D integer picking" 800 600
-- setup render data
let inputSchema = makeSchema $ do
defObjectArray "objects" Triangles $ do
"position" @: Attribute_V2F
"id" @: Attribute_Int
"color" @: Attribute_V4F
defUniforms $ do
"viewProj" @: M44F
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" []
-- allocate GL pipeline
pipePick <- LambdaCubeGL.allocRenderer pipePickDesc
pipeDraw <- LambdaCubeGL.allocRenderer pipeDrawDesc
errPick <- LambdaCubeGL.setStorage pipePick storage
errDraw <- LambdaCubeGL.setStorage pipeDraw storage
case (errPick, errDraw) of -- check schema compatibility
(Just err, _) -> putStrLn err
(_, Just err) -> putStrLn err
(Nothing, Nothing) -> loop
where loop = do
-- update graphics input
GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
LambdaCubeGL.updateUniforms storage $ do
let (x, y) = (,) 0 0
cvpos = Vec3 x (-y) 0
toScreen = screenM screenW screenH
"viewProj" @= pure (mat4ToM44F $! (Vc.fromProjective $! Vc.translation cvpos) Vc..*. toScreen)
(curX, curY) <- GLFW.getCursorPos win
let pickPoints = -- should be fb 0 fb 1 (pick)
[ (clamp curX 800, clamp curY 600)
, (0, 0) -- black 0
, (200, 200) -- ..blue, ffff0000 2
, (600, 400) -- ..red, ff0000ff 1
] :: [(Int, Int)]
clamp v m = min (pred m) $ max 0 (floor v)
-- render to render texture
LambdaCubeGL.renderFrame pipePick
case LC.glOutputs pipePick of
[LC.GLOutputRenderTexture (fromIntegral -> fbo) _rendTex] -> do
rtexPicks <- collectPicks fbo pickPoints
printPicks pickPoints rtexPicks
x -> error $ "Unexpected outputs: " ++ show x
-- render to framebuffer & pick
LambdaCubeGL.renderFrame pipeDraw
colorPicks <- collectPicks 0 pickPoints
printPicks pickPoints colorPicks
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
collectPicks :: Int -> [(Int, Int)] -> IO [Int]
collectPicks fb picks =
forM picks $ (fromIntegral <$>) . pickFrameBuffer fb screenDim
printPicks pickPoints colorPicks = do
forM_ (zip pickPoints colorPicks) $ \((x,y), col)-> do
printf "%d:%d: %x " x y col
putStrLn ""
LambdaCubeGL.disposeRenderer pipePick
LambdaCubeGL.disposeRenderer pipeDraw
LambdaCubeGL.disposeStorage storage
GLFW.destroyWindow win
GLFW.terminate
deriving instance Show (LC.GLOutput)
deriving instance Show (LC.GLTexture)
-- geometry data: triangles
scale = 250.0
s = scale
triangleA :: LambdaCubeGL.Mesh
triangleA = Mesh
{ mAttributes = Map.fromList
[ ("position", A_V2F $ V.fromList [V2 s s, V2 s (-s), V2 (-s) (-s)])
, ("color", A_V4F $ V.fromList $ take 4 $ repeat $ V4 1 0 0 1)
, ("id", A_Int $ V.fromList [1, 1, 1])
]
, mPrimitive = P_Triangles
}
triangleB :: LambdaCubeGL.Mesh
triangleB = Mesh
{ mAttributes = Map.fromList
[ ("position", A_V2F $ V.fromList [V2 s s, V2 (-s) (-s), V2 (-s) s])
, ("color", A_V4F $ V.fromList $ take 4 $ repeat $ V4 0 0 1 1)
, ("id", A_Int $ V.fromList [2, 2, 2])
]
, mPrimitive = P_Triangles
}
vec4ToV4F :: Vec4 -> LCLin.V4F
vec4ToV4F (Vc.Vec4 x y z w) = LCLin.V4 x y z w
mat4ToM44F :: Mat4 -> LCLin.M44F
mat4ToM44F (Mat4 a b c d) = LCLin.V4 (vec4ToV4F a) (vec4ToV4F b) (vec4ToV4F c) (vec4ToV4F d)
screenM :: Int -> Int -> Mat4
screenM w h = scaleM
where (fw, fh) = (fromIntegral w, fromIntegral h)
scaleM = Vc.Mat4 (Vc.Vec4 (1/fw) 0 0 0)
(Vc.Vec4 0 (1/fh) 0 0)
(Vc.Vec4 0 0 1 0)
(Vc.Vec4 0 0 0 0.5)
pickFrameBuffer
:: Int -- ^ framebuffer
-> (Int, Int) -- ^ FB dimensions
-> (Int, Int) -- ^ pick coordinates
-> IO F.Word32 -- ^ resultant pixel value
pickFrameBuffer fb (w, h) (x, y) = do
glFinish
glBindFramebuffer GL_READ_FRAMEBUFFER $ fromIntegral fb
let (fbmode, format) =
if fb == 0
then (GL_BACK_LEFT, GL_RGBA)
else (GL_COLOR_ATTACHMENT0, GL_RGBA_INTEGER)
glReadBuffer fbmode
withFrameBuffer w format x (h - y - 1) 1 1 $ \p -> fromIntegral <$> F.peek (F.castPtr p :: F.Ptr F.Word32)
withFrameBuffer :: Int -> GLenum -> Int -> Int -> Int -> Int -> (F.Ptr F.Word8 -> IO a) -> IO a
withFrameBuffer rowLen format x y w h fn = F.allocaBytes (w*h*4) $ \p -> do
glPixelStorei GL_UNPACK_LSB_FIRST 0
glPixelStorei GL_UNPACK_SWAP_BYTES 0
glPixelStorei GL_UNPACK_ROW_LENGTH $ fromIntegral rowLen
glPixelStorei GL_UNPACK_IMAGE_HEIGHT 0
glPixelStorei GL_UNPACK_SKIP_ROWS 0
glPixelStorei GL_UNPACK_SKIP_PIXELS 0
glPixelStorei GL_UNPACK_SKIP_IMAGES 0
glPixelStorei GL_UNPACK_ALIGNMENT 1
glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) format GL_UNSIGNED_BYTE $ F.castPtr p
glPixelStorei GL_UNPACK_ROW_LENGTH 0
fn p
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
|
