From 0d46a5cda433fe1a97f3c35002c192d8050e747a Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Fri, 29 Jan 2016 15:24:25 +0100 Subject: intial version of backend test client --- Monkey.lcmesh | Bin 371791 -> 0 bytes testclient/TestData.hs | 213 +++++++++++++++++++++++++++++++++++++++++++++++++ testclient/client.hs | 187 +++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 400 insertions(+) delete mode 100644 Monkey.lcmesh create mode 100644 testclient/TestData.hs create mode 100644 testclient/client.hs diff --git a/Monkey.lcmesh b/Monkey.lcmesh deleted file mode 100644 index b651d61..0000000 Binary files a/Monkey.lcmesh and /dev/null 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 @@ +-- generated file, do not modify! +-- 2016-01-28T13:15:31.27456Z + +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +module TestData where + +import Data.Int +import Data.Word +import Data.Map +import Data.Vector (Vector(..)) +import LambdaCube.Linear + +import Data.Text +import Data.Aeson hiding (Value,Bool) +import Data.Aeson.Types hiding (Value,Bool) +import Control.Monad + +import LambdaCube.IR +import LambdaCube.Mesh +import LambdaCube.PipelineSchema + +data ClientInfo + = ClientInfo + { clientName :: String + , clientBackend :: Backend + } + + deriving (Show, Eq, Ord) + +data Frame + = Frame + { renderCount :: Int + , frameUniforms :: Map String Value + , frameTextures :: Map String Int + } + + deriving (Show, Eq, Ord) + +data Scene + = Scene + { objectArrays :: Map String (Vector Int) + , renderTargetWidth :: Int + , renderTargetHeight :: Int + , frames :: Vector Frame + } + + deriving (Show, Eq, Ord) + +data RenderJob + = RenderJob + { meshes :: Vector Mesh + , textures :: Vector String + , schema :: PipelineSchema + , scenes :: Vector Scene + , pipelines :: Vector Pipeline + } + + deriving (Show, Eq, Ord) + +data FrameResult + = FrameResult + { frRenderTimes :: Vector Float + , frImageWidth :: Int + , frImageHeight :: Int + } + + deriving (Show, Eq, Ord) + +data RenderJobResult + = RenderJobResult FrameResult + | RenderJobError String + deriving (Show, Eq, Ord) + + +instance ToJSON ClientInfo where + toJSON v = case v of + ClientInfo{..} -> object + [ "tag" .= ("ClientInfo" :: Text) + , "clientName" .= clientName + , "clientBackend" .= clientBackend + ] + +instance FromJSON ClientInfo where + parseJSON (Object obj) = do + tag <- obj .: "tag" + case tag :: Text of + "ClientInfo" -> do + clientName <- obj .: "clientName" + clientBackend <- obj .: "clientBackend" + pure $ ClientInfo + { clientName = clientName + , clientBackend = clientBackend + } + parseJSON _ = mzero + +instance ToJSON Frame where + toJSON v = case v of + Frame{..} -> object + [ "tag" .= ("Frame" :: Text) + , "renderCount" .= renderCount + , "frameUniforms" .= frameUniforms + , "frameTextures" .= frameTextures + ] + +instance FromJSON Frame where + parseJSON (Object obj) = do + tag <- obj .: "tag" + case tag :: Text of + "Frame" -> do + renderCount <- obj .: "renderCount" + frameUniforms <- obj .: "frameUniforms" + frameTextures <- obj .: "frameTextures" + pure $ Frame + { renderCount = renderCount + , frameUniforms = frameUniforms + , frameTextures = frameTextures + } + parseJSON _ = mzero + +instance ToJSON Scene where + toJSON v = case v of + Scene{..} -> object + [ "tag" .= ("Scene" :: Text) + , "objectArrays" .= objectArrays + , "renderTargetWidth" .= renderTargetWidth + , "renderTargetHeight" .= renderTargetHeight + , "frames" .= frames + ] + +instance FromJSON Scene where + parseJSON (Object obj) = do + tag <- obj .: "tag" + case tag :: Text of + "Scene" -> do + objectArrays <- obj .: "objectArrays" + renderTargetWidth <- obj .: "renderTargetWidth" + renderTargetHeight <- obj .: "renderTargetHeight" + frames <- obj .: "frames" + pure $ Scene + { objectArrays = objectArrays + , renderTargetWidth = renderTargetWidth + , renderTargetHeight = renderTargetHeight + , frames = frames + } + parseJSON _ = mzero + +instance ToJSON RenderJob where + toJSON v = case v of + RenderJob{..} -> object + [ "tag" .= ("RenderJob" :: Text) + , "meshes" .= meshes + , "textures" .= textures + , "schema" .= schema + , "scenes" .= scenes + , "pipelines" .= pipelines + ] + +instance FromJSON RenderJob where + parseJSON (Object obj) = do + tag <- obj .: "tag" + case tag :: Text of + "RenderJob" -> do + meshes <- obj .: "meshes" + textures <- obj .: "textures" + schema <- obj .: "schema" + scenes <- obj .: "scenes" + pipelines <- obj .: "pipelines" + pure $ RenderJob + { meshes = meshes + , textures = textures + , schema = schema + , scenes = scenes + , pipelines = pipelines + } + parseJSON _ = mzero + +instance ToJSON FrameResult where + toJSON v = case v of + FrameResult{..} -> object + [ "tag" .= ("FrameResult" :: Text) + , "frRenderTimes" .= frRenderTimes + , "frImageWidth" .= frImageWidth + , "frImageHeight" .= frImageHeight + ] + +instance FromJSON FrameResult where + parseJSON (Object obj) = do + tag <- obj .: "tag" + case tag :: Text of + "FrameResult" -> do + frRenderTimes <- obj .: "frRenderTimes" + frImageWidth <- obj .: "frImageWidth" + frImageHeight <- obj .: "frImageHeight" + pure $ FrameResult + { frRenderTimes = frRenderTimes + , frImageWidth = frImageWidth + , frImageHeight = frImageHeight + } + parseJSON _ = mzero + +instance ToJSON RenderJobResult where + toJSON v = case v of + RenderJobResult arg0 -> object [ "tag" .= ("RenderJobResult" :: Text), "arg0" .= arg0] + RenderJobError arg0 -> object [ "tag" .= ("RenderJobError" :: Text), "arg0" .= arg0] + +instance FromJSON RenderJobResult where + parseJSON (Object obj) = do + tag <- obj .: "tag" + case tag :: Text of + "RenderJobResult" -> RenderJobResult <$> obj .: "arg0" + "RenderJobError" -> RenderJobError <$> obj .: "arg0" + parseJSON _ = mzero + 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 @@ +{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-} + +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Catch +import Data.Text (Text) +import Data.Vector (Vector,(!)) +import Data.ByteString.Char8 (unpack,pack) +import qualified Data.ByteString as SB +import qualified Data.Vector as V +import qualified Data.Map as Map +import qualified Data.ByteString.Base64 as B64 + +import System.Exit +import Data.Time.Clock +import Data.Aeson +import Foreign + +import qualified Network.WebSockets as WS +import Network.Socket + +import "GLFW-b" Graphics.UI.GLFW as GLFW +import "OpenGLRaw" Graphics.GL.Core33 +import Codec.Picture as Juicy + +import LambdaCube.IR +import LambdaCube.PipelineSchema +import LambdaCube.Mesh +import LambdaCube.GL +import LambdaCube.GL.Mesh +import TestData + +main = do + win <- initWindow "LambdaCube 3D OpenGL 3.3 Backend" 256 256 + + GLFW.setWindowCloseCallback win $ Just $ \_ -> do + GLFW.destroyWindow win + GLFW.terminate + exitSuccess + + -- connect to the test server + forever $ catchAll (setupConnection win) $ \_ -> do + GLFW.pollEvents + threadDelay 100000 + +setupConnection win = withSocketsDo $ WS.runClient "192.168.0.12" 9160 "/" $ \conn -> do + putStrLn "Connected!" + -- register backend + WS.sendTextData conn . encode $ ClientInfo + { clientName = "Haskell OpenGL 3.3" + , clientBackend = OpenGL33 + } + chan <- newEmptyMVar :: IO (MVar RenderJob) + -- wait for incoming render jobs + _ <- forkIO $ forever $ do + -- get the pipeline from the server + decodeStrict <$> WS.receiveData conn >>= \case + Nothing -> putStrLn "unknown message" + Just renderJob -> putMVar chan renderJob + -- process render jobs + forever $ do + tryTakeMVar chan >>= \case + Nothing -> return () + Just rj -> processRenderJob win conn rj + WS.sendPing conn ("hello" :: Text) + GLFW.pollEvents + threadDelay 100000 + putStrLn "disconnected" + WS.sendClose conn ("Bye!" :: Text) + +doAfter = flip (>>) + +processRenderJob win conn renderJob@RenderJob{..} = do + putStrLn "got render job" + gpuData@GPUData{..} <- allocateGPUData renderJob + -- foreach pipeline + doAfter (disposeGPUData gpuData) $ forM_ pipelines $ \pipelineDesc -> do + renderer <- allocRenderer pipelineDesc + -- foreach scene + doAfter (disposeRenderer renderer) $ forM_ scenes $ \Scene{..} -> do + storage <- allocStorage schema + -- add objects + forM_ (Map.toList objectArrays) $ \(name,objs) -> forM_ objs $ addMeshToObjectArray storage name [] . (gpuMeshes !) + -- set render target size + GLFW.setWindowSize win renderTargetWidth renderTargetHeight + setScreenSize storage (fromIntegral renderTargetWidth) (fromIntegral renderTargetHeight) + -- connect renderer with storage + doAfter (disposeStorage storage) $ setStorage renderer storage >>= \case + Just err -> putStrLn err + Nothing -> do + -- foreach frame + forM_ frames $ \Frame{..} -> do + -- setup uniforms + updateUniforms storage $ do + forM_ (Map.toList frameTextures) $ \(name,tex) -> pack name @= return (gpuTextures ! tex) + forM_ (Map.toList frameUniforms) $ uncurry setUniformValue + -- rendering + renderTimes <- V.replicateM renderCount . timeDiff $ do + renderFrame renderer + GLFW.swapBuffers win + GLFW.pollEvents + -- send render job result to server + WS.sendTextData conn . encode . RenderJobResult $ FrameResult + { frRenderTimes = renderTimes + , frImageWidth = renderTargetWidth + , frImageHeight = renderTargetHeight + } + -- send the last render result using Base64 encoding + WS.sendBinaryData conn . B64.encode =<< getFrameBuffer renderTargetWidth renderTargetHeight + +-- utility code + +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 + +getFrameBuffer w h = do + glFinish + glBindFramebuffer GL_READ_FRAMEBUFFER 0 + glReadBuffer GL_FRONT_LEFT + glBlitFramebuffer 0 0 (fromIntegral w) (fromIntegral h) 0 (fromIntegral h) (fromIntegral w) 0 GL_COLOR_BUFFER_BIT GL_NEAREST + glReadBuffer GL_BACK_LEFT + withFrameBuffer 0 0 w h $ \p -> SB.packCStringLen (castPtr p,w*h*4) + +withFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO a) -> IO a +withFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do + glPixelStorei GL_UNPACK_LSB_FIRST 0 + glPixelStorei GL_UNPACK_SWAP_BYTES 0 + glPixelStorei GL_UNPACK_ROW_LENGTH 0 + 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 -- normally 4! + glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) GL_RGBA GL_UNSIGNED_BYTE $ castPtr p + fn p + +data GPUData + = GPUData + { gpuTextures :: Vector TextureData + , gpuMeshes :: Vector GPUMesh + } + +allocateGPUData RenderJob{..} = GPUData <$> mapM uploadTex2D textures <*> mapM uploadMeshToGPU meshes + where uploadTex2D = uploadTexture2DToGPU . either error id . decodeImage . either error id . B64.decode . pack + +disposeGPUData GPUData{..} = mapM_ disposeTexture gpuTextures >> mapM_ disposeMesh gpuMeshes + +timeDiff m = (\s e -> realToFrac $ diffUTCTime e s) <$> getCurrentTime <* m <*> getCurrentTime + +setUniformValue name = \case + VBool v -> pack name @= return v + VV2B v -> pack name @= return v + VV3B v -> pack name @= return v + VV4B v -> pack name @= return v + VWord v -> pack name @= return v + VV2U v -> pack name @= return v + VV3U v -> pack name @= return v + VV4U v -> pack name @= return v + VInt v -> pack name @= return v + VV2I v -> pack name @= return v + VV3I v -> pack name @= return v + VV4I v -> pack name @= return v + VFloat v -> pack name @= return v + VV2F v -> pack name @= return v + VV3F v -> pack name @= return v + VV4F v -> pack name @= return v + VM22F v -> pack name @= return v + VM23F v -> pack name @= return v + VM24F v -> pack name @= return v + VM32F v -> pack name @= return v + VM33F v -> pack name @= return v + VM34F v -> pack name @= return v + VM42F v -> pack name @= return v + VM43F v -> pack name @= return v + VM44F v -> pack name @= return v -- cgit v1.2.3