diff options
Diffstat (limited to 'Hello-glut.hs')
-rw-r--r-- | Hello-glut.hs | 129 |
1 files changed, 129 insertions, 0 deletions
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 @@ | |||
1 | {-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings #-} | ||
2 | import Control.Concurrent | ||
3 | |||
4 | -- import "GLFW-b" Graphics.UI.GLFW as GLFW | ||
5 | import qualified Graphics.UI.GLUT as GLFW -- lie | ||
6 | import qualified Graphics.UI.GLUT as GLUT -- truth | ||
7 | import Graphics.UI.GLUT (Window) | ||
8 | import qualified Data.Map as Map | ||
9 | import qualified Data.Vector as V | ||
10 | |||
11 | import LambdaCube.GL as LambdaCubeGL -- renderer | ||
12 | import LambdaCube.GL.Mesh as LambdaCubeGL | ||
13 | |||
14 | import Codec.Picture as Juicy | ||
15 | |||
16 | import Data.Aeson | ||
17 | import qualified Data.ByteString as SB | ||
18 | |||
19 | ---------------------------------------------------- | ||
20 | -- See: http://lambdacube3d.com/getting-started | ||
21 | ---------------------------------------------------- | ||
22 | |||
23 | main :: IO () | ||
24 | main = do | ||
25 | Just pipelineDesc <- decodeStrict <$> SB.readFile "hello.json" | ||
26 | |||
27 | win <- initWindow "LambdaCube 3D DSL Hello World" 640 640 | ||
28 | |||
29 | -- setup render data | ||
30 | let inputSchema = makeSchema $ do | ||
31 | defObjectArray "objects" Triangles $ do | ||
32 | "position" @: Attribute_V2F | ||
33 | "uv" @: Attribute_V2F | ||
34 | defUniforms $ do | ||
35 | "time" @: Float | ||
36 | "diffuseTexture" @: FTexture2D | ||
37 | |||
38 | storage <- LambdaCubeGL.allocStorage inputSchema | ||
39 | |||
40 | -- upload geometry to GPU and add to pipeline input | ||
41 | LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" [] | ||
42 | LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" [] | ||
43 | |||
44 | -- load image and upload texture | ||
45 | Right img <- Juicy.readImage "logo.png" | ||
46 | textureData <- LambdaCubeGL.uploadTexture2DToGPU img | ||
47 | |||
48 | -- allocate GL pipeline | ||
49 | renderer <- LambdaCubeGL.allocRenderer pipelineDesc | ||
50 | LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility | ||
51 | Just err -> putStrLn err | ||
52 | Nothing -> do qsig <- newMVar False | ||
53 | GLUT.keyboardMouseCallback GLUT.$= Just (keyCB qsig) | ||
54 | loop qsig | ||
55 | where loop qsig = do | ||
56 | -- update graphics input | ||
57 | -- GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h) | ||
58 | GLUT.get GLUT.windowSize >>= \(GLUT.Size w h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h) | ||
59 | LambdaCubeGL.updateUniforms storage $ do | ||
60 | "diffuseTexture" @= return textureData | ||
61 | "time" @= do | ||
62 | -- Just t <- GLFW.getTime | ||
63 | Just t <- Just . (* (1000.0 :: Double)) . fromIntegral <$> GLUT.elapsedTime | ||
64 | return (realToFrac t :: Float) | ||
65 | -- render | ||
66 | LambdaCubeGL.renderFrame renderer | ||
67 | -- GLFW.swapBuffers win | ||
68 | GLUT.swapBuffers | ||
69 | -- GLFW.pollEvents | ||
70 | GLUT.mainLoopEvent | ||
71 | |||
72 | -- let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k | ||
73 | -- escape <- keyIsPressed Key'Escape | ||
74 | escape <- withMVar qsig return | ||
75 | if escape then return () else loop qsig | ||
76 | |||
77 | keyCB :: MVar Bool -> GLUT.KeyboardMouseCallback | ||
78 | keyCB qsig key keyState mods pos= do | ||
79 | cw <- GLUT.get GLUT.currentWindow | ||
80 | case (keyState,key,cw) of | ||
81 | (GLUT.Down,GLUT.Char 'q',Just cw) -> do | ||
82 | modifyMVar_ qsig (const $ return True) | ||
83 | GLUT.destroyWindow cw | ||
84 | (GLUT.Down,_,_)-> GLUT.postRedisplay Nothing | ||
85 | _ -> return () | ||
86 | |||
87 | LambdaCubeGL.disposeRenderer renderer | ||
88 | LambdaCubeGL.disposeStorage storage | ||
89 | GLFW.destroyWindow win | ||
90 | -- GLFW.terminate | ||
91 | |||
92 | -- geometry data: triangles | ||
93 | triangleA :: LambdaCubeGL.Mesh | ||
94 | triangleA = Mesh | ||
95 | { mAttributes = Map.fromList | ||
96 | [ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)]) | ||
97 | , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0]) | ||
98 | ] | ||
99 | , mPrimitive = P_Triangles | ||
100 | } | ||
101 | |||
102 | triangleB :: LambdaCubeGL.Mesh | ||
103 | triangleB = Mesh | ||
104 | { mAttributes = Map.fromList | ||
105 | [ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1]) | ||
106 | , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0]) | ||
107 | ] | ||
108 | , mPrimitive = P_Triangles | ||
109 | } | ||
110 | |||
111 | initWindow :: String -> Int -> Int -> IO Window | ||
112 | initWindow title width height = do | ||
113 | {- | ||
114 | GLFW.init | ||
115 | GLFW.defaultWindowHints | ||
116 | mapM_ GLFW.windowHint | ||
117 | [ WindowHint'ContextVersionMajor 3 | ||
118 | , WindowHint'ContextVersionMinor 3 | ||
119 | , WindowHint'OpenGLProfile OpenGLProfile'Core | ||
120 | , WindowHint'OpenGLForwardCompat True | ||
121 | ] | ||
122 | Just win <- GLFW.createWindow width height title Nothing Nothing | ||
123 | GLFW.makeContextCurrent $ Just win | ||
124 | -} | ||
125 | (progname,args) <- GLUT.getArgsAndInitialize | ||
126 | win <- GLUT.createWindow title | ||
127 | GLUT.actionOnWindowClose GLUT.$=! GLUT.MainLoopReturns | ||
128 | return win | ||
129 | |||