diff options
-rw-r--r-- | Monkey.lcmesh | bin | 371791 -> 0 bytes | |||
-rw-r--r-- | testclient/TestData.hs | 213 | ||||
-rw-r--r-- | testclient/client.hs | 187 |
3 files changed, 400 insertions, 0 deletions
diff --git a/Monkey.lcmesh b/Monkey.lcmesh deleted file mode 100644 index b651d61..0000000 --- a/Monkey.lcmesh +++ /dev/null | |||
Binary files differ | |||
diff --git a/testclient/TestData.hs b/testclient/TestData.hs new file mode 100644 index 0000000..a48dc42 --- /dev/null +++ b/testclient/TestData.hs | |||
@@ -0,0 +1,213 @@ | |||
1 | -- generated file, do not modify! | ||
2 | -- 2016-01-28T13:15:31.27456Z | ||
3 | |||
4 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} | ||
5 | module TestData where | ||
6 | |||
7 | import Data.Int | ||
8 | import Data.Word | ||
9 | import Data.Map | ||
10 | import Data.Vector (Vector(..)) | ||
11 | import LambdaCube.Linear | ||
12 | |||
13 | import Data.Text | ||
14 | import Data.Aeson hiding (Value,Bool) | ||
15 | import Data.Aeson.Types hiding (Value,Bool) | ||
16 | import Control.Monad | ||
17 | |||
18 | import LambdaCube.IR | ||
19 | import LambdaCube.Mesh | ||
20 | import LambdaCube.PipelineSchema | ||
21 | |||
22 | data ClientInfo | ||
23 | = ClientInfo | ||
24 | { clientName :: String | ||
25 | , clientBackend :: Backend | ||
26 | } | ||
27 | |||
28 | deriving (Show, Eq, Ord) | ||
29 | |||
30 | data Frame | ||
31 | = Frame | ||
32 | { renderCount :: Int | ||
33 | , frameUniforms :: Map String Value | ||
34 | , frameTextures :: Map String Int | ||
35 | } | ||
36 | |||
37 | deriving (Show, Eq, Ord) | ||
38 | |||
39 | data Scene | ||
40 | = Scene | ||
41 | { objectArrays :: Map String (Vector Int) | ||
42 | , renderTargetWidth :: Int | ||
43 | , renderTargetHeight :: Int | ||
44 | , frames :: Vector Frame | ||
45 | } | ||
46 | |||
47 | deriving (Show, Eq, Ord) | ||
48 | |||
49 | data RenderJob | ||
50 | = RenderJob | ||
51 | { meshes :: Vector Mesh | ||
52 | , textures :: Vector String | ||
53 | , schema :: PipelineSchema | ||
54 | , scenes :: Vector Scene | ||
55 | , pipelines :: Vector Pipeline | ||
56 | } | ||
57 | |||
58 | deriving (Show, Eq, Ord) | ||
59 | |||
60 | data FrameResult | ||
61 | = FrameResult | ||
62 | { frRenderTimes :: Vector Float | ||
63 | , frImageWidth :: Int | ||
64 | , frImageHeight :: Int | ||
65 | } | ||
66 | |||
67 | deriving (Show, Eq, Ord) | ||
68 | |||
69 | data RenderJobResult | ||
70 | = RenderJobResult FrameResult | ||
71 | | RenderJobError String | ||
72 | deriving (Show, Eq, Ord) | ||
73 | |||
74 | |||
75 | instance ToJSON ClientInfo where | ||
76 | toJSON v = case v of | ||
77 | ClientInfo{..} -> object | ||
78 | [ "tag" .= ("ClientInfo" :: Text) | ||
79 | , "clientName" .= clientName | ||
80 | , "clientBackend" .= clientBackend | ||
81 | ] | ||
82 | |||
83 | instance FromJSON ClientInfo where | ||
84 | parseJSON (Object obj) = do | ||
85 | tag <- obj .: "tag" | ||
86 | case tag :: Text of | ||
87 | "ClientInfo" -> do | ||
88 | clientName <- obj .: "clientName" | ||
89 | clientBackend <- obj .: "clientBackend" | ||
90 | pure $ ClientInfo | ||
91 | { clientName = clientName | ||
92 | , clientBackend = clientBackend | ||
93 | } | ||
94 | parseJSON _ = mzero | ||
95 | |||
96 | instance ToJSON Frame where | ||
97 | toJSON v = case v of | ||
98 | Frame{..} -> object | ||
99 | [ "tag" .= ("Frame" :: Text) | ||
100 | , "renderCount" .= renderCount | ||
101 | , "frameUniforms" .= frameUniforms | ||
102 | , "frameTextures" .= frameTextures | ||
103 | ] | ||
104 | |||
105 | instance FromJSON Frame where | ||
106 | parseJSON (Object obj) = do | ||
107 | tag <- obj .: "tag" | ||
108 | case tag :: Text of | ||
109 | "Frame" -> do | ||
110 | renderCount <- obj .: "renderCount" | ||
111 | frameUniforms <- obj .: "frameUniforms" | ||
112 | frameTextures <- obj .: "frameTextures" | ||
113 | pure $ Frame | ||
114 | { renderCount = renderCount | ||
115 | , frameUniforms = frameUniforms | ||
116 | , frameTextures = frameTextures | ||
117 | } | ||
118 | parseJSON _ = mzero | ||
119 | |||
120 | instance ToJSON Scene where | ||
121 | toJSON v = case v of | ||
122 | Scene{..} -> object | ||
123 | [ "tag" .= ("Scene" :: Text) | ||
124 | , "objectArrays" .= objectArrays | ||
125 | , "renderTargetWidth" .= renderTargetWidth | ||
126 | , "renderTargetHeight" .= renderTargetHeight | ||
127 | , "frames" .= frames | ||
128 | ] | ||
129 | |||
130 | instance FromJSON Scene where | ||
131 | parseJSON (Object obj) = do | ||
132 | tag <- obj .: "tag" | ||
133 | case tag :: Text of | ||
134 | "Scene" -> do | ||
135 | objectArrays <- obj .: "objectArrays" | ||
136 | renderTargetWidth <- obj .: "renderTargetWidth" | ||
137 | renderTargetHeight <- obj .: "renderTargetHeight" | ||
138 | frames <- obj .: "frames" | ||
139 | pure $ Scene | ||
140 | { objectArrays = objectArrays | ||
141 | , renderTargetWidth = renderTargetWidth | ||
142 | , renderTargetHeight = renderTargetHeight | ||
143 | , frames = frames | ||
144 | } | ||
145 | parseJSON _ = mzero | ||
146 | |||
147 | instance ToJSON RenderJob where | ||
148 | toJSON v = case v of | ||
149 | RenderJob{..} -> object | ||
150 | [ "tag" .= ("RenderJob" :: Text) | ||
151 | , "meshes" .= meshes | ||
152 | , "textures" .= textures | ||
153 | , "schema" .= schema | ||
154 | , "scenes" .= scenes | ||
155 | , "pipelines" .= pipelines | ||
156 | ] | ||
157 | |||
158 | instance FromJSON RenderJob where | ||
159 | parseJSON (Object obj) = do | ||
160 | tag <- obj .: "tag" | ||
161 | case tag :: Text of | ||
162 | "RenderJob" -> do | ||
163 | meshes <- obj .: "meshes" | ||
164 | textures <- obj .: "textures" | ||
165 | schema <- obj .: "schema" | ||
166 | scenes <- obj .: "scenes" | ||
167 | pipelines <- obj .: "pipelines" | ||
168 | pure $ RenderJob | ||
169 | { meshes = meshes | ||
170 | , textures = textures | ||
171 | , schema = schema | ||
172 | , scenes = scenes | ||
173 | , pipelines = pipelines | ||
174 | } | ||
175 | parseJSON _ = mzero | ||
176 | |||
177 | instance ToJSON FrameResult where | ||
178 | toJSON v = case v of | ||
179 | FrameResult{..} -> object | ||
180 | [ "tag" .= ("FrameResult" :: Text) | ||
181 | , "frRenderTimes" .= frRenderTimes | ||
182 | , "frImageWidth" .= frImageWidth | ||
183 | , "frImageHeight" .= frImageHeight | ||
184 | ] | ||
185 | |||
186 | instance FromJSON FrameResult where | ||
187 | parseJSON (Object obj) = do | ||
188 | tag <- obj .: "tag" | ||
189 | case tag :: Text of | ||
190 | "FrameResult" -> do | ||
191 | frRenderTimes <- obj .: "frRenderTimes" | ||
192 | frImageWidth <- obj .: "frImageWidth" | ||
193 | frImageHeight <- obj .: "frImageHeight" | ||
194 | pure $ FrameResult | ||
195 | { frRenderTimes = frRenderTimes | ||
196 | , frImageWidth = frImageWidth | ||
197 | , frImageHeight = frImageHeight | ||
198 | } | ||
199 | parseJSON _ = mzero | ||
200 | |||
201 | instance ToJSON RenderJobResult where | ||
202 | toJSON v = case v of | ||
203 | RenderJobResult arg0 -> object [ "tag" .= ("RenderJobResult" :: Text), "arg0" .= arg0] | ||
204 | RenderJobError arg0 -> object [ "tag" .= ("RenderJobError" :: Text), "arg0" .= arg0] | ||
205 | |||
206 | instance FromJSON RenderJobResult where | ||
207 | parseJSON (Object obj) = do | ||
208 | tag <- obj .: "tag" | ||
209 | case tag :: Text of | ||
210 | "RenderJobResult" -> RenderJobResult <$> obj .: "arg0" | ||
211 | "RenderJobError" -> RenderJobError <$> obj .: "arg0" | ||
212 | parseJSON _ = mzero | ||
213 | |||
diff --git a/testclient/client.hs b/testclient/client.hs new file mode 100644 index 0000000..236320c --- /dev/null +++ b/testclient/client.hs | |||
@@ -0,0 +1,187 @@ | |||
1 | {-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-} | ||
2 | |||
3 | import Control.Concurrent | ||
4 | import Control.Concurrent.MVar | ||
5 | import Control.Monad | ||
6 | import Control.Monad.Catch | ||
7 | import Data.Text (Text) | ||
8 | import Data.Vector (Vector,(!)) | ||
9 | import Data.ByteString.Char8 (unpack,pack) | ||
10 | import qualified Data.ByteString as SB | ||
11 | import qualified Data.Vector as V | ||
12 | import qualified Data.Map as Map | ||
13 | import qualified Data.ByteString.Base64 as B64 | ||
14 | |||
15 | import System.Exit | ||
16 | import Data.Time.Clock | ||
17 | import Data.Aeson | ||
18 | import Foreign | ||
19 | |||
20 | import qualified Network.WebSockets as WS | ||
21 | import Network.Socket | ||
22 | |||
23 | import "GLFW-b" Graphics.UI.GLFW as GLFW | ||
24 | import "OpenGLRaw" Graphics.GL.Core33 | ||
25 | import Codec.Picture as Juicy | ||
26 | |||
27 | import LambdaCube.IR | ||
28 | import LambdaCube.PipelineSchema | ||
29 | import LambdaCube.Mesh | ||
30 | import LambdaCube.GL | ||
31 | import LambdaCube.GL.Mesh | ||
32 | import TestData | ||
33 | |||
34 | main = do | ||
35 | win <- initWindow "LambdaCube 3D OpenGL 3.3 Backend" 256 256 | ||
36 | |||
37 | GLFW.setWindowCloseCallback win $ Just $ \_ -> do | ||
38 | GLFW.destroyWindow win | ||
39 | GLFW.terminate | ||
40 | exitSuccess | ||
41 | |||
42 | -- connect to the test server | ||
43 | forever $ catchAll (setupConnection win) $ \_ -> do | ||
44 | GLFW.pollEvents | ||
45 | threadDelay 100000 | ||
46 | |||
47 | setupConnection win = withSocketsDo $ WS.runClient "192.168.0.12" 9160 "/" $ \conn -> do | ||
48 | putStrLn "Connected!" | ||
49 | -- register backend | ||
50 | WS.sendTextData conn . encode $ ClientInfo | ||
51 | { clientName = "Haskell OpenGL 3.3" | ||
52 | , clientBackend = OpenGL33 | ||
53 | } | ||
54 | chan <- newEmptyMVar :: IO (MVar RenderJob) | ||
55 | -- wait for incoming render jobs | ||
56 | _ <- forkIO $ forever $ do | ||
57 | -- get the pipeline from the server | ||
58 | decodeStrict <$> WS.receiveData conn >>= \case | ||
59 | Nothing -> putStrLn "unknown message" | ||
60 | Just renderJob -> putMVar chan renderJob | ||
61 | -- process render jobs | ||
62 | forever $ do | ||
63 | tryTakeMVar chan >>= \case | ||
64 | Nothing -> return () | ||
65 | Just rj -> processRenderJob win conn rj | ||
66 | WS.sendPing conn ("hello" :: Text) | ||
67 | GLFW.pollEvents | ||
68 | threadDelay 100000 | ||
69 | putStrLn "disconnected" | ||
70 | WS.sendClose conn ("Bye!" :: Text) | ||
71 | |||
72 | doAfter = flip (>>) | ||
73 | |||
74 | processRenderJob win conn renderJob@RenderJob{..} = do | ||
75 | putStrLn "got render job" | ||
76 | gpuData@GPUData{..} <- allocateGPUData renderJob | ||
77 | -- foreach pipeline | ||
78 | doAfter (disposeGPUData gpuData) $ forM_ pipelines $ \pipelineDesc -> do | ||
79 | renderer <- allocRenderer pipelineDesc | ||
80 | -- foreach scene | ||
81 | doAfter (disposeRenderer renderer) $ forM_ scenes $ \Scene{..} -> do | ||
82 | storage <- allocStorage schema | ||
83 | -- add objects | ||
84 | forM_ (Map.toList objectArrays) $ \(name,objs) -> forM_ objs $ addMeshToObjectArray storage name [] . (gpuMeshes !) | ||
85 | -- set render target size | ||
86 | GLFW.setWindowSize win renderTargetWidth renderTargetHeight | ||
87 | setScreenSize storage (fromIntegral renderTargetWidth) (fromIntegral renderTargetHeight) | ||
88 | -- connect renderer with storage | ||
89 | doAfter (disposeStorage storage) $ setStorage renderer storage >>= \case | ||
90 | Just err -> putStrLn err | ||
91 | Nothing -> do | ||
92 | -- foreach frame | ||
93 | forM_ frames $ \Frame{..} -> do | ||
94 | -- setup uniforms | ||
95 | updateUniforms storage $ do | ||
96 | forM_ (Map.toList frameTextures) $ \(name,tex) -> pack name @= return (gpuTextures ! tex) | ||
97 | forM_ (Map.toList frameUniforms) $ uncurry setUniformValue | ||
98 | -- rendering | ||
99 | renderTimes <- V.replicateM renderCount . timeDiff $ do | ||
100 | renderFrame renderer | ||
101 | GLFW.swapBuffers win | ||
102 | GLFW.pollEvents | ||
103 | -- send render job result to server | ||
104 | WS.sendTextData conn . encode . RenderJobResult $ FrameResult | ||
105 | { frRenderTimes = renderTimes | ||
106 | , frImageWidth = renderTargetWidth | ||
107 | , frImageHeight = renderTargetHeight | ||
108 | } | ||
109 | -- send the last render result using Base64 encoding | ||
110 | WS.sendBinaryData conn . B64.encode =<< getFrameBuffer renderTargetWidth renderTargetHeight | ||
111 | |||
112 | -- utility code | ||
113 | |||
114 | initWindow :: String -> Int -> Int -> IO Window | ||
115 | initWindow title width height = do | ||
116 | GLFW.init | ||
117 | GLFW.defaultWindowHints | ||
118 | mapM_ GLFW.windowHint | ||
119 | [ WindowHint'ContextVersionMajor 3 | ||
120 | , WindowHint'ContextVersionMinor 3 | ||
121 | , WindowHint'OpenGLProfile OpenGLProfile'Core | ||
122 | , WindowHint'OpenGLForwardCompat True | ||
123 | ] | ||
124 | Just win <- GLFW.createWindow width height title Nothing Nothing | ||
125 | GLFW.makeContextCurrent $ Just win | ||
126 | return win | ||
127 | |||
128 | getFrameBuffer w h = do | ||
129 | glFinish | ||
130 | glBindFramebuffer GL_READ_FRAMEBUFFER 0 | ||
131 | glReadBuffer GL_FRONT_LEFT | ||
132 | glBlitFramebuffer 0 0 (fromIntegral w) (fromIntegral h) 0 (fromIntegral h) (fromIntegral w) 0 GL_COLOR_BUFFER_BIT GL_NEAREST | ||
133 | glReadBuffer GL_BACK_LEFT | ||
134 | withFrameBuffer 0 0 w h $ \p -> SB.packCStringLen (castPtr p,w*h*4) | ||
135 | |||
136 | withFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO a) -> IO a | ||
137 | withFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do | ||
138 | glPixelStorei GL_UNPACK_LSB_FIRST 0 | ||
139 | glPixelStorei GL_UNPACK_SWAP_BYTES 0 | ||
140 | glPixelStorei GL_UNPACK_ROW_LENGTH 0 | ||
141 | glPixelStorei GL_UNPACK_IMAGE_HEIGHT 0 | ||
142 | glPixelStorei GL_UNPACK_SKIP_ROWS 0 | ||
143 | glPixelStorei GL_UNPACK_SKIP_PIXELS 0 | ||
144 | glPixelStorei GL_UNPACK_SKIP_IMAGES 0 | ||
145 | glPixelStorei GL_UNPACK_ALIGNMENT 1 -- normally 4! | ||
146 | glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) GL_RGBA GL_UNSIGNED_BYTE $ castPtr p | ||
147 | fn p | ||
148 | |||
149 | data GPUData | ||
150 | = GPUData | ||
151 | { gpuTextures :: Vector TextureData | ||
152 | , gpuMeshes :: Vector GPUMesh | ||
153 | } | ||
154 | |||
155 | allocateGPUData RenderJob{..} = GPUData <$> mapM uploadTex2D textures <*> mapM uploadMeshToGPU meshes | ||
156 | where uploadTex2D = uploadTexture2DToGPU . either error id . decodeImage . either error id . B64.decode . pack | ||
157 | |||
158 | disposeGPUData GPUData{..} = mapM_ disposeTexture gpuTextures >> mapM_ disposeMesh gpuMeshes | ||
159 | |||
160 | timeDiff m = (\s e -> realToFrac $ diffUTCTime e s) <$> getCurrentTime <* m <*> getCurrentTime | ||
161 | |||
162 | setUniformValue name = \case | ||
163 | VBool v -> pack name @= return v | ||
164 | VV2B v -> pack name @= return v | ||
165 | VV3B v -> pack name @= return v | ||
166 | VV4B v -> pack name @= return v | ||
167 | VWord v -> pack name @= return v | ||
168 | VV2U v -> pack name @= return v | ||
169 | VV3U v -> pack name @= return v | ||
170 | VV4U v -> pack name @= return v | ||
171 | VInt v -> pack name @= return v | ||
172 | VV2I v -> pack name @= return v | ||
173 | VV3I v -> pack name @= return v | ||
174 | VV4I v -> pack name @= return v | ||
175 | VFloat v -> pack name @= return v | ||
176 | VV2F v -> pack name @= return v | ||
177 | VV3F v -> pack name @= return v | ||
178 | VV4F v -> pack name @= return v | ||
179 | VM22F v -> pack name @= return v | ||
180 | VM23F v -> pack name @= return v | ||
181 | VM24F v -> pack name @= return v | ||
182 | VM32F v -> pack name @= return v | ||
183 | VM33F v -> pack name @= return v | ||
184 | VM34F v -> pack name @= return v | ||
185 | VM42F v -> pack name @= return v | ||
186 | VM43F v -> pack name @= return v | ||
187 | VM44F v -> pack name @= return v | ||