WIP: Skybox for MeshSketch rework.

2 files changed, 52 insertions, 7 deletions

diff --git a/CubeMap.hs b/CubeMap.hs
index 337881f..10ba9e0 100644
--- a/CubeMap.hs
+++ b/CubeMap.hs
@@ -1,20 +1,23 @@
 module CubeMap
     ( loadSkyboxes
     , Skyboxes(..)
+    , cubeMesh
     ) where
 
 import LambdaCube.GL as LC
-import LambdaCube.GL.Mesh as LC
 import LambdaCube.GL.Data (uploadCubeMapToGPU)
+import LambdaCube.GL.Mesh as LC
 
-import Data.Maybe
+import Codec.Archive.Zip
+import Codec.Picture as Juicy
 import Control.Monad
+import qualified Data.ByteString.Lazy as Lazy
 import Data.List
+import qualified Data.Map as Map
+import Data.Maybe
+import qualified Data.Vector as V
 import System.Directory
 import System.FilePath
-import Codec.Archive.Zip
-import qualified Data.ByteString.Lazy as Lazy
-import Codec.Picture as Juicy
 
 image_names_xyz_dir :: [String]
 image_names_xyz_dir =
@@ -70,3 +73,24 @@ loadSkyboxes = do
                 return $ sequence imgs
         }
 
+cubeMesh :: Mesh
+cubeMesh = Mesh
+        { mAttributes = Map.singleton "position" $ A_V3F $ V.fromList
+            [ V3 1 (-1) (-1) -- 0
+            , V3 1 (-1)   1  -- 1
+            , V3 1   1    1  -- 2
+            , V3 1   1  (-1) -- 3
+            , V3 (-1) (-1)   1  -- 4
+            , V3 (-1) (-1) (-1) -- 5
+            , V3 (-1)   1  (-1) -- 6
+            , V3 (-1)   1    1  -- 7
+            ]
+        , mPrimitive = P_TrianglesI $ V.fromList
+            [ 0, 1, 2,  2, 3, 0 -- posx
+            , 4, 5, 6,  6, 7, 4 -- negx
+            , 6, 3, 2,  2, 7, 6 -- posy
+            , 4, 1, 0,  0, 5, 4 -- negy
+            , 1, 4, 7,  7, 2, 1 -- posz
+            , 5, 0, 3,  3, 6, 5 -- negz
+            ]
+        }
diff --git a/MeshSketch.hs b/MeshSketch.hs
index 1408710..288488b 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -30,7 +30,9 @@ import Control.Exception
 import LambdaCube.GL as LC
 import LambdaCube.IR as LC
 import LambdaCube.Gtk
+import LambdaCube.GL.Data (uploadCubeMapToGPU)
 
+import CubeMap
 import GLWidget (nullableContext, withCurrentGL)
 import LambdaCube.GL.HMatrix
 import LambdaCubeWidget (loadPipeline,DynamicPipeline(..))
@@ -45,6 +47,9 @@ data State = State
     { stAnimator   :: Animator
     , stCamera     :: IORef Camera
     , stFullscreen :: IO ()
+    , stSkyboxes   :: Skyboxes
+    , stSkybox     :: IORef Int
+    , stSkyTexture :: IORef TextureData
     }
 
 data Camera = Camera
@@ -122,11 +127,23 @@ uploadState obj glarea storage = do
     Just pwidget <- get w #parent
     Just parent <- get pwidget #window
     toggle <- mkFullscreenToggle parent
+    skyboxes <- loadSkyboxes
+    skybox <- newIORef 0
+    Right ts <- skyboxLoad skyboxes 0
+    skybox_id <- uploadCubeMapToGPU ts
+    -- LC.updateUniforms storage $ do
+    --    "CubeMap" @= return skybox_id
+    skytex <- newIORef skybox_id
+    mi <- LC.uploadMeshToGPU cubeMesh
+    -- LC.addMeshToObjectArray storage "SkyCube" [] mi -- TODO
 
     let st = State
             { stAnimator     = tm
             , stCamera       = cam
             , stFullscreen   = toggle
+            , stSkyboxes     = skyboxes
+            , stSkybox       = skybox
+            , stSkyTexture   = skytex
             }
     _ <- addAnimation tm (whirlingCamera st)
 
@@ -291,13 +308,17 @@ onEvent w realized ev = do
             kev <- get ev #key
             val <- get kev #keyval <&> \k -> if k > 0x5A then k - 0x20 else k
             case val of
-                {-
                 KEY_N -> do
                     modifyIORef' (stSkybox st) $ \n -> (n + 1) `mod` (skyboxCount $ stSkyboxes st)
                     idx <- readIORef (stSkybox st)
+                    Right ts <- skyboxLoad (stSkyboxes st) idx
+                    disposeTexture =<< readIORef (stSkyTexture st)
+                    skybox_id <- uploadCubeMapToGPU ts
+                    -- LC.updateUniforms storage $ do
+                    --    "CubeMap" @= return skybox_id
+                    writeIORef (stSkyTexture st) skybox_id
                     put (skyboxNames (stSkyboxes st) !! idx)
                     return ()
-                -}
                 KEY_F -> do
                     put 'F'
                     stFullscreen st