scenegraph 0.1 → 0.1.0.1
raw patch · 8 files changed
+585/−581 lines, 8 filessetup-changed
Files
- CHANGES +4/−0
- Setup.lhs +3/−3
- scenegraph.cabal +5/−5
- src/Graphics/SceneGraph/Library.hs +1/−1
- src/Graphics/SceneGraph/ReadImage.hs +68/−68
- src/Graphics/SceneGraph/Render.hs +1/−1
- src/Graphics/SceneGraph/SimpleViewPort.hs +0/−503
- src/Graphics/SceneGraph/SimpleViewport.hs +503/−0
+ CHANGES view
@@ -0,0 +1,4 @@+Version 0.1.0.1 + +Rename SimpleViewPort.hs to SimpleViewport +Fix the deprecated language pragmas
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain+#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain
scenegraph.cabal view
@@ -1,19 +1,19 @@ Name: scenegraph -Version: 0.1 -Copyright: Mark Wassell 2008 +Version: 0.1.0.1 +Copyright: Mark Wassell 2009 License: BSD3 license-file: LICENSE Author: Mark Wassell <mwassell@bigpond.net.au> -Maintainer: Mark Wassell <mwassell@bigpond.net.au> +Maintainer: none Stability: experimental Homepage: http://www.haskell.org/haskellwiki/SceneGraph Category: Graphics Build-Depends: base,mtl,hmatrix,OpenGL>=2.2,GLUT>=2.1,haskell98,containers,fgl,array,old-time,process build-type: Simple -tested-with: GHC==6.8.2 +tested-with: GHC==6.10.1 Synopsis: Scene Graph Description: - Scene Graph Library + Scene Graph Library. Extensions: OverlappingInstances,UndecidableInstances Hs-Source-Dirs: src Exposed-Modules: Graphics.SceneGraph,
src/Graphics/SceneGraph/Library.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, - TypeSynonymInstances, PatternSignatures #-} + TypeSynonymInstances, ScopedTypeVariables #-} ---------------------------------------------------------------------- -- |
src/Graphics/SceneGraph/ReadImage.hs view
@@ -1,68 +1,68 @@-{-- ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.)- Copyright (c) Sven Panne 2002-2004 <sven.panne@aedion.de>- This file is part of HOpenGL and distributed under a BSD-style license- See the file libraries/GLUT/LICENSE-- This module has been modified to read both color and alpha data necessary for transparent textures in OpenGL.-- Support for reading a file of raw RGB data:- 4 bytes big-endian width- 4 bytes big-endian height- width * height RGBA byte quadruples (the original module reads width * height RGB byte triples)--}--module Graphics.SceneGraph.ReadImage ( readImage ) where--import Data.Word ( Word8, Word32 )-import Control.Exception ( bracket )-import Control.Monad ( liftM, when )-import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose )-import System.IO.Error ( mkIOError, eofErrorType )-import Foreign ( Ptr, alloca, mallocBytes, Storable(..) )-import Graphics.UI.GLUT---- This is probably overkill, but anyway...-newtype Word32BigEndian = Word32BigEndian Word32--word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei-word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x--instance Storable Word32BigEndian where- sizeOf ~(Word32BigEndian x) = sizeOf x- alignment ~(Word32BigEndian x) = alignment x- peek ptr = do- let numBytes = sizeOf (undefined :: Word32BigEndian)- bytes <- mapM (peekByteOff ptr) [ 0 .. numBytes - 1 ] :: IO [Word8]- let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes- return $ Word32BigEndian value- poke = error ""---- This is the reason for all this stuff above...-readGLsizei :: Handle -> IO GLsizei-readGLsizei handle =- alloca $ \buf -> do- hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian))- liftM word32BigEndianToGLsizei $ peek buf---- A handy variant of hGetBuf with additional error checking-hGetBufFully :: Handle -> Ptr a -> Int -> IO ()-hGetBufFully handle ptr numBytes = do- bytesRead <- hGetBuf handle ptr numBytes- when (bytesRead /= numBytes) $- ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing----- Closing a file is nice, even when an error occurs during reading.-withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a-withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose--readImage :: FilePath -> IO (Maybe (Size, PixelData a))-readImage filePath =- withBinaryFile filePath $ \handle -> do- width <- readGLsizei handle- height <- readGLsizei handle- let numBytes = fromIntegral (4 * width * height) -- changed the 3 to a 4 to make space for our alpha data.- buf <- mallocBytes numBytes- hGetBufFully handle buf numBytes- return $ Just (Size width height, PixelData RGBA UnsignedByte buf) -- changed the PixelFormat constructor here from RGB to RGBA, to account for our alpha data.+{- + ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.) + Copyright (c) Sven Panne 2002-2004 <sven.panne@aedion.de> + This file is part of HOpenGL and distributed under a BSD-style license + See the file libraries/GLUT/LICENSE + + This module has been modified to read both color and alpha data necessary for transparent textures in OpenGL. + + Support for reading a file of raw RGB data: + 4 bytes big-endian width + 4 bytes big-endian height + width * height RGBA byte quadruples (the original module reads width * height RGB byte triples) +-} + +module Graphics.SceneGraph.ReadImage ( readImage ) where + +import Data.Word ( Word8, Word32 ) +import Control.Exception ( bracket ) +import Control.Monad ( liftM, when ) +import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose ) +import System.IO.Error ( mkIOError, eofErrorType ) +import Foreign ( Ptr, alloca, mallocBytes, Storable(..) ) +import Graphics.UI.GLUT + +-- This is probably overkill, but anyway... +newtype Word32BigEndian = Word32BigEndian Word32 + +word32BigEndianToGLsizei :: Word32BigEndian -> GLsizei +word32BigEndianToGLsizei (Word32BigEndian x) = fromIntegral x + +instance Storable Word32BigEndian where + sizeOf ~(Word32BigEndian x) = sizeOf x + alignment ~(Word32BigEndian x) = alignment x + peek ptr = do + let numBytes = sizeOf (undefined :: Word32BigEndian) + bytes <- mapM (peekByteOff ptr) [ 0 .. numBytes - 1 ] :: IO [Word8] + let value = foldl (\val byte -> val * 256 + fromIntegral byte) 0 bytes + return $ Word32BigEndian value + poke = error "" + +-- This is the reason for all this stuff above... +readGLsizei :: Handle -> IO GLsizei +readGLsizei handle = + alloca $ \buf -> do + hGetBufFully handle buf (sizeOf (undefined :: Word32BigEndian)) + liftM word32BigEndianToGLsizei $ peek buf + +-- A handy variant of hGetBuf with additional error checking +hGetBufFully :: Handle -> Ptr a -> Int -> IO () +hGetBufFully handle ptr numBytes = do + bytesRead <- hGetBuf handle ptr numBytes + when (bytesRead /= numBytes) $ + ioError $ mkIOError eofErrorType "hGetBufFully" (Just handle) Nothing + + +-- Closing a file is nice, even when an error occurs during reading. +withBinaryFile :: FilePath -> (Handle -> IO a) -> IO a +withBinaryFile filePath = bracket (openBinaryFile filePath ReadMode) hClose + +readImage :: FilePath -> IO (Maybe (Size, PixelData a)) +readImage filePath = + withBinaryFile filePath $ \handle -> do + width <- readGLsizei handle + height <- readGLsizei handle + let numBytes = fromIntegral (4 * width * height) -- changed the 3 to a 4 to make space for our alpha data. + buf <- mallocBytes numBytes + hGetBufFully handle buf numBytes + return $ Just (Size width height, PixelData RGBA UnsignedByte buf) -- changed the PixelFormat constructor here from RGB to RGBA, to account for our alpha data.
src/Graphics/SceneGraph/Render.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, - TypeSynonymInstances, PatternSignatures #-} + TypeSynonymInstances, ScopedTypeVariables #-} ---------------------------------------------------------------------- -- |
− src/Graphics/SceneGraph/SimpleViewPort.hs
@@ -1,503 +0,0 @@-{-# 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 }) -
+ src/Graphics/SceneGraph/SimpleViewport.hs view
@@ -0,0 +1,503 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, + TypeSynonymInstances, ScopedTypeVariables #-} + +---------------------------------------------------------------------- +-- | +-- 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 }) +