objdemo: pass view matrix from haskell.

7 files changed, 323 insertions, 23 deletions

diff --git a/GLWidget.hs b/GLWidget.hs
index 19ef129..8620c1a 100644
--- a/GLWidget.hs
+++ b/GLWidget.hs
@@ -82,7 +82,10 @@ oopsG e = do
 oops :: String -> IO ()
 oops s = hPutStrLn stderr s
 
-runGLApp :: IsWidget b => (GLArea -> IO b) -> WidgetMethods b -> IO ()
+runGLApp :: IsWidget b => (GLArea -> IO b) -- ^ Initialize a state object that will be passed
+                                           -- to all the event handlers.
+                       -> WidgetMethods b
+                       -> IO ()
 runGLApp mk methods = do
     _ <- Gtk.init Nothing
 
diff --git a/LambdaCube/GL/HMatrix.hs b/LambdaCube/GL/HMatrix.hs
new file mode 100644
index 0000000..ff5e7a7
--- /dev/null
+++ b/LambdaCube/GL/HMatrix.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module LambdaCube.GL.HMatrix where
+
+import GHC.TypeLits
+
+import LambdaCube.GL.Uniform
+import Numeric.LinearAlgebra
+import Numeric.LinearAlgebra.Devel
+
+import Graphics.Rendering.OpenGL.GL (GLboolean)
+
+instance Uniformable (Matrix Float) where
+    uniformContexts _ = contexts floatMatrices
+
+instance (KnownNat r, KnownNat c) => IsUniform (Matrix Float) (UMatrix r c Float) where
+    marshalUniform abi mat = case matrixDimensions abi of
+        (r,c) | fromIntegral (natVal r) /= rows mat -> Nothing
+              | fromIntegral (natVal c) /= cols mat -> Nothing
+        _ -> let isRowOrder = case orderOf mat of
+                        RowMajor    -> 1 :: GLboolean
+                        ColumnMajor -> 0 :: GLboolean
+             in Just $ MarshalUMatrix
+                     $ \f -> apply mat (\ptr -> f 1 isRowOrder ptr) (\r c sr sc ptr -> ptr)
+
+{-
+
+-- apply :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r
+{-# INLINE amat #-}
+amat :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r
+amat x f g = unsafeWith (xdat x) (f . g r c sr sc)
+  where
+    r  = fi (rows x)
+    c  = fi (cols x)
+    sr = fi (xRow x)
+    sc = fi (xCol x)
+
+
+apply (0 :: Matrix Float)
+  :: (b -> IO r)
+     -> (Foreign.C.Types.CInt
+     -> Foreign.C.Types.CInt
+     -> Foreign.C.Types.CInt
+     -> Foreign.C.Types.CInt
+     -> GHC.Ptr.Ptr Float
+     -> b)
+     -> IO r
+-}
diff --git a/Matrix.hs b/Matrix.hs
new file mode 100644
index 0000000..b47e223
--- /dev/null
+++ b/Matrix.hs
@@ -0,0 +1,230 @@
+{-# LANGUAGE BangPatterns, FlexibleContexts #-}
+module Matrix where
+
+import Numeric.LinearAlgebra
+import Foreign.Storable
+import Data.Vector.Generic as V (snoc,init)
+import Prelude hiding ((<>))
+
+rotMatrixX :: (Storable a, Floating a) => a -> Matrix a
+rotMatrixX a = (4><4)
+    [ 1 , 0 , 0  , 0
+    , 0 , c , -s , 0
+    , 0 , s , c  , 0
+    , 0 , 0 , 0  , 1 ] where (c,s) = (cos a, sin a)
+
+
+rotMatrixY :: (Storable a, Floating a) => a -> Matrix a
+rotMatrixY a = (4><4)
+    [  c , 0 , s , 0
+    ,  0 , 1 , 0 , 0
+    , -s , 0 , c , 0
+    ,  0 , 0 , 0 , 1 ] where (c,s) = (cos a, sin a)
+
+rotMatrixZ :: (Storable a, Floating a) => a -> Matrix a
+rotMatrixZ a = (4><4)
+    [ c , -s , 0 , 0
+    , s ,  c , 0 , 0
+    , 0 ,  0 , 1 , 0
+    , 0 ,  0 , 0 , 1 ] where (c,s) = (cos a, sin a)
+
+
+-- | Equivalent to
+--
+-- > translateBefore3to4 v m = translation v <> homoMatrix m
+--
+-- where translation and homoMatrix are taken as the usual transformations into
+-- the 4-dimensional homogeneous coordinate space.
+translateBefore3to4 :: Numeric t =>
+                        Vector t    -- 3 vector (translation)
+                        -> Matrix t -- 3><3 matrix (projection)
+                        -> Matrix t -- 4><4 matrix (projection)
+translateBefore3to4 v p3 = fromRows $ rs ++ [u]
+ where
+    !u = snoc (v <# p3) 1
+    rs = map (`snoc` 0) $ toRows p3
+{-# SPECIALIZE translateBefore3to4 :: Vector R -> Matrix R -> Matrix R #-}
+
+{-
+lookat pos target up = translateBefore3to4 (negate pos) r
+  where
+    backward  = normalize $ pos - target
+    rightward = normalize $ up `cross` backward
+    upward    = backward `cross` rightward
+    r = fromColumns [rightward,upward,backward]
+
+    -- Rebind 'normalize' in order to support Float which has no Field
+    -- instance.
+    normalize :: (Linear t c, Fractional t, Normed (c t)) => c t -> c t
+    normalize v = scale (1 / realToFrac (norm_2 v)) v
+-}
+
+-- | Camera transformation matrix (4x4).
+lookat :: (Numeric t, Num (Vector t), Fractional t, Normed (Vector t)) =>
+    Vector t    -- ^ Camera position 3-vector.
+    -> Vector t -- ^ Target position 3-vector.
+    -> Vector t -- ^ Upward direction 3-vector.
+    -> Matrix t
+lookat pos target up = fromRows
+    [ snoc rightward         (- dot rightward pos)
+    , snoc upward            (- dot upward    pos)
+    , snoc backward          (- dot backward  pos)
+    , snoc (fromList[0,0,0]) 1
+    ]
+  where
+    backward  = normalize $ pos - target
+    rightward = normalize $ up `cross` backward
+    upward    = backward `cross` rightward
+
+    -- Rebind 'normalize' in order to support Float which has no Field
+    -- instance.
+    normalize :: (Linear t c, Fractional t, Normed (c t)) => c t -> c t
+    normalize v = scale (1 / realToFrac (norm_2 v)) v
+
+{-# SPECIALIZE lookat :: Vector R -> Vector R -> Vector R -> Matrix R #-}
+
+
+
+
+
+-- lookat pos target up <> rot t
+--    == lookat ((((pos - target) <# rot (-t))) + target)
+--              target
+--
+-- | Perspective transformation 4x4 matrix.
+perspective :: (Storable a, Floating a) =>
+                a    -- ^ Near plane clipping distance (always positive).
+                -> a -- ^ Far plane clipping distance (always positive).
+                -> a -- ^ Field of view of the y axis, in radians.
+                -> a -- ^ Aspect ratio, i.e. screen's width\/height.
+                -> Matrix a
+perspective n f fovy aspect = (4><4)
+    [ (2*n/(r-l))    , 0             , 0              , 0
+    , 0              , (2*n/(t-b))   , 0              , 0
+    , (-(r+l)/(r-l)) , ((t+b)/(t-b)) , (-(f+n)/(f-n)) , (-1)
+    , 0              , 0             , (-2*f*n/(f-n)) , 0    ]
+  where
+    t = n*tan(fovy/2)
+    b = -t
+    r = aspect*t
+    l = -r
+
+
+
+-- | Build a look at view matrix
+{-
+lookat2
+  :: (Epsilon a, Floating a)
+  => V3 a -- ^ Eye
+  -> V3 a -- ^ Center
+  -> V3 a -- ^ Up
+  -> M44 a
+-}
+lookat2 :: (Normed (Vector a), Field a, Num (Vector a)) =>
+                 Vector a -> Vector a -> Vector a -> Matrix a
+lookat2 eye center up = fromColumns
+   [ snoc xa xd
+   , snoc ya yd
+   , snoc (-za) zd
+   , fromList [ 0 , 0 , 0 , 1 ] ]
+  where za = normalize $ center - eye
+        xa = normalize $ cross za up
+        ya = cross xa za
+        xd = -dot xa eye
+        yd = -dot ya eye
+        zd = dot za eye
+
+{-
+
+-- | Build a look at view matrix
+lookAt
+  :: (Epsilon a, Floating a)
+  => V3 a -- ^ Eye
+  -> V3 a -- ^ Center
+  -> V3 a -- ^ Up
+  -> M44 a
+lookAt eye center up =
+  V4 (V4 (xa^._x)  (xa^._y)  (xa^._z)  xd)
+     (V4 (ya^._x)  (ya^._y)  (ya^._z)  yd)
+     (V4 (-za^._x) (-za^._y) (-za^._z) zd)
+     (V4 0         0         0          1)
+  where za = normalize $ center - eye
+        xa = normalize $ cross za up
+        ya = cross xa za
+        xd = -dot xa eye
+        yd = -dot ya eye
+        zd = dot za eye
+
+-- | Build a matrix for a symmetric perspective-view frustum
+perspective
+  :: Floating a
+  => a -- ^ FOV (y direction, in radians)
+  -> a -- ^ Aspect ratio
+  -> a -- ^ Near plane
+  -> a -- ^ Far plane
+  -> M44 a
+perspective fovy aspect near far =
+  V4 (V4 x 0 0    0)
+     (V4 0 y 0    0)
+     (V4 0 0 z    w)
+     (V4 0 0 (-1) 0)
+  where tanHalfFovy = tan $ fovy / 2
+        x = 1 / (aspect * tanHalfFovy)
+        y = 1 / tanHalfFovy
+        fpn = far + near
+        fmn = far - near
+        oon = 0.5/near
+        oof = 0.5/far
+        -- z = 1 / (near/fpn - far/fpn) -- would be better by .5 bits
+        z = -fpn/fmn
+        w = 1/(oof-oon) -- 13 bits error reduced to 0.17
+        -- w = -(2 * far * near) / fmn
+
+
+-- | Perspective transformation matrix in row major order.
+perspective :: Float  -- ^ Near plane clipping distance (always positive).
+            -> Float  -- ^ Far plane clipping distance (always positive).
+            -> Float  -- ^ Field of view of the y axis, in radians.
+            -> Float  -- ^ Aspect ratio, i.e. screen's width\/height.
+            -> Mat4
+perspective n f fovy aspect = transpose $
+    Mat4 (Vec4 (2*n/(r-l))       0       (-(r+l)/(r-l))        0)
+         (Vec4     0        (2*n/(t-b))  ((t+b)/(t-b))         0)
+         (Vec4     0             0       (-(f+n)/(f-n))  (-2*f*n/(f-n)))
+         (Vec4     0             0            (-1)             0)
+  where
+    t = n*tan(fovy/2)
+    b = -t
+    r = aspect*t
+    l = -r
+
+-}
+
+lookAtRotate :: (Normed (Vector t), Num (Vector t), Numeric t,
+                       Floating t) =>
+                      Vector t -> Vector t -> Vector t -> t -> Matrix t
+lookAtRotate pos target up t = lookat pos target up <> m
+ where
+    m = rotMatrixX t {- <> rotMatrixZ t -}
+
+rotateLookAt :: (Normed (Vector t), Floating t, Num (Vector t),
+                       Numeric t) =>
+                      Vector t -> Vector t -> Vector t -> t -> Matrix t
+rotateLookAt pos target up t = lookat pos' target up'
+    where
+        m = rotMatrixX (-t)
+        pos' = V.init $ (m #> snoc pos 0)
+        up' = V.init (m #> snoc up 0)
+
+
+{-
+void UniformMatrix{234}{fd}v( int location, sizei count, boolean transpose, const float *value );
+void UniformMatrix{2x3,3x2,2x4,4x2,3x4,4x3}{fd}v( int location, sizei count, boolean transpose, const float *value );
+
+The UniformMatrix{234}fv and UniformMatrix{234}dv commands will load count 2 ×
+2, 3 × 3, or 4 × 4 matrices (corresponding to 2, 3, or 4 in the command name)
+of single- or double-precision floating-point values, respectively, into a
+uniform defined as a matrix or an array of matrices. If transpose is FALSE ,
+the matrix is specified in column major order, otherwise in row major order.
+
+-}
diff --git a/TimeKeeper.hs b/TimeKeeper.hs
index d85f61f..36e7e8a 100644
--- a/TimeKeeper.hs
+++ b/TimeKeeper.hs
@@ -24,6 +24,9 @@ newTimeKeeper = do
     ff <- newMVar 0
     return $ TimeKeeper s ff
 
+getSeconds :: TimeKeeper -> IO Double
+getSeconds tk = readMVar (tmSeconds tk)
+
 tick :: TimeKeeper -> Widget -> FrameClock -> IO Bool
 tick tm widget clock = widgetGetWindow widget >>= \case
     Nothing  -> return SOURCE_REMOVE
diff --git a/hello_obj2.lc b/hello_obj2.lc
index ebee807..7adf8b1 100644
--- a/hello_obj2.lc
+++ b/hello_obj2.lc
@@ -1,15 +1,11 @@
 deg30 = 0.5235987755982988 -- pi/6
 
-coordmap (time::Float) (p::Vec 4 Float)
+coordmap (cam::Mat 4 4 Float) (p::Vec 4 Float)
     = perspective 0.1 -- near plane
                   100 -- far plane
                 deg30 -- y fov radians
                     1 -- aspect ratio w/h
-                      *. lookat (V3 0 0 10) -- camera position
-                                (V3 0 0 0)  -- target position
-                                (V3 0 1 0)  -- upward direction
-                      *. rotMatrixX time -- time = radians
-                      *. rotMatrixZ time -- time = radians
+                      *. cam
                       *. p
 
 blendplane = -- NoBlending -- BlendLogicOp Xor
@@ -17,7 +13,7 @@ blendplane = -- NoBlending -- BlendLogicOp Xor
           ((OneBF,SrcAlpha),(DstAlpha,DstAlpha))
           (V4 0 0 0 0)
 
-makeFrame (time :: Float)
+makeFrame (cam ::  Mat 4 4 Float)
           (color :: Vec 4 Float)
           (texture :: Texture)
           (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
@@ -26,13 +22,13 @@ makeFrame (time :: Float)
     = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
   `overlay`
       prims
-    & mapPrimitives (\(p,n,uvw) -> ( coordmap time p, V2 uvw%x (1 - uvw%y) ))
+    & mapPrimitives (\(p,n,uvw) -> ( coordmap cam p, V2 uvw%x (1 - uvw%y) ))
     & rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) ((Smooth))
     & mapFragments (\((uv)) -> ((color * texture2D (Sampler PointFilter MirroredRepeat texture) uv )))
     & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
   `overlay`
       plane
-    & mapPrimitives (\((p)) -> (coordmap time p, p%xy ))
+    & mapPrimitives (\((p)) -> (coordmap cam p, p%xy ))
     & rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) ((Smooth))
     -- & mapFragments (\((uv)) -> ((texture2D (Sampler PointFilter MirroredRepeat texture) uv )))
     -- & mapFragments (\((uv)) -> ((V4 uv%x uv%y 0 1))) -- ((rgb 1 0 0)))
@@ -46,7 +42,7 @@ makeFrame (time :: Float)
 
 
 main = renderFrame $
-   makeFrame (Uniform "time")
+   makeFrame (Uniform "cam")
              (Uniform "diffuseColor")
              (Texture2DSlot "diffuseTexture")
              (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))
diff --git a/lambda-gtk.cabal b/lambda-gtk.cabal
index bc86d57..83eb922 100644
--- a/lambda-gtk.cabal
+++ b/lambda-gtk.cabal
@@ -25,7 +25,7 @@ executable lambda-gtk
                        -- GUI
                        gi-gdk , gi-glib , gi-gobject , gi-gtk , haskell-gi-base
                        -- , gi-gtk-declarative, gi-gtk-declarative-app-simple,
-
+  default-language:    Haskell2010
   -- hs-source-dirs:
 
 
@@ -48,15 +48,15 @@ executable gldemo
 executable objdemo
   main-is:             mainObj.hs
   other-modules:       InfinitePlane LambdaCubeWidget GLWidget LambdaCube.Gtk TimeKeeper
-                       LoadMesh MtlParser
+                       LoadMesh MtlParser Matrix LambdaCube.GL.HMatrix
   extensions:          NondecreasingIndentation
   other-extensions:    OverloadedLabels, OverloadedLists, OverloadedStrings
   build-depends:       base, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11,
-                       vector, aeson, JuicyPixels, text, contravariant,
+                       vector, aeson, JuicyPixels, text, contravariant, hmatrix,
                        -- writer monad
                        mtl,
                        -- rendering
-                       lambdacube-ir, lambdacube-gl, OpenGL, wavefront,
+                       lambdacube-ir, lambdacube-gl >=0.5.4, OpenGL, wavefront,
                        -- GUI
                        gi-gdk , gi-glib , gi-gobject , gi-gtk , haskell-gi-base
 
diff --git a/mainObj.hs b/mainObj.hs
index 1513075..caa4fa4 100644
--- a/mainObj.hs
+++ b/mainObj.hs
@@ -13,23 +13,31 @@ import Data.Text (Text)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import qualified Data.Vector     as V
+import Data.Vector.Generic as VG (init,snoc)
 import GI.Gdk.Objects
 import GI.GLib.Constants
 import GI.Gtk                    as Gtk hiding (main)
 import LambdaCube.GL             as LC
 import LambdaCube.GL.Mesh        as LC
+import Numeric.LinearAlgebra hiding ((<>))
 import System.Environment
 import System.IO
 import System.IO.Error
 
 import GLWidget
+import LambdaCube.GL.HMatrix
 import LambdaCubeWidget
 import TimeKeeper
 import LoadMesh
 import InfinitePlane
 import MtlParser (ObjMaterial(..))
+import Matrix
 
-type State = (TimeKeeper, TickCallbackHandle)
+-- State created by uploadState.
+data State = State
+    { stTimeKeeper   :: TimeKeeper
+    , stTickCallback :: TickCallbackHandle
+    }
 
 addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
 addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
@@ -57,17 +65,28 @@ uploadState obj glarea storage = do
     -- setup FrameClock
     tm <- newTimeKeeper
     tickcb <- widgetAddTickCallback glarea (tick tm)
-    return (tm,tickcb)
+
+    return State
+        { stTimeKeeper   = tm
+        , stTickCallback = tickcb
+        }
 
 destroyState :: GLArea -> State -> IO ()
-destroyState glarea (tm,tickcb) = do
-    widgetRemoveTickCallback glarea tickcb
+destroyState glarea st = do
+    widgetRemoveTickCallback glarea (stTickCallback st)
 
 setUniforms :: glctx -> GLStorage -> State -> IO ()
-setUniforms gl storage (tm,_) = do
-    t <- withMVar (tmSeconds tm) return
+setUniforms gl storage st = do
+    t <- getSeconds $ stTimeKeeper st
+    let tf = realToFrac t :: Float
+        roZ = rotMatrixZ (-tf)
+        roX = rotMatrixX (-tf)
+        ro = roZ <> roX
+        pos = VG.init (ro #> fromList [0,0,10,0])
+        up = VG.init (ro #> fromList [0,1,0,0])
+        cam = lookat pos 0 up
     LC.updateUniforms storage $ do
-      "time" @= return (realToFrac t :: Float)
+      "cam" @= return (cam :: Matrix Float)
 
 main :: IO ()
 main = do
@@ -82,7 +101,7 @@ main = do
           defObjectArray "plane" Triangles $ do
             "position"  @: Attribute_V4F
           defUniforms $ do
-            "time"            @: Float
+            "cam"             @: M44F
             "diffuseTexture"  @: FTexture2D
             "diffuseColor"    @: V4F
         return $ (,) <$> mobj <*> mpipeline