summaryrefslogtreecommitdiff
path: root/examples/pickInt.hs
blob: 2703e916c8d3d9a46c8dd51f244dc14b6351ee56 (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
{-# 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