{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, PatternSignatures #-} ---------------------------------------------------------------------- -- | -- Module : Graphics.SceneGraph.SimpleViewport -- Copyright : (c) Mark Wassell 2008 -- License : LGPL -- -- Maintainer : mwassell@bigpond.net.au -- Stability : experimental -- Portability : portable -- -- Provide a view window onto a scenegraph. Handles basic navigation -- and interaction with widgets. ---------------------------------------------------------------------- module Graphics.SceneGraph.SimpleViewport ( setupGUI,GraphicsState(..),newState,drawCanvas,GSRef,runScene ) where import Control.Concurrent import Control.Concurrent.MVar import Data.Graph.Inductive.Graph import qualified Data.Map as M import Data.Graph.Inductive.Graph (pre) import Data.IORef import Data.List import qualified Data.Packed.Matrix as PM import Graphics.Rendering.OpenGL hiding (Red, Green,Blue,scale,Texture) import qualified Graphics.Rendering.OpenGL as GL import Graphics.UI.GLUT hiding (Red, Green,Blue,scale,Texture) import Graphics.UI.GLUT.Objects import Graphics.UI.GLUT.Fonts import System.Exit ( exitWith, ExitCode(ExitSuccess) ) import System.Time import Numeric.LinearAlgebra -- (inv, (><),toLists, ) import Graphics.SceneGraph.MySTM import Graphics.SceneGraph.Vector import Graphics.SceneGraph.Basic hiding (scale,translate,rotate) import Graphics.SceneGraph.Render import Graphics.SceneGraph.Textures import qualified Graphics.SceneGraph.Matrix as M initWindowSize = Size 700 700 perseAngle = 90.0 clrColor = Color4 0 0 0 1 type GSRef = TVar GraphicsState type HitSink = GSRef -> GLuint -> KeyState -> STM () -- Holds state of viewport. Theta is angle around the vertical/y axes; Sigma is the angle around the x-axes data GraphicsState = GraphicsState { gsR :: GLdouble, gsSig :: GLdouble, gsTheta :: GLdouble, gsMPos::Maybe Position, gsDisplayList :: Maybe DisplayList, gsDrawFunc :: Maybe (IO ()), gsHitSink :: Maybe HitSink, -- Handles hits onto the viewport gsDrag::Bool, gsScene :: Maybe Scene, -- The whole thing gsFocus :: Maybe Scene, -- The portion of the scene that has focus, -- mouse drag and keyboard events will be sent to this. gsTexture :: M.Map String TextureObject, gsDragPos :: Maybe (Vector GLdouble), gsProjMatrix :: Maybe (GLmatrix GLdouble), gsBlah :: Maybe (Int -> IO () ), gsModelMatrix :: Maybe (GLmatrix GLdouble) -- The model matrix up to camera } newState = GraphicsState { gsR = 50, gsSig = 0, gsTheta = 0, gsMPos=Nothing,gsDrawFunc = Nothing, gsDrag=False, gsDisplayList=Nothing,gsBlah=Nothing, gsScene = Nothing, gsTexture = M.empty, gsHitSink = Nothing, gsFocus=Nothing,gsProjMatrix = Nothing, gsModelMatrix=Nothing,gsDragPos=Nothing } modifyTVar tvar f = do x <- readTVar tvar writeTVar tvar (f x) -- | Run a scene. Displays the Scene in a basic viewport permitting user interaction. runScene :: Scene -> IO () runScene scene = do sem <- newMVar True ref <- newTVar newState { gsScene = Just scene } setupGUI sem ref getTextures :: Scene -> IO (M.Map String TextureObject) getTextures (gs,_) = do let textureNames = nub $ foldr (\x xs -> case (llab gs x) of SceneNode _ (Texture s) -> (s:xs) _ -> xs) [] (nodes gs) tlist <- getAndCreateTextures $ map (\s -> "data/" ++ s) textureNames return $ M.fromList $ zip textureNames $ map (maybe (error "failed to load texture") id) tlist -- | Setup GUI and run it. setupGUI :: MVar Bool -> GSRef -> IO () setupGUI sem rGS = do (progName, _args) <- getArgsAndInitialize initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ] initialWindowSize $= initWindowSize initialWindowPosition $= (Position 100 100) createWindow progName lighting $= Enabled normalize $= Enabled depthFunc $= Just Less matrixMode $= Projection loadIdentity perspective perseAngle 1.0 0.1 10000.0 (m::GLmatrix Double) <- get $ matrix Nothing mc <- getMatrixComponents RowMajor m matrixMode $= Modelview 0 loadIdentity shadeModel $= Smooth clearColor $= clrColor blend $= Enabled blendFunc $= (SrcAlpha,OneMinusSrcAlpha) gs <- readIORef rGS texMap <- getTextures (maybe (error "no scene") id (gsScene gs)) (atomically sem) $ modifyTVar rGS (\gs -> gs { gsHitSink = Just findHitAction , gsProjMatrix = Just m, gsTexture = texMap}) displayCallback $= ( (atomically sem) $ drawCanvas rGS) keyboardMouseCallback $= Just (\a b c d -> (atomically sem) $ handleKeyEvent rGS a b c d) motionCallback $= Just (\p -> (atomically sem) $ handleDragEvent rGS p ) passiveMotionCallback $= Just (\p -> (atomically sem) $ handleMotionEvent rGS p ) mainLoop i2d :: GLint -> GLdouble i2d = fromInteger . toInteger i2f :: GLint -> Float i2f = fromInteger . toInteger handleMotionEvent _ _ = return () drawCanvasNull _ = return () handleDragEvent :: TVar GraphicsState -> Position -> STM () handleDragEvent rGS pos = do gs <- readTVar rGS case (gsFocus gs) of Just scene | (gsDrag gs) -> handleFocusedDrag rGS pos Nothing | (gsDrag gs) -> handleTransformDrag rGS pos _ -> return () -- To calculate - -- Widget needs to supply a plane (lets start with z = 0 - then we include transform of object in unproject) -- Calculate 2 points on pick line (ie mouse z = 0, mouse z = 1) -- calculate intersection of pick line with the plane to get the point lineToYPlane p1 p2 = lineToYPlane' (fromVertex p1) (fromVertex p2) fromVertex :: Vertex3 GLdouble -> Vector Double fromVertex (Vertex3 x y z) = fromList [x,z,(-y)] toVertex :: Vector Double -> Vertex3 GLdouble toVertex vec = let [x,y,z] = toList vec in Vertex3 x y z lineToYPlane' :: Vector GLdouble -> Vector GLdouble -> Vector GLdouble lineToYPlane' p1 p2 = let n = fromList [ 0, 1, 0] origin = fromList [ 0, 0, 0] u = (n `dot` ( origin `sub` p1)) / n `dot` (p2 `sub` p1) in p1 `add` ( u `scale` (p2 `sub` p1)) t1 = lineToYPlane (Vertex3 0 1 0) (Vertex3 0 (-1) 0 ) t2 = lineToYPlane (Vertex3 3 1 0 ) (Vertex3 1 (-1) 0 ) constrainDrag :: Vector GLdouble -> Vector GLdouble constrainDrag vec = vec `dot` (fromList [1,0,0]) `scale` (fromList [1,0,0]) -- Assumes matrix transform is the parent ... doDrag :: TVar GraphicsState -> Node -> Vector GLdouble -> IO () doDrag rGS nde vec' = do let vec = constrainDrag vec' gs <- readTVar rGS case (gsScene gs) of Just (sg,start) -> do case (llab sg nde) of (SceneNode _ (Handler _ (Just (dragHandlerF,snk)))) -> do (sg'',val) <- dragHandlerF (sg,nde) vec snk val writeTVar rGS $ gs { gsScene = Just $ (sg'',start) } _ -> return () _ -> return () -- FIXME swap z and y and negate y handleFocusedDrag :: TVar GraphicsState -> Position -> STM () handleFocusedDrag rGS pos@(Position x y) = do gs <- readTVar rGS case gsFocus gs of Just (gr,nde) -> do vp <- unsafeIOToSTM $ get viewport --should we move modelmatrix also to the positon of the nde? let mm = maybe (error "No set") id (gsModelMatrix gs) let pm = maybe (error "No set") id (gsProjMatrix gs) pos1 <- unsafeIOToSTM $ unProject (Vertex3 (fromIntegral x) (fromIntegral y) 0) mm pm vp pos2 <- unsafeIOToSTM $ unProject (Vertex3 (fromIntegral x) (fromIntegral y) 1) mm pm vp let pos3 = lineToYPlane pos1 pos2 case (gsDragPos gs) of Just lastPos -> do let vec = pos3 `sub` lastPos -- putStrLn $ "New pos = " ++ show vec writeTVar rGS (gs { gsDragPos = Just pos3 }) doDrag rGS nde vec drawCanvas rGS Nothing -> writeTVar rGS (gs { gsDragPos = Just pos3 }) return () Nothing -> return () handleTransformDrag :: GSRef -> Position -> STM () handleTransformDrag rGS pos = do gs <- readTVar rGS if (gsDrag gs) then rotateBy gs (gsMPos gs) pos else return () where rotateBy gs Nothing _ = writeTVar rGS (gs { gsMPos = (Just pos) }) rotateBy gs (Just (Position x' y')) pos@(Position x y) = do writeTVar rGS (gs { gsSig = (gsSig gs) - ((i2d (x'-x))/100), gsTheta = (gsTheta gs) - ((i2d (y'-y))/100), gsMPos = (Just pos)}) rotateCamera rGS ((i2d (x'-x))/100) ((i2d (y'-y))/100) drawCanvas rGS bufSize :: GLsizei bufSize = 512 moveFactor = 1 resetDrag f x = x { gsMPos = Nothing, gsDrag=f ,gsDragPos=Nothing } handleKeyEvent :: GSRef -> Key -> KeyState -> Modifiers -> Position -> STM () handleKeyEvent _ (Char '\27') _ _ _ = unsafeIOToSTM $ System.Exit.exitWith ExitSuccess handleKeyEvent gs (MouseButton btn) dir _ (Position x y) = do modifyTVar gs (resetDrag (dir == Down)) case btn of LeftButton -> pickSceneNode gs dir x y _ -> return () handleKeyEvent gs (Char 'w') _ _ _= moveCamera gs (vector3 0 moveFactor 0) handleKeyEvent gs (Char 'a') _ _ _= moveCamera gs (vector3 (-moveFactor) 0 0) handleKeyEvent gs (Char 's') _ _ _= moveCamera gs (vector3 0 (-moveFactor) 0) handleKeyEvent gs (Char 'd') _ _ _= moveCamera gs (vector3 moveFactor 0 0) handleKeyEvent gs (Char 'z') _ _ _= moveCamera gs (vector3 0 0 (-moveFactor)) handleKeyEvent gs (Char 'x') _ _ _= moveCamera gs (vector3 0 0 moveFactor) -- FIXME. Doesn' work? -- handleKeyEvent gs (MouseButton WheelDown) _ _ _= moveCamera gs (Vector3 0 0 (-1)) -- handleKeyEvent gs (MouseButton WheelUp) _ _ _= moveCamera gs (Vector3 0 0 1) handleKeyEvent gs _ _ _ _ = return () -- Note: Selection in OpenGL is basically a draw with names and then the system returns the names of -- visible in the viewing volume. The last step in setting up the view is to call pickMatrix to restrict -- the viewing volume to an NxN pixel square centred on the mouse hit. pickSceneNode :: GSRef -> KeyState -> GLint -> GLint -> STM () pickSceneNode gsRef dir x y= do gs <- readTVar gsRef (_, maybeHitRecords) <- unsafeIOToSTM $ do vp@(_, (Size _ height)) <- get viewport getHitRecords bufSize $ withName (Name 0) $ do matrixMode $= Projection preservingMatrix $ do loadIdentity pickMatrix (fromIntegral x, fromIntegral height - fromIntegral y) (5, 5) vp -- This is the same as at start of code. FIXME perspective perseAngle 1.0 0.1 10000.0 drawCanvas'' gs Nothing processHits gsRef dir maybeHitRecords processHits :: GSRef -> KeyState -> Maybe[HitRecord] -> STM () processHits _ _ Nothing = error "selection buffer overflow" processHits gs dir (Just ((HitRecord _ _ (Name n:_)):_)) = findHitAction gs n dir >> drawCanvas gs processHits _ _ _ = return () drawCanvas :: GSRef -> STM () drawCanvas rGS = drawCanvas' rGS Nothing drawCanvas' :: GSRef -> Maybe (IO ()) -> STM () drawCanvas' rGS pm = do gs <- readTVar rGS gs' <- unsafeIOToSTM $ drawCanvas'' gs pm writeTVar rGS gs' drawCanvas'' :: GraphicsState -> Maybe (IO ()) -> IO GraphicsState drawCanvas'' gs pm = do clearColor $= clrColor clear [ColorBuffer,DepthBuffer] gs' <- setCamera gs crMat (0.0, 0.7, 0)(0.4, 0.4, 0.4) 5 1.0 --mapM_ (drawCircle 5 50) [Vertex3 0 0 1,Vertex3 0 1 0,Vertex3 1 0 0 ] --mapM_ drawLetter [zPts,yPts,xPts] maybe (return ()) id pm gs''<-case (gsDisplayList gs) of Just dl -> callList dl >> return gs' Nothing -> do list <- defineNewList CompileAndExecute $ maybe (return ()) (drawSceneGraph (gsTexture gs)) (gsScene gs) return $ gs' { gsDisplayList = Just list } flush swapBuffers return gs'' cameraChange :: GSRef -> (SceneGraph -> Node -> SceneGraph) -> STM () cameraChange rGS f = do st <- readTVar rGS case (gsScene st) of Just sc@(sg,start) -> do let cam = findCameraPath sc 0 tnde = (reverse cam) !! 1 sg' = f sg tnde st' = st { gsScene = Just $ (sg',start) } writeTVar rGS st' drawCanvas rGS Nothing -> return () rotateCamera :: GSRef -> GLdouble -> GLdouble -> STM () rotateCamera rGS s t = do cameraChange rGS (\sg tnde -> rotatePostSG' (rotatePostSG' sg tnde (vector3 0.0 0.0 1.0) s) tnde (vector3 1.0 0.0 0.0) t) moveCamera :: GSRef -> VectorD -> STM () moveCamera rGS vec = do st <- readTVar rGS case (gsScene st) of Just sc@(sg,start) -> do let cam = findCameraPath sc 0 tnde = (reverse cam) !! 1 sg' = translatePostSG' sg tnde vec st' = st { gsScene = Just $ (sg',start) } (SceneNode _ (MatrixTransform tr1)) = llab sg tnde (SceneNode _ (MatrixTransform tr2)) = llab sg' tnde writeTVar rGS st' drawCanvas rGS Nothing -> return () setCamera :: GraphicsState -> IO GraphicsState setCamera st = do matrixMode $= Modelview 0 loadIdentity let r = gsR st maybe (return ()) (applyCameraTransform 1) (gsScene st) lookAt (Vertex3 0 0 0) (Vertex3 0.0 0 (-r)) (Vector3 0 1.0 0) (m::GLmatrix Double) <- get $ matrix (Just $ Modelview 0 ) return $ st { gsModelMatrix = Just m } -- | Traverse down to the camera for this viewport and apply the transforms along -- the way. applyCameraTransform :: Int -> Scene -> IO () applyCameraTransform cnum sc@(gr,start) = do mapM_ applyTransform $ (map (llab gr) $ findCameraPath sc 0 ) applyLA inv -- | Apply a unary function from HMatrix package to Modelview matrix applyLA :: (PM.Matrix Double -> PM.Matrix Double) -> IO () applyLA f = do (m::GLmatrix Double) <- get $ matrix Nothing mc <- getMatrixComponents RowMajor m let mc' = concat $ toLists $ f ((4><4) mc) (m'::GLmatrix Double) <- newMatrix RowMajor mc' matrix (Just (Modelview 0)) $= m' setCamera' rGS = do gs <- readTVar rGS -- Those in the know say that lookAt is done in Modelview. unsafeIOToSTM $ do matrixMode $= Modelview 0 loadIdentity let (t,s,r) = (gsTheta gs, gsSig gs, gsR gs) z = l * sin s' x = l * cos s' l = (cos s') s' = s -- or -s ?? lookAt (Vertex3 0 0 r) (Vertex3 0.0 0 0) (Vector3 0 1.0 0) rotate (s*180/pi) (Vector3 0 1 0) rotate (t*180/pi) (Vector3 x 0 z) crMat (rd,gd,bd) (rs,gs,bs) exp a = do materialDiffuse Front $= Color4 rd gd bd a materialAmbient Front $= Color4 rd gd bd a materialSpecular Front $= Color4 rs gs bs a materialShininess Front $= exp materialDiffuse Back $= Color4 rd gd bd a materialSpecular Back $= Color4 rs gs bs a materialShininess Back $= exp drawCircle :: GLdouble-> Int -> Vertex3 GLdouble -> IO () drawCircle r n a@(Vertex3 x y z) = preservingMatrix $ do rotate (theta*180/pi) (Vector3 x' y' z') renderPrimitive LineLoop $ mapM_ mapVertex ls where mapVertex v = do normal (Normal3 x y z) vertex v ls = [ (Vertex3 (r * cos (vt t)) (r*sin (vt t)) 0) | t <- [0 .. (n-1)] ] vt t = 2*pi* (fromInteger (toInteger t))/(fromInteger (toInteger n)) (Vertex3 x' y' z') = a `vCross` (Vertex3 0 0 1) theta = a `ang` (Vertex3 0 0 1) vCross :: Num a => Vertex3 a -> Vertex3 a -> Vertex3 a vCross (Vertex3 a1 a2 a3) (Vertex3 b1 b2 b3) = Vertex3 (a2*b3 -a3*b2) (a3*b1-a1*b3) (a1*b2-a2*b1) vDot :: Num a => Vertex3 a -> Vertex3 a -> a vDot (Vertex3 a1 a2 a3) (Vertex3 b1 b2 b3) = a1*b1 + a2*b2 + a3*b3 vPlus :: Num a => Vertex3 a -> Vertex3 a -> Vertex3 a vPlus (Vertex3 a1 a2 a3) (Vertex3 b1 b2 b3) = Vertex3 (a1+b1) (a2+b2) (a3+b3) mag :: Vertex3 GLdouble -> GLdouble mag (Vertex3 a1 a2 a3) = sqrt (a1*a1 + a2*a2 + a3*a3) ang :: Vertex3 GLdouble-> Vertex3 GLdouble -> GLdouble ang v w = acos ((v `vDot` w) / ((mag v) * (mag w))) drawLetter :: ([(GLdouble,GLdouble)],Vector3 GLdouble) -> IO () drawLetter (pts,t) = preservingMatrix $ do translate t GL.scale 0.1 0.1 (0.1::GLdouble) renderPrimitive Quads $ mapM_ mapVertex pts where mapVertex (x,y) = do normal (Normal3 (0::GLdouble) 0 1) vertex (Vertex3 x y 0 ) xPts = ([ (0,-1), (-4,-5),(-6,-5),(-1,0), (-1,0),(-6,5),(-4,5),(0,1), (0,1), (4,5), (6,5), (1,0), (1,0),(6,-5), (4,-5),(0,-1), (-1,0),(0,1),(1,0),(0,-1)],Vector3 (5::GLdouble) 0 0) zPts = ([ (-5,5), (-5,6), (5,6), (4,5), (5,6), (6,6), (-5,-6),(-6,-6), (-5,-6), (6,-6),(6,-5), (-4,-5)],Vector3 0 (5::GLdouble) 0) yPts = ([ (5,6), (6,6), (-5,-6),(-6,-6), (-5,6), (-4,6), (0,0), (-1,-1)],Vector3 0 0 (5::GLdouble)) -- | Find and perform hit action findHitAction :: HitSink findHitAction ref = f where f 0 _ = return () f name dir = do gs <- readTVar ref let scene@(_,start) = maybe (error "No scene") id (gsScene gs) ((gr,_), focused,f) <- unsafeIOToSTM $ handleClickEvent scene name dir let focus = case dir of Up -> Nothing Down -> focused case f of Just f' -> writeTVar ref (gs { gsScene = Just $ (f' gr, start), gsFocus = focus }) Nothing -> writeTVar ref (gs { gsScene = Just $ (gr, start), gsFocus = focus })