diff --git a/CHANGES b/CHANGES deleted file mode 100644 --- a/CHANGES +++ /dev/null @@ -1,4 +0,0 @@ -Version 0.1.0.1 - -Rename SimpleViewPort.hs to SimpleViewport -Fix the deprecated language pragmas diff --git a/data/Snow.tga b/data/Snow.tga deleted file mode 100644 Binary files a/data/Snow.tga and /dev/null differ diff --git a/data/ankhlite_wht.tga b/data/ankhlite_wht.tga deleted file mode 100644 Binary files a/data/ankhlite_wht.tga and /dev/null differ diff --git a/data/ankhlite_ylw.blend.tga b/data/ankhlite_ylw.blend.tga deleted file mode 100644 Binary files a/data/ankhlite_ylw.blend.tga and /dev/null differ diff --git a/data/ankhlite_ylw.tga b/data/ankhlite_ylw.tga deleted file mode 100644 Binary files a/data/ankhlite_ylw.tga and /dev/null differ diff --git a/data/bounce_effects.tga b/data/bounce_effects.tga deleted file mode 100644 Binary files a/data/bounce_effects.tga and /dev/null differ diff --git a/data/font.tga b/data/font.tga deleted file mode 100644 Binary files a/data/font.tga and /dev/null differ diff --git a/data/gold_groove.tga b/data/gold_groove.tga deleted file mode 100644 Binary files a/data/gold_groove.tga and /dev/null differ diff --git a/data/gold_trim01.tga b/data/gold_trim01.tga deleted file mode 100644 Binary files a/data/gold_trim01.tga and /dev/null differ diff --git a/data/gold_trim02.tga b/data/gold_trim02.tga deleted file mode 100644 Binary files a/data/gold_trim02.tga and /dev/null differ diff --git a/data/gold_trim03.tga b/data/gold_trim03.tga deleted file mode 100644 Binary files a/data/gold_trim03.tga and /dev/null differ diff --git a/data/heiro_01.tga b/data/heiro_01.tga deleted file mode 100644 Binary files a/data/heiro_01.tga and /dev/null differ diff --git a/data/leaf.tga b/data/leaf.tga deleted file mode 100644 Binary files a/data/leaf.tga and /dev/null differ diff --git a/data/oldbrk_01.tga b/data/oldbrk_01.tga deleted file mode 100644 Binary files a/data/oldbrk_01.tga and /dev/null differ diff --git a/data/oldbrk_01broken13.tga b/data/oldbrk_01broken13.tga deleted file mode 100644 Binary files a/data/oldbrk_01broken13.tga and /dev/null differ diff --git a/data/oldbrk_03.tga b/data/oldbrk_03.tga deleted file mode 100644 Binary files a/data/oldbrk_03.tga and /dev/null differ diff --git a/data/oldbrk_03_bloody.tga b/data/oldbrk_03_bloody.tga deleted file mode 100644 Binary files a/data/oldbrk_03_bloody.tga and /dev/null differ diff --git a/data/oldstone2.tga b/data/oldstone2.tga deleted file mode 100644 Binary files a/data/oldstone2.tga and /dev/null differ diff --git a/data/oldstone2_bas01.tga b/data/oldstone2_bas01.tga deleted file mode 100644 Binary files a/data/oldstone2_bas01.tga and /dev/null differ diff --git a/data/oldstone2_bas03.tga b/data/oldstone2_bas03.tga deleted file mode 100644 Binary files a/data/oldstone2_bas03.tga and /dev/null differ diff --git a/data/oldstone2_bas04.tga b/data/oldstone2_bas04.tga deleted file mode 100644 Binary files a/data/oldstone2_bas04.tga and /dev/null differ diff --git a/data/oldstone2_bas05.tga b/data/oldstone2_bas05.tga deleted file mode 100644 Binary files a/data/oldstone2_bas05.tga and /dev/null differ diff --git a/data/oldstone2_bas06.tga b/data/oldstone2_bas06.tga deleted file mode 100644 Binary files a/data/oldstone2_bas06.tga and /dev/null differ diff --git a/data/oldstone2_bas07.tga b/data/oldstone2_bas07.tga deleted file mode 100644 Binary files a/data/oldstone2_bas07.tga and /dev/null differ diff --git a/data/oldstone2_step.tga b/data/oldstone2_step.tga deleted file mode 100644 Binary files a/data/oldstone2_step.tga and /dev/null differ diff --git a/data/oldstone2_trim01.tga b/data/oldstone2_trim01.tga deleted file mode 100644 Binary files a/data/oldstone2_trim01.tga and /dev/null differ diff --git a/data/oldstone2_trim02.tga b/data/oldstone2_trim02.tga deleted file mode 100644 Binary files a/data/oldstone2_trim02.tga and /dev/null differ diff --git a/data/oldstone2grooved.tga b/data/oldstone2grooved.tga deleted file mode 100644 Binary files a/data/oldstone2grooved.tga and /dev/null differ diff --git a/data/oldstone_ramses.tga b/data/oldstone_ramses.tga deleted file mode 100644 Binary files a/data/oldstone_ramses.tga and /dev/null differ diff --git a/data/plant_egy.tga b/data/plant_egy.tga deleted file mode 100644 Binary files a/data/plant_egy.tga and /dev/null differ diff --git a/data/sand_egy.tga b/data/sand_egy.tga deleted file mode 100644 Binary files a/data/sand_egy.tga and /dev/null differ diff --git a/data/stei_tele2.tga b/data/stei_tele2.tga deleted file mode 100644 Binary files a/data/stei_tele2.tga and /dev/null differ diff --git a/scenegraph.cabal b/scenegraph.cabal --- a/scenegraph.cabal +++ b/scenegraph.cabal @@ -1,5 +1,5 @@ Name: scenegraph -Version: 0.1.0.1 +Version: 0.1.0.2 Copyright: Mark Wassell 2009 License: BSD3 license-file: LICENSE @@ -8,7 +8,7 @@ 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-Depends: base>=3 && < 5,mtl,hmatrix,OpenGL>=2.2,GLUT>=2.1,haskell98,containers,fgl == 5.4.2.2,array,old-time,process build-type: Simple tested-with: GHC==6.10.1 Synopsis: Scene Graph diff --git a/src/Calc.hs b/src/Calc.hs deleted file mode 100644 --- a/src/Calc.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Calc where - - -data Calculator = Calculator { replace :: Bool, - operand :: Maybe String, - operator :: Maybe String, - register :: String } deriving Show - -newCalculator = Calculator True Nothing Nothing "0" - - -applyCalc :: Calculator -> String -> Calculator -applyCalc calc "+" = calc { replace=True, - operand = Just (register calc), - operator = Just "+" } -applyCalc calc "=" = doCalc calc -applyCalc calc "c" = newCalculator -applyCalc calc "ce" = calc { replace=True, register="0" } -applyCalc calc str = if replace calc then - calc { replace=False,register=str } - else - calc { register = (register calc) ++ str} - -doCalc calc = let x = read $ maybe "0" id (operand calc ) - y = read $ register calc - in case (operator calc) of - Just "+" -> calc { replace=True,register = show $ x + y,operand= Just $ show y } - _ -> calc - - -calcString = foldl applyCalc newCalculator - -t1 = calcString [ "1", "+", "1", "=", "=", "="] - -t2 = calcString [ "2", "+", "5", "=","="] - - diff --git a/src/Example.hs b/src/Example.hs deleted file mode 100644 --- a/src/Example.hs +++ /dev/null @@ -1,29 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Main --- Copyright : (c) Mark Wassell 2008 --- License : LGPL --- --- Maintainer : mwassell@bigpond.net.au --- Stability : experimental --- Portability : portable --- --- Example scenegraphs. See SimpleViewPort.hs for how to navigate around the --- scene. See Library.hs for the construction of the examples ----------------------------------------------------------------------- -module Main where - -import Graphics.SceneGraph - --- Button and 'Hello World' text. -ex1 = runScene sceneButton - -ex2 = runScene $ osgt $ cube 0.5 `colour` Green `scale` v1x 40 `translate` vy 2 <+> camera `translate` vy (-10) <+> light `translate` vz 10 - --- An Ancient Egyptian Calculator -ex3 = runScene calculator - --- Tux the penguin -ex4 = runScene tuxAndToys - - diff --git a/src/ExampleReactive.hs b/src/ExampleReactive.hs deleted file mode 100644 --- a/src/ExampleReactive.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Main where - -import Graphics.SceneGraph -import Graphics.SceneGraph.Reactive - -import Control.Concurrent.MVar -import Control.Monad.State -import Control.Applicative hiding ( (<*>) ) -import Control.Concurrent (yield, forkIO, killThread, threadDelay, ThreadId,forkOS) - -import Data.Reactive -import Data.IORef -import Data.Monoid - -import Calc - -calc = runSceneReactive calculator sceneButtonReactive - --- --- To get at the string to display we fmap register to the calculator --- -sceneButtonReactive :: SGM (Event Action) -sceneButtonReactive = do - snk <- getNodeByLabel "txt" >>= mkText - ce <- calcEvent - return $ snk <$> (fmap register ce ) - --- Build a Calculator event. Build up the button events and --- append these events together. -calcEvent :: SGM (Event Calculator) -calcEvent = do - btnList <- mapM mkCalcBtn ["0","1","2","3","4","5","6","7","8","9","c", "+","=" ] - return $ scanlE applyCalc newCalculator $ foldr mappend mempty btnList - - --- Turn passive button in the scene graph into an active one that --- provides an event that returns 'lbl' -mkCalcBtn :: [Char] -> SGM (Event String) -mkCalcBtn lbl = do - ev <- getNodeByLabel ("btn" ++ lbl) >>= mkButton - return $ fmap (const lbl) ev - - diff --git a/src/Graphics/SceneGraph/Basic.hs b/src/Graphics/SceneGraph/Basic.hs --- a/src/Graphics/SceneGraph/Basic.hs +++ b/src/Graphics/SceneGraph/Basic.hs @@ -37,7 +37,7 @@ import Data.Array hiding (bounds) import Data.IORef import Data.Graph.Inductive hiding (mkNode,context) -import Data.Sequence hiding (empty,fromList) +import Data.Sequence hiding (empty,fromList,filter,zip) import Data.Tree import Data.List hiding (group,union) import qualified Data.Map as M diff --git a/src/Graphics/SceneGraph/Matrix.hs b/src/Graphics/SceneGraph/Matrix.hs deleted file mode 100644 --- a/src/Graphics/SceneGraph/Matrix.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, - TypeSynonymInstances #-} -module Graphics.SceneGraph.Matrix where - --- Warning: Because this matrix is going to get passed directly to GL we convert to GL space --- here. - -import Graphics.Rendering.OpenGL hiding (Matrix) -import Graphics.SceneGraph.Vector -import Data.List -import Numeric.LinearAlgebra -- (inv, (><),toLists,Matrix,Vector,mul,fromLists,toList,fromList ) - -type MatrixD = Matrix GLdouble - -identityMatrix :: MatrixD -identityMatrix = fromLists [ [1,0,0,0], [0,1,0,0], [0,0,1,0],[0,0,0,1]] - -asMatrix :: VectorD -> MatrixD -asMatrix vec = let v = toList vec - in fromLists [ [1, 0, 0, v!!0],[ 0, 1, 0, v!!2],[ 0, 0, 1 , (-(v!!1))],[ 0, 0, 0, 1] ] - -translateM :: VectorD -> MatrixD -> MatrixD -translateM v m = (asMatrix v) `multiply` m - - -translatePostM :: VectorD -> MatrixD -> MatrixD -translatePostM v m = m `multiply` (asMatrix v) - -scaleM :: VectorD -> MatrixD -> MatrixD -scaleM vec m = let v = toList vec - in m `multiply` (fromLists [ [ v!!0,0,0,0],[ 0, v!!2,0,0],[ 0, 0, (-(v!!1)),0],[ 0, 0, 0, 1] ]) - --- | Build rotational transform matrix for rotate of ''theta'' around a vector. -rotateM' :: ((Element a)) => a -> Vector a -> Matrix a -rotateM' theta v = fromLists [ [ t*x*x + c, t*x*y-s*z, t*x*z + s*y, 0], - [ t*x*y+s*z, t*y*y + c, t*y*z - s*x , 0], - [ t*x*z-s*y, t*y*z + s*x, t*z*z+c, 0], - [0,0,0,1]] - where t = 1 - cos theta - c = cos theta - s = sin theta - [x',y',z'] = toList v - [x,y,z] = [x',z',(-y')] - -rotateM theta v m = (rotateM' theta v) `multiply` m - -rotatePostM theta v m = m `multiply` (rotateM' theta v) - - -mulV :: MatrixD -> VectorD -> VectorD -mulV m v = head $ toColumns $ m `multiply` (asColumn v) - diff --git a/src/Graphics/SceneGraph/MySTM.hs b/src/Graphics/SceneGraph/MySTM.hs deleted file mode 100644 --- a/src/Graphics/SceneGraph/MySTM.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, - TypeSynonymInstances, TypeOperators #-} -{-- - At some point I was going to use STM. Rather than change the code back, just use the - primitive mappings to MVar. ---} - -module Graphics.SceneGraph.MySTM where - -import Data.IORef -import Control.Concurrent.MVar - -type STM a = IO a - -atomically :: MVar Bool -> STM a -> IO a -atomically sem f = withMVar sem (\_ -> f) - -unsafeIOToSTM :: IO a -> STM a -unsafeIOToSTM = id - -type TVar a = IORef a - -readTVar :: TVar a -> STM a -readTVar = readIORef - -writeTVar :: TVar a -> a -> STM () -writeTVar = writeIORef - -newTVar :: a -> STM (TVar a) -newTVar = newIORef diff --git a/src/Graphics/SceneGraph/Reactive.hs b/src/Graphics/SceneGraph/Reactive.hs deleted file mode 100644 --- a/src/Graphics/SceneGraph/Reactive.hs +++ /dev/null @@ -1,124 +0,0 @@ - ----------------------------------------------------------------------- --- | --- Module : Graphics.SceneGraph.Reactive --- Copyright : (c) Mark Wassell 2008 --- License : LGPL --- --- Maintainer : mwassell@bigpond.net.au --- Stability : experimental --- Portability : portable --- --- This module provides the ability to 'enliven' a scene with widgets --- which act as sources of events and are sinks. For example button widgets --- and text string display areas. --- --- runSceneReactive takes a scene and an instance of SGM monad. The latter --- would have been built up to provide a series of actions to enliven --- the scene. The monad is run prior to passing the scene to the viewport --- engine. ----------------------------------------------------------------------- - -module Graphics.SceneGraph.Reactive where - -import Data.Reactive -import Graphics.SceneGraph.Basic -import Control.Monad.State -import Control.Concurrent.MVar -import Graphics.SceneGraph.MySTM -import Graphics.SceneGraph.SimpleViewport -import Data.IORef -import Graphics.Rendering.OpenGL.GL.BasicTypes (GLdouble) -import Data.Graph.Inductive (Node) - -import Graphics.SceneGraph.SimpleViewport (GSRef,GraphicsState(..)) - -data Widget = Button Scene | Slider Scene | Wheel Scene | WText Scene - - -{-- - The widget building functions below assume the following structure in the - scene graph for the following widgets: - - Simple Button: Handler -> Switch -> Material -> Sphere - -> Material -> Sphere - - Button -> Group -> Group -> Transform -> Material -> Transform -> Torus - Transform -> Material -> Cube - -> Transform -> Simple Button - - Slider == Same as button in structure BUT has a different output and the button can slide. - - Text = Text ---} - --- | This monad allows us to compose widget building actions on the scene. -type SGM = StateT (Scene,MVar Bool ,GSRef) IO - - -getNodeByLabel :: String -> SGM Node -getNodeByLabel lbl = do - ((sg,_),_,_) <- get - return $ getByLabel sg lbl - --- | Turn the supplied node into an button style widget --- Int needs to reference a handler -mkButton :: Int -> SGM (Event Bool) -mkButton nde = do - ((sg,start),sem,ref) <- get - let nde' = findHandlerDown sg nde - -- lift $ putStrLn $ "handler " ++ show nde' - (ev,snk') <- lift $ mkEvent - let snk _ = snk' True - let (SceneNode ide (Handler (Just (f,_)) dh)) = llab sg nde' - sg' = replaceNode'' sg (SceneNode ide (Handler (Just (f,snk)) dh )) - put ((sg',start),sem,ref) - return $ ev - --- | Turn the referenced node into a slider style widget -mkSlider :: Int -> SGM (Event GLdouble) -mkSlider nde = do - ((sg,start),sem,ref) <- get - (ev,snk) <- lift $ mkEvent - let (SceneNode ide (Handler ch (Just (f,_)))) = llab sg nde - sg' = replaceNode'' sg (SceneNode ide (Handler ch (Just (f,snk)) )) - put ((sg',start),sem,ref) - return $ ev - - -doText :: Int -> MVar Bool -> GSRef -> Sink String -doText nde sem ref a = updateNode nde sem ref (Text $ a) - -updateNode :: Node -> MVar Bool -> IORef GraphicsState -> SceneData -> IO () -updateNode nde sem ref dte = atomically sem $ do - gs <- readIORef ref - case gsScene gs of - Just (gr,start) -> do - let (SceneNode lab _) = llab gr nde - gr' = replaceNode'' gr (SceneNode lab dte) - writeIORef ref (gs { gsDisplayList=Nothing,gsScene = Just (gr',start)}) - return () - _ -> return () - --- | Turn the referenced node into a text sink widget -mkText :: Int -> SGM (Sink String) -mkText nde = do - ((sg,_),sem,ref) <- get - let nde' = findTextDown sg nde - return $ doText nde' sem ref - - --- | Run a scene with supplied Event Action builder -runSceneReactive :: Scene -> SGM (Event Action) -> IO () -runSceneReactive scene sr = do - sem <- newMVar True - ref <- newTVar newState - - -- We have pass sem and ref as these are need when the widgets are - -- doing something when we run the scene. - (x, (scene',sem,ref)) <- runStateT sr (scene,sem,ref) - modifyIORef ref (\s -> s { gsScene = Just scene' }) - forkE x - - setupGUI sem ref - diff --git a/src/Graphics/SceneGraph/ReadImage.hs b/src/Graphics/SceneGraph/ReadImage.hs deleted file mode 100644 --- a/src/Graphics/SceneGraph/ReadImage.hs +++ /dev/null @@ -1,68 +0,0 @@ -{- - ReadImage.hs (adapted from readImage.c which is (c) Silicon Graphics, Inc.) - Copyright (c) Sven Panne 2002-2004 - 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. diff --git a/src/Graphics/SceneGraph/TGA.hs b/src/Graphics/SceneGraph/TGA.hs deleted file mode 100644 --- a/src/Graphics/SceneGraph/TGA.hs +++ /dev/null @@ -1,102 +0,0 @@ -{- TGA.hs; Mun Hon Cheong (mhch295@cse.unsw.edu.au) 2005 - -This module was based on lesson 24 from neon helium productions -http://nehe.gamedev.net/data/lessons/lesson.asp?lesson=24 - -The TGA format is a used bitmap image file format. They are -quite easy to load compared to other formats and have -good support in image editors. All that has to be done is -read the header to determine the dimensions and pixel format. -Then the bytes have to be swapped and can be used by OPenGL. - -If you see a texture that is upside down, just open it in your -editor and flip it vertically. Somtimes the TGA file is stored -with its pixels upside down. - --} - - - -module Graphics.SceneGraph.TGA 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 Foreign.Marshal.Array -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Graphics.UI.GLUT - - -withBinaryFile' :: FilePath -> (Handle -> IO a) -> IO a -withBinaryFile' filePath = bracket (openBinaryFile filePath ReadMode) hClose - - --- reads a *.tga file -readTga :: FilePath -> IO (Maybe (Size, PixelData Word8)) -readTga filePath = - withBinaryFile' filePath $ \handle -> do - buf <- mallocBytes 6 :: IO(Ptr Word8) - --the first 12 bytes of the header aren't used - hGetBuf handle buf 6 - hGetBuf handle buf 6 - hGetBuf handle buf 6 - header <- peekArray 6 buf - let w1 = (fromIntegral (header!!1))*256 :: Int - let width = w1 + (fromIntegral (header!!0)) - let h1 = (fromIntegral (header!!3))*256 :: Int - let height = h1 + (fromIntegral (header!!2)) - let bitspp = (fromIntegral (header!!4)) - let numBytes = (bitspp `div` 8) * width * height - --allocate memory for the image - image <- mallocBytes numBytes - hGetBuf handle image numBytes - --define whether the pixels are in RGB or RGBA format. - pixelFormat <- getFormat (fromIntegral bitspp) - free buf - --convert the pixels which are in BGR/BGRA to RGB/RGBA - swapBytes' image (bitspp `div` 8) (width * height) - print ("loaded "++filePath) - return $ Just (Size (fromIntegral width) (fromIntegral height), - PixelData pixelFormat UnsignedByte image) - - --- converts the image from bgr/bgra to rgb/rgba --- perhaps the opengl bgra extension could be --- used to avoid this -swapBytes' :: Ptr Word8 -> Int -> Int -> IO() -swapBytes' image bytespp size = - case bytespp of - 3 -> do mapM_ (swapByteRGB.(plusPtr image).(bytespp*)) [0..(size-1)] - 4 -> do mapM_ (swapByteRGBA.(plusPtr image).(bytespp*)) [0..(size-1)] - - --- converts from bgr to rgb -swapByteRGB :: Ptr Word8 -> IO() -swapByteRGB ptr = do - [b,g,r] <- peekArray 3 ptr - pokeArray ptr [r,g,b] - - --- converts from bgra to rgba -swapByteRGBA :: Ptr Word8 -> IO() -swapByteRGBA ptr = do - [b,g,r,a] <- peekArray 4 ptr - pokeArray ptr [r,g,b,a] - - --- returns the pixel format given the bits per pixel -getFormat :: Int -> IO(PixelFormat) -getFormat bpp = do - case bpp of - (32) -> return RGBA - (24) -> return RGB - - - - - - diff --git a/src/Graphics/SceneGraph/Utils.hs b/src/Graphics/SceneGraph/Utils.hs deleted file mode 100644 --- a/src/Graphics/SceneGraph/Utils.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Graphics.SceneGraph.Utils where - - -head' s [] = error s -head' s (x:_) = x diff --git a/src/Graphics/SceneGraph/VectorSpace.hs b/src/Graphics/SceneGraph/VectorSpace.hs deleted file mode 100644 --- a/src/Graphics/SceneGraph/VectorSpace.hs +++ /dev/null @@ -1,173 +0,0 @@ -{- -****************************************************************************** -* A F R P * -* * -* Module: AFRPVectorSpace * -* Purpose: Vector space type relation and basic instances. * -* Authors: Henrik Nilsson and Antony Courtney * -* * -* Copyright (c) Yale University, 2003 * -* * -****************************************************************************** --} - -module Vinci.VectorSpace where - -import Graphics.Rendering.OpenGL (Vector3 (..), Vertex3 (..) ) - ------------------------------------------------------------------------------- --- Vector space type relation ------------------------------------------------------------------------------- - -infixr *^ -infixl ^/ -infix 7 `dot` -infixl 6 ^+^, ^-^ - --- Maybe norm and normalize should not be class methods, in which case --- the constraint on the coefficient space (a) should (or, at least, could) --- be Fractional (roughly a Field) rather than Floating. - --- Minimal instance: zeroVector, (*^), (^+^), dot -class Floating a => VectorSpace v a | v -> a where - zeroVector :: v - (*^) :: a -> v -> v - (^/) :: v -> a -> v - negateVector :: v -> v - (^+^) :: v -> v -> v - (^-^) :: v -> v -> v - dot :: v -> v -> a - norm :: v -> a - normalize :: v -> v - - v ^/ a = (1/a) *^ v - - negateVector v = (-1) *^ v - - v1 ^-^ v2 = v1 ^+^ negateVector v2 - - norm v = sqrt (v `dot` v) - - normalize v = if nv /= 0 then v ^/ nv else error "normalize: zero vector" - where - nv = norm v - ------------------------------------------------------------------------------- --- Vector space instances for Float and Double ------------------------------------------------------------------------------- - -instance VectorSpace Float Float where - zeroVector = 0 - - a *^ x = a * x - - x ^/ a = x / a - - negateVector x = (-x) - - x1 ^+^ x2 = x1 + x2 - - x1 ^-^ x2 = x1 - x2 - - x1 `dot` x2 = x1 * x2 - - -instance VectorSpace Double Double where - zeroVector = 0 - - a *^ x = a * x - - x ^/ a = x / a - - negateVector x = (-x) - - x1 ^+^ x2 = x1 + x2 - - x1 ^-^ x2 = x1 - x2 - - x1 `dot` x2 = x1 * x2 - - ------------------------------------------------------------------------------- --- Vector space instances for small tuples of Floating ------------------------------------------------------------------------------- - -instance Floating a => VectorSpace (a,a) a where - zeroVector = (0,0) - - a *^ (x,y) = (a * x, a * y) - - (x,y) ^/ a = (x / a, y / a) - - negateVector (x,y) = (-x, -y) - - (x1,y1) ^+^ (x2,y2) = (x1 + x2, y1 + y2) - - (x1,y1) ^-^ (x2,y2) = (x1 - x2, y1 - y2) - - (x1,y1) `dot` (x2,y2) = x1 * x2 + y1 * y2 - - -instance Floating a => VectorSpace (a,a,a) a where - zeroVector = (0,0,0) - - a *^ (x,y,z) = (a * x, a * y, a * z) - - (x,y,z) ^/ a = (x / a, y / a, z / a) - - negateVector (x,y,z) = (-x, -y, -z) - - (x1,y1,z1) ^+^ (x2,y2,z2) = (x1+x2, y1+y2, z1+z2) - - (x1,y1,z1) ^-^ (x2,y2,z2) = (x1-x2, y1-y2, z1-z2) - - (x1,y1,z1) `dot` (x2,y2,z2) = x1 * x2 + y1 * y2 + z1 * z2 - - -instance Floating a => VectorSpace (a,a,a,a) a where - zeroVector = (0,0,0,0) - - a *^ (x,y,z,u) = (a * x, a * y, a * z, a * u) - - (x,y,z,u) ^/ a = (x / a, y / a, z / a, u / a) - - negateVector (x,y,z,u) = (-x, -y, -z, -u) - - (x1,y1,z1,u1) ^+^ (x2,y2,z2,u2) = (x1+x2, y1+y2, z1+z2, u1+u2) - - (x1,y1,z1,u1) ^-^ (x2,y2,z2,u2) = (x1-x2, y1-y2, z1-z2, u1-u2) - - (x1,y1,z1,u1) `dot` (x2,y2,z2,u2) = x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 - - -instance Floating a => VectorSpace (a,a,a,a,a) a where - zeroVector = (0,0,0,0,0) - - a *^ (x,y,z,u,v) = (a * x, a * y, a * z, a * u, a * v) - - (x,y,z,u,v) ^/ a = (x / a, y / a, z / a, u / a, v / a) - - negateVector (x,y,z,u,v) = (-x, -y, -z, -u, -v) - - (x1,y1,z1,u1,v1) ^+^ (x2,y2,z2,u2,v2) = (x1+x2, y1+y2, z1+z2, u1+u2, v1+v2) - - (x1,y1,z1,u1,v1) ^-^ (x2,y2,z2,u2,v2) = (x1-x2, y1-y2, z1-z2, u1-u2, v1-v2) - - (x1,y1,z1,u1,v1) `dot` (x2,y2,z2,u2,v2) = - x1 * x2 + y1 * y2 + z1 * z2 + u1 * u2 + v1 * v2 - - - -instance Floating a => VectorSpace (Vector3 a) a where - zeroVector = Vector3 0 0 0 - a *^ (Vector3 x y z) = Vector3 (a*x) (a*y) (a*z) - (Vector3 x y z) ^/ a = Vector3 (x/a) (y/a) (z/a) - - negateVector (Vector3 x y z) = Vector3 (-x) (-y) (-z) - - (Vector3 x1 y1 z1) ^+^ (Vector3 x2 y2 z2) = Vector3 (x1+x2) (y1+y2) (z1+z2) - (Vector3 x1 y1 z1) ^-^ (Vector3 x2 y2 z2) = Vector3 (x1-x2) (y1-y2) (z1-z2) - (Vector3 x1 y1 z1) `dot` (Vector3 x2 y2 z2) = x1 * x2 + y1 * y2 + z1 * z2 - - -asVec (Vertex3 x y z) = Vector3 x y z