summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorCsabaHruska <>2011-06-23 01:02:09 (GMT)
committerLuite Stegeman <luite@luite.com>2011-06-23 01:02:09 (GMT)
commiteedf87249bf1ade34ea31bb411a5746f72b9dd60 (patch)
treeb5ee531db38433cdf4453a8e36f657d0af137829
parent35a42ba36bcd1ef38cdda19f5fa7f5217058c247 (diff)
version 0.1.20.1.2
-rw-r--r--LICENSE2
-rw-r--r--lambdacube-examples.cabal21
-rw-r--r--media/Example.material3
-rw-r--r--media/MRAMOR6X6.jpgbin0 -> 96990 bytes
-rw-r--r--media/Robot.material21
-rw-r--r--media/RustySteel.jpgbin0 -> 13975 bytes
-rw-r--r--src/Utils.hs350
-rw-r--r--src/lambdacube-basic.hs185
-rw-r--r--src/lambdacube-cameratrack.hs179
9 files changed, 292 insertions, 469 deletions
diff --git a/LICENSE b/LICENSE
index 62198e0..80ac9e7 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2009, Csaba Hruska
+Copyright (c) 2009-2011, Csaba Hruska
All rights reserved.
Redistribution and use in source and binary forms, with or without
diff --git a/lambdacube-examples.cabal b/lambdacube-examples.cabal
index 9e44a98..fdf6837 100644
--- a/lambdacube-examples.cabal
+++ b/lambdacube-examples.cabal
@@ -1,13 +1,14 @@
Name: lambdacube-examples
-Version: 0.1.1
+Version: 0.1.2
Cabal-Version: >= 1.2
Synopsis: Examples for LambdaCube
Category: Graphics
Description: Examples for LambdaCube
-Author: Csaba Hruska
+Author: Csaba Hruska, Gergely Patai
Maintainer: csaba (dot) hruska (at) gmail (dot) com
-Copyright: (c) 2009, Csaba Hruska
+Copyright: (c) 2009-2011, Csaba Hruska
Homepage: http://www.haskell.org/haskellwiki/LambdaCubeEngine
+Bug-Reports: http://code.google.com/p/lambdacube/issues
License: BSD3
License-File: LICENSE
Stability: experimental
@@ -17,6 +18,8 @@ Extra-Source-Files:
src/Utils.hs
Data-Files:
+ media/MRAMOR6X6.jpg
+ media/RustySteel.jpg
media/01.png
media/02.png
media/03.png
@@ -49,15 +52,15 @@ Data-Files:
media/WeirdEye.png
Executable lambdacube-basic
- Executable: lambdacube-basic
+ main-is: lambdacube-basic
HS-Source-Dirs: src
Main-IS: lambdacube-basic.hs
- Build-Depends: base >= 4 && < 5, lambdacube-engine, elerea, GLFW, OpenGL, containers, hslogger
- GHC-Options: -Wall -O2
+ Build-Depends: base >= 4 && < 5, mtl, lambdacube-engine, elerea, GLFW-b, hslogger
+ GHC-Options: -Wall -O2 -fno-warn-unused-do-bind -fno-warn-name-shadowing
Executable lambdacube-cameratrack
- Executable: lambdacube-cameratrack
+ main-is: lambdacube-cameratrack
HS-Source-Dirs: src
Main-IS: lambdacube-cameratrack.hs
- Build-Depends: base >= 4 && < 5, lambdacube-engine, elerea, GLFW, OpenGL, containers, hslogger
- GHC-Options: -Wall -O2
+ Build-Depends: base >= 4 && < 5, lambdacube-engine, elerea, GLFW-b, hslogger
+ GHC-Options: -Wall -O2 -fno-warn-unused-do-bind -fno-warn-name-shadowing
diff --git a/media/Example.material b/media/Example.material
index 661ae75..b3c4ffa 100644
--- a/media/Example.material
+++ b/media/Example.material
@@ -633,7 +633,8 @@ material "2 - Default"
texture_unit
{
- texture MtlPlat2.jpg
+ //texture MtlPlat2.jpg
+ texture MRAMOR6X6.jpg
}
}
}
diff --git a/media/MRAMOR6X6.jpg b/media/MRAMOR6X6.jpg
new file mode 100644
index 0000000..f3f25ce
--- /dev/null
+++ b/media/MRAMOR6X6.jpg
Binary files differ
diff --git a/media/Robot.material b/media/Robot.material
index 0b119bc..060cad0 100644
--- a/media/Robot.material
+++ b/media/Robot.material
@@ -12,7 +12,7 @@ fragment_program Examples/AmbientShadingFP glsl
source toonf2.frag
}
-material Examples/Robot
+material Examples/Toon
{
// Software blending technique
@@ -31,24 +31,11 @@ material Examples/Robot
// map shininess from custom renderable param 1
//param_named_auto shininess custom 1
}
-
- // scene_blend modulate
-// depth_check off
-// depth_write off
-// cull_hardware none
-// cull_software none
- texture_unit
- {
- texture r2skin.jpg
- colour_op modulate
- }
-// texture_unit
-// {
-// colour_op modulate
-// texture GreenSkin.jpg
-// }
}
}
+}
+material Examples/Robot
+{
technique
{
diff --git a/media/RustySteel.jpg b/media/RustySteel.jpg
new file mode 100644
index 0000000..a2d7b9d
--- /dev/null
+++ b/media/RustySteel.jpg
Binary files differ
diff --git a/src/Utils.hs b/src/Utils.hs
index f3e3079..dfc5415 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -1,307 +1,97 @@
module Utils where
-import Data.Maybe
-import qualified Data.List as List
-import qualified Data.IntMap as IntMap
-import qualified Data.Map as Map
-import Foreign
-import Foreign.C.Types
-import Data.IORef ( IORef, newIORef )
-import Control.Monad as Monad
-import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans
+import Data.IORef
---import Graphics.UI.GLFW as GLFW
-import Graphics.Rendering.OpenGL as GL
-import FRP.Elerea
+import FRP.Elerea.Param
+import Graphics.UI.GLFW as GLFW
+import System.Log.Logger
-import Graphics.LambdaCube
+import Graphics.LambdaCube as LC
+-- Reactive helper functions
+
+integral :: (Real p, Fractional t) => t -> Signal t -> SignalGen p (Signal t)
+integral v0 s = transfer v0 (\dt v v0 -> v0+v*realToFrac dt) s
+
+driveNetwork :: (MonadIO m) => (p -> IO (m a)) -> IO (Maybe p) -> m ()
driveNetwork network driver = do
- dt <- driver
+ dt <- liftIO driver
case dt of
- Just dt -> do Monad.join $ superstep network dt
- driveNetwork network driver
+ Just dt -> do
+ join . liftIO $ network dt
+ driveNetwork network driver
Nothing -> return ()
--- FPS measure code
-data State
- = State
- { frames :: IORef Int
- , t0 :: IORef Double
- }
+-- OpenGL/GLFW boilerplate
+
+initCommon :: String -> IO (Signal (Int, Int))
+initCommon title = do
+ updateGlobalLogger rootLoggerName (setLevel DEBUG)
+ initialize
+ openWindow defaultDisplayOptions
+ { displayOptions_numRedBits = 8
+ , displayOptions_numGreenBits = 8
+ , displayOptions_numBlueBits = 8
+ , displayOptions_numDepthBits = 24
+ }
+ --openWindow (Size 960 600) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window
+ setWindowTitle title
+
+ (windowSize,windowSizeSink) <- external (0,0)
+ setWindowSizeCallback $ \w h -> do
+ windowSizeSink (fromIntegral w, fromIntegral h)
+ return windowSize
+
+-- FPS tracking
+
+data State = State { frames :: IORef Int, t0 :: IORef Double }
+
+fpsState :: IO State
fpsState = do
a <- newIORef 0
b <- newIORef 0
return $ State a b
-updateFPS :: State -> Double -> IO ()
+updateFPS :: State -> Double -> IO ()
updateFPS state t1 = do
let t = 1000*t1
- frames state $~! (+1)
- t0' <- get (t0 state)
- t0 state $= t0' + t
+ fR = frames state
+ tR = t0 state
+ modifyIORef fR (+1)
+ --frames state $~! (+1)
+ t0' <- readIORef tR
+ writeIORef tR $ t0' + t
+ --t0' <- get (t0 state)
+ --t0 state $= t0' + t
when (t + t0' >= 5000) $ do
- f <- get (frames state)
- let seconds = (t + t0') / 1000
+ f <- readIORef fR --get (frames state)
+ let seconds = (t + t0') / 1000
fps = fromIntegral f / seconds
putStrLn (show f ++ " frames in " ++ show seconds ++ " seconds = "++ show fps ++ " FPS")
- t0 state $= 0
- frames state $= 0
-
-drawCube = renderPrimitive Quads $ do
- -- top of cube
- color $ Color3 0 1 (0.0 :: GLfloat)
- vertex $ Vertex3 1.0 1.0 (-1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) 1.0 (-1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) 1.0 ( 1.0 :: GLfloat)
- vertex $ Vertex3 1.0 1.0 ( 1.0 :: GLfloat)
-
- -- bottom of cube
- color $ Color3 1 0.5 (0.0 :: GLfloat)
- vertex $ Vertex3 1.0 (-1.0) ( 1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) (-1.0) ( 1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) (-1.0) (-1.0 :: GLfloat)
- vertex $ Vertex3 1.0 (-1.0) (-1.0 :: GLfloat)
-
- -- front of cube
- color $ Color3 1 0 (0.0 :: GLfloat)
- vertex $ Vertex3 1.0 1.0 ( 1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) 1.0 ( 1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) (-1.0) ( 1.0 :: GLfloat)
- vertex $ Vertex3 1.0 (-1.0) ( 1.0 :: GLfloat)
-
- -- back of cube.
- color $ Color3 1 1 (0.0 :: GLfloat)
- vertex $ Vertex3 1.0 (-1.0) (-1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) (-1.0) (-1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) 1.0 (-1.0 :: GLfloat)
- vertex $ Vertex3 1.0 1.0 (-1.0 :: GLfloat)
-
- -- left of cube
- color $ Color3 0 0 (1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) 1.0 ( 1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) 1.0 (-1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) (-1.0) (-1.0 :: GLfloat)
- vertex $ Vertex3 (-1.0) (-1.0) ( 1.0 :: GLfloat)
-
- -- right of cube
- color $ Color3 1 0 (1.0 :: GLfloat)
- vertex $ Vertex3 1.0 1.0 (-1.0 :: GLfloat)
- vertex $ Vertex3 1.0 1.0 ( 1.0 :: GLfloat)
- vertex $ Vertex3 1.0 (-1.0) ( 1.0 :: GLfloat)
- vertex $ Vertex3 1.0 (-1.0) (-1.0 :: GLfloat)
+ writeIORef tR 0 --t0 state $= 0
+ writeIORef fR 0 --frames state $= 0
-initGL width height = do
- clearColor $= Color4 0 0 0 1
- clearDepth $= 1
- depthFunc $= Just Less
- --depthMask $= Enabled
- --shadeModel $= Smooth
- cullFace $= Just Back
- -- lighting setup
- materialAmbient Front $= Color4 0.2 0.2 0.2 1
- materialDiffuse Front $= Color4 1 1 1 1
- materialSpecular Front $= Color4 0 0 0 0
- materialShininess Front $= 0
- materialAmbient Back $= Color4 0.2 0.2 0.2 1
- materialDiffuse Back $= Color4 1 1 1 1
- materialSpecular Back $= Color4 0 0 0 0
- materialShininess Back $= 0
- GL.position (Light 0) $= Vertex4 20 80 150 1
- GL.lighting $= Enabled
- GL.light (Light 0) $= Enabled
-
- polygonMode $= (Line,Line)
-
- matrixMode $= Projection
- loadIdentity
-
- perspective 45 (width/height) 0.1 200
-
- matrixMode $= Modelview 0
- color $ Color4 1 1 1 (1::GLfloat)
+-- Continuous camera state (rotated with mouse, moved with arrows)
-resizeGLScene winSize size@(Size w h) = do
- winSize (fromIntegral w,fromIntegral h)
- viewport $= (Position 0 0, size)
-
- matrixMode $= Projection
- loadIdentity
-
- perspective 45 (fromIntegral w / fromIntegral h) 0.1 1000
-
- matrixMode $= Modelview 0
-
-cameraSignal (sx,sy,sz) mposs keyss = createSignal $ transfer (Vec4 sx sy sz 0, Vec4 1 0 0 0, Vec4 0 1 0 0,(-pi * 50,0)) calcCam ((,) <$> mposs <*> keyss)
+cameraSignal :: Real t => Vec3 -> Signal (FloatType, FloatType)
+ -> Signal (Bool, Bool, Bool, Bool, Bool)
+ -> SignalGen t (Signal (Vec3, Vec3, Vec3, (FloatType, FloatType)))
+cameraSignal p mposs keyss = transfer2 (p,zero,zero,(0,0)) calcCam mposs keyss
where
- dir cx cy = (vec4xmat44 (Vec4 0 0 (-1) 0) $ rotX (cy) <> rotY (cx),vec4xmat44 (Vec4 0 1 0 0) $ rotX (cy) <> rotY (cx))
- calcCam dt ((dmx,dmy),(ka,kw,ks,kd,turbo)) (p0,_,_,(mx,my)) = (p4,d,u,(mx',my'))
+ d0 = Vec4 0 0 (-1) 1
+ u0 = Vec4 0 1 0 1
+ calcCam dt (dmx,dmy) (ka,kw,ks,kd,turbo) (p0,_,_,(mx,my)) = (p',d,u,(mx',my'))
where
- p1 = if ka then p0 `vec4addvec4` (v `vec4xscalar` t) else p0
- p2 = if kw then p1 `vec4addvec4` (d `vec4xscalar` (-t)) else p1
- p3 = if ks then p2 `vec4addvec4` (d `vec4xscalar` t) else p2
- p4 = if kd then p3 `vec4addvec4` (v `vec4xscalar` (-t)) else p3
- k = if turbo then 10 else 1
+ f0 c n = if c then (&+ n) else id
+ p' = foldr1 (.) [f0 ka (v &* (-t)),f0 kw (d &* t),f0 ks (d &* (-t)),f0 kd (v &* t)] p0
+ k = if turbo then 100 else 30
t = k * realToFrac dt
mx' = dmx + mx
my' = dmy + my
- (d,u) = dir (mx' / 100) (my' / 100)
- v = norm $ d `vec4crossvec4` u
-
-
---mkMesh :: String -> [(Matrix4,Mesh)] -> World -> IO World
-mkMesh name ml w = do
- let sml = concat [[(mat,setVD sm $ msSharedVertexData m) | sm <- msSubMeshList m] | (mat,m) <- ml]
- setVD sm svd = case smVertexData sm of
- { Just _ -> sm
- ; Nothing -> sm { smVertexData = svd }
- }
- matGrp = groupSetBy (\(_,a) (_,b) -> smMaterialName a == smMaterialName b) sml
- geomGrp = concat $ map (groupSetBy declCmp) matGrp
- declCmp (_,a) (_,b) = sortDecl a == sortDecl b && smOperationType a == smOperationType b
- where
- sortDecl sm = List.sort [(veType e, veSemantic e, veIndex e) | e <- vdElementList $ vdVertexDeclaration $ fromJust $ smVertexData sm]
- vcnt l = foldl (+) 0 [getNumVertices $ head $ IntMap.elems $ vbbBindingMap $ vdVertexBufferBinding $ fromJust $ smVertexData sm | (_,sm) <- l]
- rl = wrResource w
- rs = wrRenderSystem w
- joinVD l = do
- let counts = scanl (+) 0 [getNumVertices $ head $ IntMap.elems $ vbbBindingMap $ vdVertexBufferBinding $ fromJust $ smVertexData sm | (_,sm) <- l]
- offs = scanl (\a b -> a + (getTypeSize $ veType b)) 0 d
- d = vdElementList $ vdVertexDeclaration $ fromJust $ smVertexData $ snd $ head l
- decl = VertexDeclaration [e { veSource = 0, veOffset = o } | (e,o) <- zip d offs]
- --vsize = getVertexSize $ head $ IntMap.elems $ vbbBindingMap $ vdVertexBufferBinding $ fromJust $ smVertexData $ head l -- FIXME
- vsize = foldl (\a b -> a + (getTypeSize $ veType b)) 0 $ vdElementList $ decl
- usage = HBU_STATIC -- TODO
- vcount = last counts
- material = smMaterialName $ snd $ head l
- operation = smOperationType $ snd $ head l
- indexCounts = scanl (\a (_,b) -> a + (idIndexCount $ fromJust $ smIndexData b)) 0 l
- indexCount = last indexCounts
--- indexCount' = foldl (\a b -> a + (getNumIndexes $ idIndexBuffer $ fromJust $ smIndexData b)) 0 l
- idType = if vcount > 0xFFFF then IT_32BIT else IT_16BIT
- sortDecl dl = List.sortBy (\a b-> (veType a, veSemantic a, veIndex a) `compare` (veType b, veSemantic b, veIndex b)) dl
- sorteddecl = sortDecl $ vdElementList decl
- vb <- createVertexBuffer rs vsize vcount usage True
- ptr <- lock vb 0 (getSizeInBytes vb) HBL_NORMAL
- -- iterate over subents
- -- copy and transform vertex attributes
- forM_ (zip counts l) $ \(o,(mat,sm)) -> do
- -- TODO
- -- filter out VES_BLEND attributes from src and dst declarations (static mesh cant be vertex blended)
- -- iterate over each vertex attribute and do copy&transform
- let svbs = IntMap.elems $ vbbBindingMap $ vdVertexBufferBinding $ fromJust $ smVertexData sm
- srcdecl = sortDecl $ vdElementList $ vdVertexDeclaration $ fromJust $ smVertexData sm
- --print sorteddecl
- --print srcdecl
- sptrs <- forM svbs $ \svb -> lock svb 0 (getSizeInBytes svb) HBL_NORMAL
-
- let copyAttr se de = do
- let sptr = sptrs !! (veSource se)
- sstride = getVertexSize $ svbs !! (veSource se)
- svcount = getNumVertices $ svbs !! (veSource se)
- forM_ [0..(svcount-1)] $ \i -> copyArray (advancePtr ptr $ (o+i) * vsize + veOffset de) (advancePtr sptr $ i * vsize + veOffset se) (getTypeSize $ veType se)
- rFloat3 = peekArray 3 :: Ptr CFloat -> IO [CFloat]
- wFloat3 = pokeArray :: Ptr CFloat -> [CFloat] -> IO ()
- transrotAttr se de = do
- let sptr = sptrs !! (veSource se)
- sstride = getVertexSize $ svbs !! (veSource se)
- svcount = getNumVertices $ svbs !! (veSource se)
- forM_ [0..(svcount-1)] $ \i -> do
- [x,y,z] <- rFloat3 (castPtr $ advancePtr sptr $ i * vsize + veOffset se)
- let Vec4 x' y' z' _ = vec4xmat44 (Vec4 (realToFrac x) (realToFrac y) (realToFrac z) 1) mat
- wFloat3 (castPtr $ advancePtr ptr $ (o+i) * vsize + veOffset de) [realToFrac x', realToFrac y', realToFrac z']
- rotAttr se de = do
- let sptr = sptrs !! (veSource se)
- sstride = getVertexSize $ svbs !! (veSource se)
- svcount = getNumVertices $ svbs !! (veSource se)
- forM_ [0..(svcount-1)] $ \i -> do
- [x,y,z] <- rFloat3 (castPtr $ advancePtr sptr $ i * vsize + veOffset se)
- let Vec4 x' y' z' _ = vec4xmat44 (Vec4 (realToFrac x) (realToFrac y) (realToFrac z) 0) mat
- wFloat3 (castPtr $ advancePtr ptr $ (o+i) * vsize + veOffset de) [realToFrac x', realToFrac y', realToFrac z']
-
- forM_ (zip srcdecl sorteddecl) $ \(se,de) -> case veSemantic se of
- { VES_POSITION -> transrotAttr se de
- ; VES_BLEND_WEIGHTS -> error "invalid semantic"
- ; VES_BLEND_INDICES -> error "invalid semantic"
- ; VES_NORMAL -> rotAttr se de
- ; VES_DIFFUSE -> copyAttr se de
- ; VES_SPECULAR -> copyAttr se de
- ; VES_TEXTURE_COORDINATES -> copyAttr se de
- ; VES_BINORMAL -> rotAttr se de
- ; VES_TANGENT -> rotAttr se de
- }
- forM_ svbs $ \svb -> unlock svb
- unlock vb
-
- ib <- createIndexBuffer rs idType indexCount usage True
--- print $ "created new index buffer: " ++ show indexCount ++ " " ++ show idType ++ " " ++ show indexCount'
- print $ "created new index buffer: " ++ show indexCount ++ " " ++ show idType
- -- 1. lock buffer
- ptr <- lock ib 0 (getSizeInBytes ib) HBL_NORMAL
- -- 2. fill buffer
- forM_ (zip3 counts l indexCounts) $ \(o,(_,sm),io) -> do
- let sib = idIndexBuffer $ fromJust $ smIndexData sm
- cnt = getNumIndexes sib
- st = getIndexType sib
- r16 = peekElemOff :: Ptr Word16 -> Int -> IO Word16
- r32 = peekElemOff :: Ptr Word32 -> Int -> IO Word32
- w16 = pokeElemOff :: Ptr Word16 -> Int -> Word16 -> IO ()
- w32 = pokeElemOff :: Ptr Word32 -> Int -> Word32 -> IO ()
- sptr <- lock sib 0 (getSizeInBytes sib) HBL_NORMAL
- print (o,cnt,io)
- forM_ [0..(cnt-1)] $ \i -> case (idType,st) of
- { (IT_16BIT,IT_16BIT) -> do
- d <- r16 (castPtr sptr) i
- w16 (castPtr ptr) (io+i) $ d + fromIntegral o
- ; (IT_16BIT,IT_32BIT) -> do
- d <- r32 (castPtr sptr) i
- w16 (castPtr ptr) (io+i) $ fromIntegral d + fromIntegral o
- ; (IT_32BIT,IT_16BIT) -> do
- d <- r16 (castPtr sptr) i
- w32 (castPtr ptr) (io+i) $ fromIntegral d + fromIntegral o
- ; (IT_32BIT,IT_32BIT) -> do
- d <- r32 (castPtr sptr) i
- w32 (castPtr ptr) (io+i) $ d + fromIntegral o
- }
- unlock sib
- -- 3. unlock buffer
- unlock ib
-
- let binding = VertexBufferBinding $ IntMap.fromList [(0,vb)]
- vd = VertexData decl binding 0 vcount
- idat = IndexData ib 0 indexCount
- print decl
- print $ "vcount " ++ show vcount ++ " indexCount " ++ show indexCount
- return $ SubMesh
- { smOperationType = operation
- , smVertexData = Just vd
- , smIndexData = Just idat
- , smExtremityPoints = undefined -- TODO
- , smMaterialName = material
- }
- print $ "groupNum: " ++ (show $ length geomGrp)
- print $ map length geomGrp
- print $ foldl (+) 0 $ map length geomGrp
- print $ map vcnt geomGrp
- print $ foldl (+) 0 $ map vcnt geomGrp
- sml' <- mapM joinVD geomGrp
- let mesh = Mesh
- { msSubMeshList = sml'
- , msSharedVertexData = Nothing
- , msSubMeshNameMap = undefined -- TODO
- , msBoundRadius = undefined -- TODO
- , msSkeletonName = undefined -- TODO
- , msVertexBufferUsage = undefined -- TODO
- , msIndexBufferUsage = undefined -- TODO
- , msVertexBufferShadowBuffer = undefined -- TODO
- , msIndexBufferShadowBuffer = undefined -- TODO
- }
- return w { wrResource = rl { rlMeshMap = Map.insert name mesh (rlMeshMap rl) } }
-
-mkMeshN name nl w0 = do
- let f (w,l) (mt,n) = do
- (m,w') <- getMesh n w
- return (w',(mt,m):l)
- (w1,l) <- foldM f (w0,[]) nl
- mkMesh name l w1
+ rm = fromProjective $ rotationEuler $ Vec3 (mx' / 100) (my' / 100) 0
+ d = trim $ rm *. d0 :: Vec3 --Vec.take n3 $ rm `multmv` d0
+ u = trim $ rm *. u0 :: Vec3 --Vec.take n3 $ rm `multmv` u0
+ v = LC.normalize $ d &^ u
diff --git a/src/lambdacube-basic.hs b/src/lambdacube-basic.hs
index 0acb01e..1a2002c 100644
--- a/src/lambdacube-basic.hs
+++ b/src/lambdacube-basic.hs
@@ -1,12 +1,7 @@
-import Data.Maybe
-import Data.Map
import Control.Applicative
-import Control.Monad
-
+import Control.Monad.Trans
+import FRP.Elerea.Param
import Graphics.UI.GLFW as GLFW
-import Graphics.Rendering.OpenGL as GL hiding (light)
-import System.Log.Logger
-import FRP.Elerea
import Graphics.LambdaCube
import Graphics.LambdaCube.RenderSystem.GL
@@ -16,103 +11,105 @@ import Paths_lambdacube_examples (getDataFileName)
import Utils
-integral v0 s = transfer v0 (\dt v v0 -> v0+v*realToFrac dt) s
-
-baseMousePos = Position 200 200
+width :: Float
width = 150
+
+height :: Float
height = 150
+
+main :: IO ()
main = do
- updateGlobalLogger rootLoggerName (setLevel DEBUG)
- initialize
- openWindow (Size 640 480) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window
- windowTitle $= "LambdaCube Engine Basic Example"
- GLFW.mousePos $= baseMousePos
- GLFW.disableSpecial MouseCursor
-
- initGL 640 480
- (windowSize,windowSizeSink) <- external (0,0)
+ windowSize <- initCommon "LambdaCube Engine Basic Example"
+
(mousePosition,mousePositionSink) <- external (0,0)
- (mousePress,mousePressSink) <- external False
+ (_mousePress,mousePressSink) <- external False
(fblrPress,fblrPressSink) <- external (False,False,False,False,False)
- windowSizeCallback $= resizeGLScene windowSizeSink
- let --mkNodeR = mkNode "Root"
- idMatrix4 = transl 0 0 0
-
mediaPath <- getDataFileName "media"
-
renderSystem <- mkGLRenderSystem
- world' <- addRenderWindow "MainWindow" 640 480 [mkViewport 0 0 1 0.5 "Camera1" ["Glass"{- "Tiling","Glass" -}], mkViewport 0 0.5 1 0.5 "Camera2" []]
- =<< addRenderTexture "RenderTex01" 640 480
- =<< addScene ([-- mkNode "Root" "Car" idMatrix4 [mesh "scooby_body.mesh.xml"]
- mkNode "Root" "Robot" idMatrix4 [mesh "robot.mesh.xml"]
--- , mkNodeR "OgreHead" idMatrix4 [mesh "BigRamp_N.mesh.xml"]
--- , mkNodeR "Plane" (transl 41.5 (-50) (-146)) [entity "robot.mesh.xml"]
- , mkNode "Root" "OgreHead" (scal 0.05) [mesh "ogrehead.mesh.xml",mesh "Quad.mesh.xml"]
--- , mkNodeR "Light1" transl 5 5 10 $ [sun ]
- , mkNode "Root" "Light1" (transl 5 5 10) [light,mesh "ogrehead.mesh.xml"]
--- , mkNode "Root" "Light2" (transl (-5) 15 10) [light,mesh "Cube.mesh.xml"]
--- , mkNodeR "CustomMeshNode" idMatrix4 [customMesh (plane) "RenderTex01Material"]
- , mkNode "Root" "CameraNode1" idMatrix4 [simpleCamera "Camera1"]
- , mkNode "Root" "CameraEye" idMatrix4 [mesh "Box.mesh.xml"]
--- , mkNode "Root" "CameraNode1" idMatrix4 [wireCamera "Camera1"]
- , mkNode "Root" "CameraNode2" (transl 0 0 (-10)) [simpleCamera "Camera2"] ]
--- , mkNode "Root" "CameraNode2" (transl 0 0 10) [simpleCamera "Camera2"] ]
--- ++ [ mkNode "Root" ("Robot" ++ show i) (transl ((i-100)*20) (-50) (-166)) [mesh "robot.mesh.xml"] | i <- [1..200] ])
- ++ [ mkNode "Root" ("Knot" ++ show i) idMatrix4 [meshMat "knot.mesh.xml" (repeat "Examples/TransparentTest")] | i <- [1..200]::[Int] ])
- =<< addResourceLibrary [("General",[(PathDir,mediaPath)])]
--- =<< addConfig "resources.cfg"
- =<< mkWorld renderSystem [Stb.loadImage]
- (world,worldSink) <- external world'
-
- re1 <- createSignal $ integral 0 $ pure (1.5)-- :: Float)
- re2 <- createSignal $ integral 10 $ pure (-1.0)-- :: Float)
- re3 <- createSignal $ integral 110 $ pure (0.8)-- :: Float)
- time <- createSignal $ stateful 0 (+)
- cam <- cameraSignal (-4,0,0) mousePosition fblrPress
-
- s <- fpsState
-
- driveNetwork (drawGLScene worldSink <$> world <*> windowSize <*> mousePosition <*> re1 <*> re2 <*> re3 <*> cam)-- <*> zsin <*> cam)
- (readInput s mousePositionSink mousePressSink fblrPressSink)
+ runLCM renderSystem [Stb.loadImage] $ do
+ -- inLCM $ addConfig "resources.cfg"
+ addResourceLibrary [("General",[(PathDir,mediaPath)])]
+ let mrq = mesh defaultRQP
+ m = mrq Nothing
+ materials = ["Examples/TransparentTest","Examples/Toon","2 - Default","Examples/EnvMappedRustySteel"]
+ materialLen = length materials
+ mat i = materials !! (i `mod` materialLen)
+ addScene $
+ [ node "Root" "Robot" idmtx [m "robot.mesh.xml"]
+ , node "Root" "OgreHead" (scalingUniformProj4 0.05) [m "ogrehead.mesh.xml",m "Quad.mesh.xml"]
+ , node "Root" "Light1" (translation (Vec3 5 5 10)) [defaultLight,m "ogrehead.mesh.xml"]
+ , node "Root" "CameraNode1" (translation (Vec3 0 0 10)) [simpleCamera "Camera1"]
+ , node "Root" "CameraEye" idmtx [mesh (Just RQP_EarlySky) Nothing "Box.mesh.xml" ]
+ , node "Root" "CameraNode2" idmtx [simpleCamera "Camera2"]
+ ] ++
+ [node "Root" ("Knot" ++ show i) idmtx [mrq (Just (repeat $ mat i)) "knot.mesh.xml"] | i <- [1..200]]
+ addRenderTexture "RenderTex01" 640 480
+ addRenderWindow "MainWindow" 640 480
+ [viewport 0 0 1 0.5 "Camera1" ["Glass" {- "Tiling" -}], viewport 0 0.5 1 0.5 "Camera2" []]
+
+ s <- liftIO fpsState
+ sc <- liftIO $ start $ scene windowSize mousePosition fblrPress
+ driveNetwork sc (readInput s mousePositionSink mousePressSink fblrPressSink)
closeWindow
+scene :: RenderSystem r vb ib q t p lp
+ => Signal (Int, Int)
+ -> Signal (FloatType, FloatType)
+ -> Signal (Bool, Bool, Bool, Bool, Bool)
+ -> SignalGen FloatType (Signal (LCM (World r vb ib q t p lp) e ()))
+scene windowSize mousePosition fblrPress = do
+ re1 <- integral 0 1.5
+ re2 <- integral 10 (-1.0)
+ re3 <- integral 110 0.8
+ time <- stateful 0 (+)
+ last2 <- transfer ((0,0),(0,0)) (\_ n (_,b) -> (b,n)) mousePosition
+ let mouseMove = (\((ox,oy),(nx,ny)) -> (nx-ox,ny-oy)) <$> last2
+ --let mouseMove = mousePosition
+ cam <- cameraSignal (Vec3 (-4) 0 0) mouseMove fblrPress
+ return $ drawGLScene <$> windowSize <*> re1 <*> re2 <*> re3 <*> cam <*> time
+
+drawGLScene :: RenderSystem r vb ib q t2 p lp
+ => (Int, Int)
+ -> FloatType
+ -> FloatType
+ -> FloatType
+ -> (Vec3, Vec3, Vec3, t1)
+ -> FloatType
+ -> LCM (World r vb ib q t2 p lp) e ()
+drawGLScene (w,h) _re1 re2 re3 (cam,dir,up,_) time = do
+ updateTransforms $
+ [ ("Robot", scalingUniformProj4 0.1 .*. (linear $ rotMatrixY re2) .*. translation (Vec3 3.5 (-5) (-7)))
+ , ("Light1", translation (Vec3 0 100 200) .*. (linear $ rotMatrixX re2))
+ , ("CameraEye", scalingUniformProj4 1 .*. translation cam)
+ , ("CameraNode2", inverse $ lookat (cam) (cam &+ dir) (up))
+ ] ++
+ [("Knot" ++ show i,
+ ((linear $ rotMatrixY re3) .*.
+ let (y,x) = quotRem i 14 in
+ translation (Vec3 ((fromIntegral x - 7)*width) (height*(fromIntegral y - 7)) (-166))
+ )
+ ) | i <- [1..200 :: Int]]
+ updateTargetSize "MainWindow" w h
+ renderWorld (realToFrac time) "MainWindow"
+ liftIO $ swapBuffers
+
+readInput :: State
+ -> ((FloatType, FloatType) -> IO a)
+ -> (Bool -> IO b)
+ -> ((Bool, Bool, Bool, Bool, Bool) -> IO c)
+ -> IO (Maybe FloatType)
readInput s mousePos mouseBut fblrPress = do
- t <- get GLFW.time
+ t <- getTime
+ resetTime
+
+ (x,y) <- getMousePosition
+ mousePos (fromIntegral x,fromIntegral y)
+
+ mouseBut =<< mouseButtonIsPressed MouseButton0
+ fblrPress =<< ((,,,,) <$> keyIsPressed KeyLeft <*> keyIsPressed KeyUp <*> keyIsPressed KeyDown <*> keyIsPressed KeyRight <*> keyIsPressed KeyRightShift)
+
updateFPS s t
- GLFW.time $= 0
- let Position x0 y0 = baseMousePos
- f = (==) Press
- Position x y <- get GLFW.mousePos
- GLFW.mousePos $= baseMousePos
- mousePos (fromIntegral (x-x0),fromIntegral (y-x0))
- b <- GLFW.getMouseButton GLFW.ButtonLeft
- mouseBut (b == GLFW.Press)
- k <- getKey ESC
- kw <- getKey UP -- $ CharKey 'w'
- ks <- getKey DOWN -- $ CharKey 's'
- ka <- getKey LEFT -- $ CharKey 'a'
- kd <- getKey RIGHT -- $ CharKey 'd'
- turbo <- getKey RSHIFT
- --print (ka,kw,ks,kd)
- fblrPress (f ka,f kw,f ks,f kd,f turbo)
- return (if k == Press then Nothing else Just t)
-
-drawGLScene worldSink world (w,h) (cx,cy) re1 re2 re3 (cam,dir,up,_) {-zsin camMat-} = do
- w' <- updateTargetSize "MainWindow" w h
- =<< updateTransforms
- ([ {-("Car", rotY re3 <> scal 0.4 <> transl (cx/w*2-1) (h/w-cy/w*2) zsin)
- , -}("Robot", scal 0.1 <> rotY re2 <> transl 3.5 (-5) (-7))
- , ("Light1", transl 0 100 200 <> rotX re2)
--- , ("OgreHead", rotX (cy/50) <> rotY (-cx/50) <> transl (-0.5) 0 (-160))
--- , ("OgreHead", rotY re2 <> transl (-0.5) 0 (-160))
--- , ("CameraNode1", rotX (cy/50) <> rotY (-cx/50) <> transl 0 0 (cx/30))--camMat)
- , ("CameraEye", scal (1) <> (\(Vec4 x y z _) -> transl x y z) cam)
- , ("CameraNode1", lookat cam dir up)
- ]
- ++ [ (("Knot" ++ show i),(rotY re3 <> transl ((fromIntegral $ (i`mod`14)-7)*width) (height*(fromIntegral $ i`div`14 -7)) (-166))) | i <- [1..200] ])
- world
- w <- renderWorld 0 "MainWindow" (flattenScene $ wrScene w') w'
- worldSink w
- swapBuffers
+ k <- keyIsPressed KeyEsc
+ return $ if k then Nothing else Just (realToFrac t)
diff --git a/src/lambdacube-cameratrack.hs b/src/lambdacube-cameratrack.hs
index d03eebc..d35b7bb 100644
--- a/src/lambdacube-cameratrack.hs
+++ b/src/lambdacube-cameratrack.hs
@@ -1,13 +1,9 @@
-import Data.Maybe
-import Data.Map
-import qualified Data.List as List
import Control.Applicative
-import Control.Monad
+import Control.Monad.Trans
+import qualified Data.List as List
+import FRP.Elerea.Param
import Graphics.UI.GLFW as GLFW
-import Graphics.Rendering.OpenGL as GL hiding (light)
-import System.Log.Logger
-import FRP.Elerea
import Graphics.LambdaCube
import Graphics.LambdaCube.RenderSystem.GL
@@ -17,75 +13,124 @@ import Paths_lambdacube_examples (getDataFileName)
import Utils
-integral v0 s = transfer v0 (\dt v v0 -> v0+v*realToFrac dt) s
-
+main :: IO ()
main = do
- updateGlobalLogger rootLoggerName (setLevel DEBUG)
- initialize
- openWindow (Size 640 480) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window
- windowTitle $= "LambdaCube Engine Camera Track Example"
+ windowSize <- initCommon "LambdaCube Engine Camera Track Example"
- initGL 640 480
- (windowSize,windowSizeSink) <- external (0,0)
- windowSizeCallback $= resizeGLScene windowSizeSink
+ mediaPath <- getDataFileName "media"
+ renderSystem <- mkGLRenderSystem
+ runLCM renderSystem [Stb.loadImage] $ do
+ let simpleLight = Light
+ { lgType = LT_POINT
+ , lgDiffuse = (1,1,1,1)
+ , lgDirection = Vec3 0 0 1
+ , lgSpecular = (0,0,0,0)
+ , lgSpotOuter = pi / 180 * 40
+ , lgSpotFalloff = 1
+ , lgRange = 100000
+ , lgAttenuationConst = 1
+ , lgAttenuationLinear = 0
+ , lgAttenuationQuad = 0
+ }
- let curve kfl t = (fx + t' * dx, fy + t' * dy, fz + t' * dz)
- where
- t'' = len * (snd $ properFraction $ (realToFrac t) / len)
- t' = t'' - ft
- (al,bl) = List.span (\(a,_)-> a <= t'') kfl
- (ft,(fx,fy,fz)) = last al
- (gt,(gx,gy,gz)) = head bl
- dt = gt - ft
- dx = (gx-fx) / dt
- dy = (gy-fy) / dt
- dz = (gz-fz) / dt
- len = fst $ last kfl
- idMatrix4 = transl 0 0 0
- track =
- [ (0, (-100 , 100 , 100))
- , (2.5, (-300 ,-10 ,-200))
- , (5, ( 500 , 700 ,-500))
- , (7.5, ( 200 ,-10 , 400))
- , (10, (-100 , 100 , 100))
+ -- inLCM $ addConfig "resources.cfg"
+ addResourceLibrary [("General",[(PathDir,mediaPath)])]
+ let mrq = mesh defaultRQP
+ m = mrq Nothing
+ addScene $
+ [ node "Root" "OgreHead" idmtx [m "ogrehead.mesh.xml"]
+ , node "Root" "Light1" idmtx [light simpleLight { lgDiffuse = (1,0,0,1) }]
+ , node "Root" "Light2" idmtx [defaultLight]
+ , node "Root" "Light3" idmtx [light simpleLight { lgDiffuse = (0,0,1,1) }]
+ , node "Light1" "Cube1" (scalingUniformProj4 0.2) [mrq (Just (repeat "Examples/TransparentTest")) "knot.mesh.xml"]
+ , node "Light2" "Cube2" (scalingUniformProj4 0.2) [mrq (Just (repeat "Examples/TransparentTest")) "knot.mesh.xml"]
+ , node "Light3" "Cube3" (scalingUniformProj4 0.2) [mrq (Just (repeat "Examples/TransparentTest")) "knot.mesh.xml"]
+ , node "Root" "CameraNode1" idmtx [simpleCamera "Camera1"]
+ , node "Root" "GroundNode1" (scalingUniformProj4 7000 .*. translation (Vec3 0 (-70) 0) ) [mrq (Just ["MyAnimMaterial"]) "Ground.mesh.xml"]
+ , node "Root" "SkyBoxNode1" (scalingUniformProj4 1000) [mesh (Just RQP_EarlySky) Nothing "Box.mesh.xml"]
]
+ addRenderWindow "MainWindow" 640 480 [viewport 0 0 1 1 "Camera1" []]
- mediaPath <- getDataFileName "media"
- renderSystem <- mkGLRenderSystem
- world' <- addRenderWindow "MainWindow" 640 480 [mkViewport 0 0 1 1 "Camera1" []]
- =<< addScene [ mkNode "Root" "OgreHead" idMatrix4 [mesh "ogrehead.mesh.xml"]
- , mkNode "Root" "Light1" (transl 5 5 10) [light{-,mesh "Cube.mesh.xml"-}]
- , mkNode "Root" "Light2" (transl (-5) 15 10) [light{-,mesh "Cube.mesh.xml"-}]
- , mkNode "Root" "CameraNode1" idMatrix4 [simpleCamera "Camera1"]
--- , mkNode "Root" "GroundNode1" (scal 7000 <> transl 0 (-70) 0) [meshMat "Ground.mesh.xml" ["Examples/RustySteel"]]
- , mkNode "Root" "GroundNode1" (scal 7000 <> transl 0 (-70) 0) [meshMat "Ground.mesh.xml" ["MyAnimMaterial"]]
- , mkNode "Root" "SkyBoxNode1" (scal 1000) [mesh "Box.mesh.xml"]
- ]
- =<< addResourceLibrary [("General",[(PathDir,mediaPath)])]
--- =<< addConfig "resources.cfg"
- =<< mkWorld renderSystem [Stb.loadImage]
- (world,worldSink) <- external world'
+ s <- liftIO fpsState
+ sc <- liftIO $ start $ scene windowSize
+ driveNetwork sc (readInput s)
- time <- createSignal $ stateful 0 (+)
- let anim = curve track <$> time
+ closeWindow
- s <- fpsState
+scene :: RenderSystem r vb ib q t p lp => Signal (Int, Int) -> SignalGen FloatType (Signal (LCM (World r vb ib q t p lp) e ()))
+scene windowSize = do
+ time <- stateful 0 (+)
+ let animCm = curve track <$> time
+ animL1 = curve trackLight1 <$> time
+ animL2 = curve trackLight2 <$> time
+ animL3 = curve trackLight3 <$> time
+ return $ drawGLScene <$> windowSize <*> animCm <*> animL1 <*> animL2 <*> animL3 <*> time
+ where
+ curve kfl t = (fx + t' * dx, fy + t' * dy, fz + t' * dz)
+ where
+ t'' = len * (snd $ (properFraction :: FloatType -> (Int,FloatType)) $ realToFrac t / len)
+ t' = t'' - ft
+ (al,bl) = List.span (\(a,_)-> a <= t'') kfl
+ (ft,(fx,fy,fz)) = last al
+ (gt,(gx,gy,gz)) = head bl
+ dt = gt - ft
+ dx = (gx-fx) / dt
+ dy = (gy-fy) / dt
+ dz = (gz-fz) / dt
+ len = fst $ last kfl
- driveNetwork (drawGLScene worldSink <$> world <*> windowSize <*> anim <*> time)
- (readInput s)
+ track =
+ [ (0, (-100 , 100 , 100))
+ , (2.5, (-300 ,-10 ,-200))
+ , (5, ( 500 , 700 ,-500))
+ , (7.5, ( 200 ,-10 , 400))
+ , (10, (-100 , 100 , 100))
+ ]
+ trackLight1 =
+ [ (0, ( 200 , 200 , 100))
+ , (2*2.5, ( 100 ,-10 ,-200))
+ , (2*5, (-500 , 700 ,-500))
+ , (2*7.5, (-200 ,-10 , 400))
+ , (2*10, ( 200 , 200 , 100))
+ ]
+ trackLight2 =
+ [ (3*0, (-100 , 100 , 100))
+ , (3*2.5, (-300 ,-10 ,-200))
+ , (3*5, ( 500 , 700 ,-500))
+ , (3*7.5, ( 200 ,-10 , 400))
+ , (3*10, (-100 , 100 , 100))
+ ]
+ trackLight3 =
+ [ (0.3*0, (-100 , 10 , 100))
+ , (0.3*2.5, (-300 ,-10 ,-200))
+ , (0.3*5, ( 500 , 70 ,-500))
+ , (0.3*7.5, ( 200 ,-10 , 400))
+ , (0.3*10, (-100 , 10 , 100))
+ ]
- closeWindow
+drawGLScene :: RenderSystem r vb ib q t p lp
+ => (Int, Int)
+ -> (Float, Float, Float)
+ -> (Float, Float, Float)
+ -> (Float, Float, Float)
+ -> (Float, Float, Float)
+ -> FloatType
+ -> LCM (World r vb ib q t p lp) e ()
+drawGLScene (w,h) (x,y,z) l1 l2 l3 time = do
+ let t (x,y,z) = translation (Vec3 x y z)
+ updateTransforms
+ [ ("CameraNode1", inverse $ lookat (Vec3 x y z) (Vec3 0 0 0) (Vec3 0 1 0))
+ , ("Light1", t l1), ("Light2", t l2), ("Light3", t l3)
+ , ("SkyBoxNode1", scalingUniformProj4 1000 .*. translation (Vec3 x y z))
+ ]
+ updateTargetSize "MainWindow" w h
+ renderWorld (realToFrac time) "MainWindow"
+ liftIO $ swapBuffers
+readInput :: State -> IO (Maybe FloatType)
readInput s = do
- t <- get GLFW.time
+ t <- getTime
updateFPS s t
- GLFW.time $= 0
- k <- getKey ESC
- return (if k == Press then Nothing else Just t)
-
-drawGLScene worldSink world (w,h) (x,y,z) time = do
- w' <- updateTargetSize "MainWindow" w h
- =<< updateTransforms [("CameraNode1", lookat (Vec4 x y z 0) (Vec4 x y z 0) (Vec4 0 1 0 0))] world
- w <- renderWorld (realToFrac time) "MainWindow" (flattenScene $ wrScene w') w'
- worldSink w
- swapBuffers
+ setTime 0
+ k <- keyIsPressed KeyEsc
+ return (if k then Nothing else Just (realToFrac t))