diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Greg Horn + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Greg Horn nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Vis.cabal b/Vis.cabal new file mode 100644 --- /dev/null +++ b/Vis.cabal @@ -0,0 +1,44 @@ +name: Vis +version: 0.7.7.0 +stability: Experimental +synopsis: Painless 3D graphics, no affiliation with gloss +description:{ +This package is a fork of Greg Horn's not-gloss package. +The dependencies have been changed so that it builds with recent ghc versions. +} + +extra-source-files: changelog.txt + +license: BSD3 +license-file: LICENSE +author: Greg Horn +maintainer: Scott N. Walck +copyright: (c) Greg Horn 2012-2015 +category: Graphics +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Vis + Vis.Camera + Vis.Interface + Vis.Vis + Vis.VisObject + Vis.GlossColor + build-depends: base >= 4.5 && < 5, + GLUT >= 2.7.0 && < 2.8, + OpenGL >= 3.0.3 && < 3.1, + OpenGLRaw >= 3.3.4 && < 3.4, + bytestring >= 0.11.4 && < 0.12, + binary >= 0.8.9 && < 0.9, + bmp >= 1.2.6 && < 1.3, + SpatialMath >= 0.2.7 && < 0.3, + vector >= 0.13.0 && < 0.14, + time >= 1.11.1 && < 1.12, + vector-binary-instances >= 0.2.5 && < 0.3 + default-language: Haskell2010 + +source-repository head + type: git + location: git://github.com/ghorn/not-gloss.git diff --git a/changelog.txt b/changelog.txt new file mode 100644 --- /dev/null +++ b/changelog.txt @@ -0,0 +1,2 @@ +0.7.7.0: +- initial fork of not-gloss-0.7.7.0 diff --git a/src/Vis.hs b/src/Vis.hs new file mode 100644 --- /dev/null +++ b/src/Vis.hs @@ -0,0 +1,45 @@ +{-# OPTIONS_GHC -Wall #-} + +module Vis ( Options(..) + , Antialiasing(..) + , Camera0(..) + , defaultOpts + , display + , animate + , simulate + , play + , animateIO + , simulateIO + , playIO + , visMovie + , VisObject(..) + , SpecialKey(..) + , BitmapFont(..) + , Flavour(..) + , LoadedObjModel + , loadObjModel + , module Vis.GlossColor + ) where + +import Graphics.UI.GLUT ( SpecialKey(..), BitmapFont(..), Flavour(..) ) + +import Vis.Vis ( Options(..), Antialiasing(..), visMovie ) +import Vis.Camera ( Camera0(..) ) +import Vis.Interface ( display, animate, simulate, play, animateIO, simulateIO, playIO ) +import Vis.VisObject ( VisObject(..), LoadedObjModel, loadObjModel ) +import Vis.GlossColor + +-- | Some reasonable default options. +-- Consider changing the window name with something like: +-- +-- > myOptions = defaultOpts {optWindowName = "my rad program"} +defaultOpts :: Options +defaultOpts = + Options + { optBackgroundColor = Nothing + , optWindowSize = Nothing + , optWindowPosition = Nothing + , optWindowName = "not-gloss" + , optInitialCamera = Nothing + , optAntialiasing = Aliased + } diff --git a/src/Vis/Camera.hs b/src/Vis/Camera.hs new file mode 100644 --- /dev/null +++ b/src/Vis/Camera.hs @@ -0,0 +1,112 @@ +{-# OPTIONS_GHC -Wall #-} + +module Vis.Camera ( Camera0(..) + , Camera(..) + , makeCamera + , setCamera + , cameraMotion + , cameraKeyboardMouse + ) where + +import Graphics.UI.GLUT ( GLdouble, GLint + , Vector3(..), Vertex3(..) + , Position(..), MouseButton(..), Key(..), KeyState(..) + ) +import qualified Graphics.UI.GLUT as GLUT + +import SpatialMath ( V3(..) ) + +data Camera0 = Camera0 { phi0 :: GLdouble + , theta0 :: GLdouble + , rho0 :: GLdouble + } deriving Show + +data Camera = Camera { phi :: GLdouble + , theta :: GLdouble + , rho :: GLdouble + , pos :: V3 GLdouble + , ballX :: GLint + , ballY :: GLint + , leftButton :: GLint + , rightButton :: GLint + , middleButton :: GLint + } + +makeCamera :: Camera0 -> Camera +makeCamera camera0 = Camera { phi = phi0 camera0 + , theta = theta0 camera0 + , rho = rho0 camera0 + , pos = V3 0 0 0 + , ballX = (-1) + , ballY = (-1) + , leftButton = 0 + , rightButton = 0 + , middleButton = 0 + } + +setCamera :: Camera -> IO () +setCamera camera = GLUT.lookAt (Vertex3 xc yc zc) (Vertex3 x0 y0 z0) (Vector3 0 0 (-1)) + where + V3 x0 y0 z0 = pos camera + phi' = phi camera + theta' = theta camera + rho' = rho camera + + xc = x0 + rho'*cos(phi'*pi/180)*cos(theta'*pi/180) + yc = y0 + rho'*sin(phi'*pi/180)*cos(theta'*pi/180) + zc = z0 - rho'*sin(theta'*pi/180) + +cameraMotion :: Camera -> Position -> Camera +cameraMotion (Camera phi0' theta0' rho0' (V3 x0 y0 z0) bx by lb rb mb) (Position x y) = + Camera nextPhi nextTheta rho0' nextPos nextBallX nextBallY lb rb mb + where + deltaX + | bx == -1 = 0 + | otherwise = fromIntegral (x - bx) + deltaY + | by == -1 = 0 + | otherwise = fromIntegral (y - by) + deltaZ + | by == -1 = 0 + | otherwise = fromIntegral (y - by) + nextTheta' + | deltaY + theta0' > 80 = 80 + | deltaY + theta0' < -80 = -80 + | otherwise = deltaY + theta0' + nextX = x0 + 0.003*rho0'*( -sin(phi0'*pi/180)*deltaX - cos(phi0'*pi/180)*deltaY) + nextY = y0 + 0.003*rho0'*( cos(phi0'*pi/180)*deltaX - sin(phi0'*pi/180)*deltaY) + nextZ = z0 - 0.001*rho0'*deltaZ + + (nextPhi, nextTheta) = if lb == 1 + then (phi0' + deltaX, nextTheta') + else (phi0', theta0') + + nextPos + | rb == 1 = V3 nextX nextY z0 + | mb == 1 = V3 x0 y0 nextZ + | otherwise = V3 x0 y0 z0 + + nextBallX = x + nextBallY = y + +cameraKeyboardMouse :: Camera -> Key -> KeyState -> Camera +cameraKeyboardMouse camera key keyState = + camera {rho = newRho, leftButton = lb, rightButton = rb, middleButton = mb, ballX = bx, ballY = by} + where + (lb, reset0) = case (key, keyState) of (MouseButton LeftButton, Down) -> (1, True) + (MouseButton LeftButton, Up) -> (0, False) + _ -> (leftButton camera, False) + (rb, reset1) = case (key, keyState) of (MouseButton RightButton, Down) -> (1, True) + (MouseButton RightButton, Up) -> (0, False) + _ -> (rightButton camera, False) + (mb, reset2) = case (key, keyState) of (MouseButton MiddleButton, Down) -> (1, True) + (MouseButton MiddleButton, Up) -> (0, False) + _ -> (middleButton camera, False) + + (bx,by) = if reset0 || reset1 || reset2 then (-1,-1) else (ballX camera, ballY camera) + + newRho = case (key, keyState) of (MouseButton WheelUp, Down) -> 0.9 * (rho camera) + (MouseButton WheelDown, Down) -> 1.1 * (rho camera) + (Char 'e', Down) -> 0.9 * (rho camera) + (Char 'q', Down) -> 1.1 * (rho camera) + _ -> rho camera diff --git a/src/Vis/GlossColor.hs b/src/Vis/GlossColor.hs new file mode 100644 --- /dev/null +++ b/src/Vis/GlossColor.hs @@ -0,0 +1,250 @@ +-- Copyright (c) 2010-2012 Benjamin Lippmeier +-- +-- Permission is hereby granted, free of charge, to any person +-- obtaining a copy of this software and associated documentation +-- files (the "Software"), to deal in the Software without +-- restriction, including without limitation the rights to use, +-- copy, modify, merge, publish, distribute, sublicense, and/or sell +-- copies of the Software, and to permit persons to whom the +-- Software is furnished to do so, subject to the following +-- condition: +-- +-- The above copyright notice and this permission notice shall be +-- included in all copies or substantial portions of the Software. + +{-# OPTIONS_GHC #-} + +-- | Predefined and custom colors. +module Vis.GlossColor + ( + -- ** Color data type + Color + , makeColor + , makeColor' + , makeColor8 + , rawColor + , rgbaOfColor + + -- ** Color functions + , mixColors + , addColors + , dim, bright + , light, dark + + -- ** Pre-defined colors + , greyN, black, white + -- *** Primary + , red, green, blue + -- *** Secondary + , yellow, cyan, magenta + + -- *** Tertiary + , rose, violet, azure, aquamarine, chartreuse, orange + ) +where + +-- | An abstract color value. +-- We keep the type abstract so we can be sure that the components +-- are in the required range. To make a custom color use 'makeColor'. +data Color + -- | Holds the color components. All components lie in the range [0..1. + = RGBA !Float !Float !Float !Float + deriving (Show, Eq) + + +instance Num Color where + {-# INLINE (+) #-} + (+) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) + = RGBA (r1 + r2) (g1 + g2) (b1 + b2) 1 + + {-# INLINE (-) #-} + (-) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) + = RGBA (r1 - r2) (g1 - g2) (b1 - b2) 1 + + {-# INLINE (*) #-} + (*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) + = RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1 + + {-# INLINE abs #-} + abs (RGBA r1 g1 b1 _) + = RGBA (abs r1) (abs g1) (abs b1) 1 + + {-# INLINE signum #-} + signum (RGBA r1 g1 b1 _) + = RGBA (signum r1) (signum g1) (signum b1) 1 + + {-# INLINE fromInteger #-} + fromInteger i + = let f = fromInteger i + in RGBA f f f 1 + + +-- | Make a custom color. All components are clamped to the range [0..1]. +makeColor + :: Float -- ^ Red component. + -> Float -- ^ Green component. + -> Float -- ^ Blue component. + -> Float -- ^ Alpha component. + -> Color + +makeColor r g b a + = clampColor + $ RGBA r g b a +{-# INLINE makeColor #-} + + +-- | Make a custom color. +-- You promise that all components are clamped to the range [0..1] +makeColor' :: Float -> Float -> Float -> Float -> Color +makeColor' r g b a + = RGBA r g b a +{-# INLINE makeColor' #-} + + +-- | Make a custom color. All components are clamped to the range [0..255]. +makeColor8 + :: Int -- ^ Red component. + -> Int -- ^ Green component. + -> Int -- ^ Blue component. + -> Int -- ^ Alpha component. + -> Color + +makeColor8 r g b a + = clampColor + $ RGBA (fromIntegral r / 255) + (fromIntegral g / 255) + (fromIntegral b / 255) + (fromIntegral a / 255) +{-# INLINE makeColor8 #-} + + +-- | Take the RGBA components of a color. +rgbaOfColor :: Color -> (Float, Float, Float, Float) +rgbaOfColor (RGBA r g b a) = (r, g, b, a) +{-# INLINE rgbaOfColor #-} + + +-- | Make a custom color. +-- Components should be in the range [0..1] but this is not checked. +rawColor + :: Float -- ^ Red component. + -> Float -- ^ Green component. + -> Float -- ^ Blue component. + -> Float -- ^ Alpha component. + -> Color + +rawColor = RGBA +{-# INLINE rawColor #-} + + +-- Internal + +-- | Clamp components of a color into the required range. +clampColor :: Color -> Color +clampColor cc + = let (r, g, b, a) = rgbaOfColor cc + in RGBA (min 1 r) (min 1 g) (min 1 b) (min 1 a) + +-- | Normalise a color to the value of its largest RGB component. +normaliseColor :: Color -> Color +normaliseColor cc + = let (r, g, b, a) = rgbaOfColor cc + m = maximum [r, g, b] + in RGBA (r / m) (g / m) (b / m) a + + +-- Color functions ------------------------------------------------------------ + +-- | Mix two colors with the given ratios. +mixColors + :: Float -- ^ Ratio of first color. + -> Float -- ^ Ratio of second color. + -> Color -- ^ First color. + -> Color -- ^ Second color. + -> Color -- ^ Resulting color. + +mixColors ratio1 ratio2 c1 c2 + = let RGBA r1 g1 b1 a1 = c1 + RGBA r2 g2 b2 a2 = c2 + + total = ratio1 + ratio2 + m1 = ratio1 / total + m2 = ratio2 / total + + in RGBA (m1 * r1 + m2 * r2) + (m1 * g1 + m2 * g2) + (m1 * b1 + m2 * b2) + (m1 * a1 + m2 * a2) + + +-- | Add RGB components of a color component-wise, then normalise +-- them to the highest resulting one. The alpha components are averaged. +addColors :: Color -> Color -> Color +addColors c1 c2 + = let RGBA r1 g1 b1 a1 = c1 + RGBA r2 g2 b2 a2 = c2 + + in normaliseColor + $ RGBA (r1 + r2) + (g1 + g2) + (b1 + b2) + ((a1 + a2) / 2) + + +-- | Make a dimmer version of a color, scaling towards black. +dim :: Color -> Color +dim (RGBA r g b a) + = RGBA (r / 1.2) (g / 1.2) (b / 1.2) a + + +-- | Make a brighter version of a color, scaling towards white. +bright :: Color -> Color +bright (RGBA r g b a) + = clampColor + $ RGBA (r * 1.2) (g * 1.2) (b * 1.2) a + + +-- | Lighten a color, adding white. +light :: Color -> Color +light (RGBA r g b a) + = clampColor + $ RGBA (r + 0.2) (g + 0.2) (b + 0.2) a + + +-- | Darken a color, adding black. +dark :: Color -> Color +dark (RGBA r g b a) + = clampColor + $ RGBA (r - 0.2) (g - 0.2) (b - 0.2) a + + +-- Pre-defined Colors --------------------------------------------------------- +-- | A greyness of a given magnitude. +greyN :: Float -- ^ Range is 0 = black, to 1 = white. + -> Color +greyN n = RGBA n n n 1.0 + +black, white :: Color +black = RGBA 0.0 0.0 0.0 1.0 +white = RGBA 1.0 1.0 1.0 1.0 + +-- Colors from the additive color wheel. +red, green, blue :: Color +red = RGBA 1.0 0.0 0.0 1.0 +green = RGBA 0.0 1.0 0.0 1.0 +blue = RGBA 0.0 0.0 1.0 1.0 + +-- secondary +yellow, cyan, magenta :: Color +yellow = addColors red green +cyan = addColors green blue +magenta = addColors red blue + +-- tertiary +rose, violet, azure, aquamarine, chartreuse, orange :: Color +rose = addColors red magenta +violet = addColors magenta blue +azure = addColors blue cyan +aquamarine = addColors cyan green +chartreuse = addColors green yellow +orange = addColors yellow red diff --git a/src/Vis/Interface.hs b/src/Vis/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Vis/Interface.hs @@ -0,0 +1,132 @@ +{-# OPTIONS_GHC -Wall #-} + +module Vis.Interface ( display + , animate + , animateIO + , simulate + , simulateIO + , play + , playIO + ) where + +import Data.Maybe ( fromMaybe ) +import Graphics.UI.GLUT ( Key, KeyState, Position, Modifiers, Cursor(..) ) + +import Vis.Vis ( Options(..), vis ) +import Vis.Camera ( Camera, Camera0(..), makeCamera, setCamera, cameraMotion, cameraKeyboardMouse ) +import Vis.VisObject ( VisObject(..) ) + +-- | draw a static image +display :: Real b => + Options -- ^ user options + -> VisObject b -- ^ object to draw + -> IO () +display opts visobjects = animate opts (\_ -> visobjects) + +---- | display an animation +animate :: Real b => + Options -- ^ user options + -> (Float -> VisObject b) -- ^ draw function (takes time since start as input) + -> IO () +animate opts userDrawFun = animateIO opts (return . userDrawFun) + +-- | display an animation impurely +animateIO :: Real b => + Options -- ^ user options + -> (Float -> IO (VisObject b)) -- ^ draw function (takes time since start as input) + -> IO () +animateIO opts userDrawFun = + vis opts ts (userState0, cameraState0) simFun drawFun setCameraFun (Just kmCallback) (Just motionCallback) Nothing + where + ts = 0.01 + userState0 = () + cameraState0 = makeCamera $ fromMaybe defaultCamera (optInitialCamera opts) + drawFun (_,time) = do + obs <- userDrawFun time + return (obs, Nothing) + simFun (state,_) = return state + kmCallback (state, camState) k0 k1 _ _ = (state, cameraKeyboardMouse camState k0 k1) + motionCallback (state, cameraState) pos = (state, cameraMotion cameraState pos) + setCameraFun :: ((), Camera) -> IO () + setCameraFun (_,cameraState) = setCamera cameraState + + +-- | run a simulation +simulate :: Real b => + Options -- ^ user options + -> Double -- ^ sample rate + -> world -- ^ initial state + -> (world -> VisObject b) -- ^ draw function + -> (Float -> world -> world) -- ^ state propogation function (takes time since start and state as inputs) + -> IO () +simulate opts ts state0 userDrawFun userSimFun = + simulateIO opts ts state0 (return . userDrawFun) (\t -> return . (userSimFun t)) + +-- | run a simulation impurely +simulateIO :: Real b => + Options -- ^ user options + -> Double -- ^ sample rate + -> world -- ^ initial state + -> (world -> IO (VisObject b)) -- ^ draw function + -> (Float -> world -> IO world) -- ^ state propogation function (takes time since start and state as inputs) + -> IO () +simulateIO opts ts userState0 userDrawFun userSimFun = + vis opts ts (userState0, cameraState0) simFun drawFun setCameraFun (Just kmCallback) (Just motionCallback) Nothing + where + drawFun ((userState, _),_) = do + obs <- userDrawFun userState + return (obs, Nothing) + + simFun ((userState,cameraState),time) = do + nextUserState <- userSimFun time userState + return (nextUserState, cameraState) + cameraState0 = makeCamera $ fromMaybe defaultCamera (optInitialCamera opts) + kmCallback (state, camState) k0 k1 _ _ = (state, cameraKeyboardMouse camState k0 k1) + motionCallback (state, cameraState) pos = (state, cameraMotion cameraState pos) + setCameraFun (_,cameraState) = setCamera cameraState + + +---- | play a game +play :: Real b => + Options -- ^ user options + -> Double -- ^ sample time + -> world -- ^ initial state + -> (world -> (VisObject b, Maybe Cursor)) -- ^ draw function, can give a different cursor + -> (Float -> world -> world) -- ^ state propogation function (takes time since start and state as inputs) + -> (world -> IO ()) -- ^ set where camera looks + -> Maybe (world -> Key -> KeyState -> Modifiers -> Position -> world) -- ^ keyboard/mouse press callback + -> Maybe (world -> Position -> world) -- ^ mouse drag callback + -> Maybe (world -> Position -> world) -- ^ mouse move callback + -> IO () +play opts ts userState0 userDrawFun userSimFun = + vis opts ts userState0 simFun drawFun + where + drawFun (userState, _) = return $ userDrawFun userState + simFun (userState,time) = return $ userSimFun time userState + + +---- | play a game impurely +playIO :: Real b => + Options -- ^ user options + -> Double -- ^ sample time + -> world -- ^ initial state + -> (world -> IO (VisObject b, Maybe Cursor)) -- ^ draw function, can give a different cursor + -> (Float -> world -> IO world) -- ^ state propogation function (takes time since start and state as inputs) + -> (world -> IO ()) -- ^ set where camera looks + -> Maybe (world -> Key -> KeyState -> Modifiers -> Position -> world) -- ^ keyboard/mouse press callback + -> Maybe (world -> Position -> world) -- ^ mouse drag callback + -> Maybe (world -> Position -> world) -- ^ mouse move callback + -> IO () +playIO opts ts userState0 userDrawFun userSimFun = + vis opts ts userState0 simFun drawFun + where + drawFun (userState, _) = userDrawFun userState + simFun (userState,time) = userSimFun time userState + + +defaultCamera :: Camera0 +defaultCamera = + Camera0 + { phi0 = 60 + , theta0 = 20 + , rho0 = 7} diff --git a/src/Vis/Vis.hs b/src/Vis/Vis.hs new file mode 100644 --- /dev/null +++ b/src/Vis/Vis.hs @@ -0,0 +1,455 @@ +{-# OPTIONS_GHC -Wall #-} +{-# Language ScopedTypeVariables #-} + +module Vis.Vis ( Options(..) + , Antialiasing(..) + , vis + , visMovie + , visMovieImmediately + , FullState + ) where + +import Codec.BMP ( BMP, packRGBA32ToBMP32, writeBMP ) +import Control.Concurrent ( MVar, readMVar, swapMVar, newMVar, takeMVar, putMVar, forkIO, threadDelay ) +import Control.Monad ( unless, forever ) +import qualified Data.ByteString.Unsafe as BS +import Data.Maybe ( fromMaybe ) +import Data.IORef ( newIORef, readIORef, writeIORef ) +import Data.Time.Clock ( getCurrentTime, diffUTCTime, addUTCTime ) +import Data.Word ( Word8 ) +import Foreign.Marshal.Alloc ( free ) +import Foreign.Marshal.Array ( mallocArray ) +import Foreign.Ptr ( Ptr, castPtr ) +import Foreign.Storable ( sizeOf ) +import qualified Graphics.UI.GLUT as GLUT +import Graphics.UI.GLUT ( Capability(..), ClearBuffer(..), Color4(..), ColorMaterialParameter(..) + , ComparisonFunction(..), Cursor(..), DisplayMode(..), Face(..) + , Key(..), KeyState(..), Light(..), Modifiers(..), Position(..) + , ShadingModel(..), Size(..) + , DisplayCallback, ReshapeCallback + , ($=) + ) +import Graphics.GL +import Text.Printf ( printf ) +import System.Exit ( exitSuccess ) + +import Vis.Camera ( Camera, Camera0(..), setCamera, makeCamera, cameraKeyboardMouse, cameraMotion ) +import Vis.VisObject ( VisObject(..), drawObjects, setPerspectiveMode ) +import qualified Vis.GlossColor as GC + +-- | user state and internal states +type FullState a = (a, Float) + +data Antialiasing = + Aliased + | Smoothed + | Multisampled Int + deriving (Eq, Show, Ord) + +data Options = + Options + { optBackgroundColor :: Maybe GC.Color -- ^ optional background color + , optWindowSize :: Maybe (Int,Int) -- ^ optional (x,y) window size in pixels + , optWindowPosition :: Maybe (Int,Int) -- ^ optional (x,y) window origin in pixels + , optWindowName :: String -- ^ window name + , optInitialCamera :: Maybe Camera0 -- ^ initial camera position + , optAntialiasing :: Antialiasing -- ^ which antialiasing strategy to use + } deriving Show + +myGlInit :: Options -> IO () +myGlInit opts = do + let displayMode = [ DoubleBuffered, RGBAMode, WithDepthBuffer ] ++ + case optAntialiasing opts of + Multisampled numSamples -> [ GLUT.Multisampling + , GLUT.WithSamplesPerPixel numSamples + ] + _ -> [] + GLUT.initialDisplayMode $= displayMode + + Size x y <- GLUT.get GLUT.screenSize + let intScale d i = round $ d*(realToFrac i :: Double) + x0 = intScale 0.3 x + xf = intScale 0.95 x + y0 = intScale 0.05 y + yf = intScale 0.95 y + + (xsize, ysize) = fromMaybe (xf - x0, yf - y0) (optWindowSize opts) + (xpos, ypos) = fromMaybe (x0,y0) (optWindowPosition opts) + + GLUT.initialWindowSize $= Size (fromIntegral xsize) (fromIntegral ysize) + GLUT.initialWindowPosition $= Position (fromIntegral xpos) (fromIntegral ypos) + _ <- GLUT.createWindow (optWindowName opts) + + case optBackgroundColor opts of + Nothing -> GLUT.clearColor $= Color4 0 0 0 0 + Just col -> GLUT.clearColor $= Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a) + where + (r,g,b,a) = GC.rgbaOfColor col + GLUT.shadeModel $= Smooth + GLUT.depthFunc $= Just Less + GLUT.lighting $= Enabled + GLUT.light (Light 0) $= Enabled + GLUT.ambient (Light 0) $= Color4 1 1 1 1 + + GLUT.materialDiffuse Front $= Color4 0.5 0.5 0.5 1 + GLUT.materialSpecular Front $= Color4 1 1 1 1 + GLUT.materialShininess Front $= 100 + GLUT.colorMaterial $= Just (Front, Diffuse) + + case optAntialiasing opts of + Aliased -> do + GLUT.lineSmooth $= Disabled + GLUT.pointSmooth $= Disabled + GLUT.multisample $= Disabled + Smoothed -> do + GLUT.hint GLUT.LineSmooth $= GLUT.Nicest + GLUT.hint GLUT.PointSmooth $= GLUT.Nicest + GLUT.lineSmooth $= Enabled + GLUT.pointSmooth $= Enabled + GLUT.multisample $= Disabled + Multisampled _ -> do + GLUT.lineSmooth $= Disabled + GLUT.pointSmooth $= Disabled + GLUT.multisample $= Enabled + + glEnable GL_BLEND + glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA + +drawScene :: MVar (FullState a) -> MVar Bool -> IO () -> (FullState a -> IO ()) -> DisplayCallback +drawScene stateMVar visReadyMVar setCameraFun userDrawFun = do + GLUT.clear [ ColorBuffer, DepthBuffer ] + + -- draw the scene + GLUT.preservingMatrix $ do + -- set the camera's position and orientation + setCameraFun + + -- call user function + state <- readMVar stateMVar + userDrawFun state + + GLUT.flush + GLUT.swapBuffers + _ <- swapMVar visReadyMVar True + GLUT.postRedisplay Nothing + + +reshape :: ReshapeCallback +reshape size@(Size _ _) = do + GLUT.viewport $= (Position 0 0, size) + setPerspectiveMode + GLUT.loadIdentity + GLUT.postRedisplay Nothing + + +vis :: Real b => + Options -- ^ user options + -> Double -- ^ sample time + -> a -- ^ initial state + -> (FullState a -> IO a) -- ^ sim function + -> (FullState a -> IO (VisObject b, Maybe Cursor)) -- ^ draw function, can give a different cursor + -> (a -> IO ()) -- ^ set camera function + -> Maybe (a -> Key -> KeyState -> Modifiers -> Position -> a) -- ^ keyboard/mouse callback + -> Maybe (a -> Position -> a) -- ^ motion callback + -> Maybe (a -> Position -> a) -- ^ passive motion callback + -> IO () +vis opts ts x0 userSimFun userDraw userSetCamera + userKeyMouseCallback userMotionCallback userPassiveMotionCallback = do + -- init glut/scene + _ <- GLUT.getArgsAndInitialize + + myGlInit opts + + -- create internal state + let fullState0 = (x0, 0) + stateMVar <- newMVar fullState0 + visReadyMVar <- newMVar False + + -- start sim thread + _ <- forkIO $ simThread stateMVar visReadyMVar userSimFun ts + + -- setup the callbacks + let makePictures x = do + (visobs,cursor') <- userDraw x + drawObjects $ (fmap realToFrac) visobs + case cursor' of Nothing -> return () + Just cursor'' -> GLUT.cursor $= cursor'' + + setCamera' = do + (state,_) <- readMVar stateMVar + userSetCamera state + + -- kill sim thread when someone hits ESC + exitOverride k0 k1 k2 k3 = case (k0,k1) of + (Char '\27', Down) -> exitSuccess + _ -> case userKeyMouseCallback of + Nothing -> return () + Just cb -> do + (state0',time) <- takeMVar stateMVar + putMVar stateMVar (cb state0' k0 k1 k2 k3, time) + GLUT.postRedisplay Nothing + + motionCallback' pos = case userMotionCallback of + Nothing -> return () + Just cb -> do + (state0',ts') <- takeMVar stateMVar + putMVar stateMVar (cb state0' pos, ts') + GLUT.postRedisplay Nothing + + passiveMotionCallback' pos = case userPassiveMotionCallback of + Nothing -> return () + Just cb -> do + (state0',ts') <- takeMVar stateMVar + putMVar stateMVar (cb state0' pos, ts') + GLUT.postRedisplay Nothing + + GLUT.displayCallback $= drawScene stateMVar visReadyMVar setCamera' makePictures + GLUT.reshapeCallback $= Just reshape + GLUT.keyboardMouseCallback $= Just exitOverride + GLUT.motionCallback $= Just motionCallback' + GLUT.passiveMotionCallback $= Just passiveMotionCallback' + + -- start main loop + GLUT.mainLoop + +simThread :: MVar (FullState a) -> MVar Bool -> (FullState a -> IO a) -> Double -> IO () +simThread stateMVar visReadyMVar userSimFun ts = do + let waitUntilDisplayIsReady :: IO () + waitUntilDisplayIsReady = do -- todo: why not just block? + visReady <- readMVar visReadyMVar + unless visReady $ do + threadDelay 10000 + waitUntilDisplayIsReady + + waitUntilDisplayIsReady + + t0 <- getCurrentTime + lastTimeRef <- newIORef t0 + + forever $ do + -- calculate how much longer to sleep before taking a timestep + currentTime <- getCurrentTime + lastTime <- GLUT.get lastTimeRef + let usRemaining :: Int + usRemaining = round $ 1e6*(ts - realToFrac (diffUTCTime currentTime lastTime)) + secondsSinceStart = realToFrac (diffUTCTime currentTime t0) + + if usRemaining <= 0 + -- slept for long enough, do a sim iteration + then do + lastTimeRef $= addUTCTime (realToFrac ts) lastTime + + let getNextState = do + state <- readMVar stateMVar + userSimFun state + putState x = swapMVar stateMVar (x, secondsSinceStart) + + nextState <- getNextState + _ <- nextState `seq` putState nextState + + GLUT.postRedisplay Nothing + + -- need to sleep longer + else threadDelay usRemaining + + + + +movieSimThread :: [VisObject a] -> MVar ([VisObject a], Camera) -> MVar Bool -> Double -> IO () +movieSimThread objects0 stateMVar visReadyMVar ts = do + let waitUntilDisplayIsReady :: IO () + waitUntilDisplayIsReady = do -- todo: why not just block? + visReady <- readMVar visReadyMVar + unless visReady $ do + threadDelay 10000 + waitUntilDisplayIsReady + + waitUntilDisplayIsReady + + t0 <- getCurrentTime + lastTimeRef <- newIORef t0 + + forever $ do + -- calculate how much longer to sleep before taking a timestep + currentTime <- getCurrentTime + lastTime <- GLUT.get lastTimeRef + let usRemaining :: Int + usRemaining = round $ 1e6*(ts - realToFrac (diffUTCTime currentTime lastTime)) + + if usRemaining <= 0 + -- slept for long enough, do a sim iteration + then do + lastTimeRef $= addUTCTime (realToFrac ts) lastTime + + let getNextState = do + state <- readMVar stateMVar + let next = case state of + (_:xs, cs) -> (xs, cs) + ([], cs) -> (objects0, cs) + return next + putState x = swapMVar stateMVar x + + nextState <- getNextState + _ <- nextState `seq` putState nextState + + GLUT.postRedisplay Nothing + + -- need to sleep longer + else threadDelay usRemaining + +-- | Make a series of images, one from each 'VisObject'. +-- When 'visMovie' is executed a window pops up and loops the animation +-- until you are happy with the camera angle. +-- Hit spacebar and the images will be created and saved to disk. +visMovie + :: forall b + . Real b + => Options -- ^ user options + -> (Int -> FilePath) -- ^ where to write the bitmaps + -> Double -- ^ sample time + -> [VisObject b] -- ^ movie to draw + -> Maybe Cursor -- ^ optional cursor + -> IO () +visMovie = visMovie' False + +-- | Make a series of images, one from each 'VisObject'. +-- When 'visMovieImmediately' is executed a window is opened and without +-- waiting the images are created and saved to disk. +visMovieImmediately + :: forall b + . Real b + => Options -- ^ user options + -> (Int -> FilePath) -- ^ where to write the bitmaps + -> Double -- ^ sample time + -> [VisObject b] -- ^ movie to draw + -> Maybe Cursor -- ^ optional cursor + -> IO () +visMovieImmediately = visMovie' True + +visMovie' + :: forall b + . Real b + => Bool -- ^ start immediately + -> Options -- ^ user options + -> (Int -> FilePath) -- ^ where to write the bitmaps + -> Double -- ^ sample time + -> [VisObject b] -- ^ movie to draw + -> Maybe Cursor -- ^ optional cursor + -> IO () +visMovie' startImmediately opts toFilename ts objectsToDraw maybeCursor = do + -- init glut/scene + _ <- GLUT.getArgsAndInitialize + + myGlInit opts + + let defaultCam = + Camera0 { phi0 = 60 + , theta0 = 20 + , rho0 = 7} + cameraState0 = makeCamera $ fromMaybe defaultCam (optInitialCamera opts) + + -- create internal state + areWeDrawingRef <- newIORef False + stateMVar <- newMVar (objectsToDraw, cameraState0) + visReadyMVar <- newMVar startImmediately + + -- start sim thread + _ <- forkIO $ movieSimThread objectsToDraw stateMVar visReadyMVar ts + + -- setup the callbacks + let makePictures :: VisObject b -> Camera -> IO () + makePictures visobj cam = do + GLUT.clear [ ColorBuffer, DepthBuffer ] + + -- draw the scene + GLUT.preservingMatrix $ do + setCamera cam + drawObjects $ (fmap realToFrac) visobj + case maybeCursor of + Nothing -> return () + Just cursor -> GLUT.cursor $= cursor + + GLUT.flush + GLUT.swapBuffers + _ <- swapMVar visReadyMVar True + GLUT.postRedisplay Nothing + + screenShot :: Int -> Camera -> (VisObject b, Int) -> IO () + screenShot n camera (visobj, imageNumber) = do + -- todo: are width/height reversed? + size@(Size width height) <- GLUT.get GLUT.windowSize + let pos = Position 0 0 + ubytePtr <- mallocArray (fromIntegral (4*width*height)) :: IO (Ptr GLubyte) + let pixelData = GLUT.PixelData GLUT.RGBA GLUT.UnsignedByte ubytePtr + makePictures visobj camera + -- "glFinish" will do the job, but it may be overkill. + -- "swapBuffers" is probably good enough. + -- http://stackoverflow.com/questions/2143240/opengl-glflush-vs-glfinish + -- We just need to make sure that readPixels will do the right thing + GLUT.finish + GLUT.readPixels pos size pixelData + let wordPtr :: Ptr Word8 + wordPtr + | sizeOf (0 :: GLubyte) == sizeOf (0 :: Word8) = castPtr ubytePtr + | otherwise = error "GLubyte size /= Word8 size" + + bs <- BS.unsafePackCStringFinalizer + wordPtr (fromIntegral (4*width*height)) (free ubytePtr) + let bmp :: BMP + bmp = packRGBA32ToBMP32 (fromIntegral width) (fromIntegral height) bs + + let filename = toFilename imageNumber + percent :: Double + percent = 100 * fromIntegral imageNumber / fromIntegral n + printf "writing \"%s\" (%d / %d == %6.2f %%) ...\n" filename imageNumber n percent + writeBMP filename bmp + + drawFun = do + areWeDrawing <- readIORef areWeDrawingRef + (state,cam) <- readMVar stateMVar + if areWeDrawing + then do let n = length objectsToDraw + state' <- takeMVar stateMVar + mapM_ (screenShot n cam) (zip objectsToDraw [0..]) + putStrLn "finished writing files" + putStrLn "you might want to try some command like:" + putStrLn "\"ffmpeg -framerate 50 -i data/movie.%03d.bmp -c:v libx264 -r 30 -pix_fmt yuv420p out.mp4\"" + putMVar stateMVar state' + + writeIORef areWeDrawingRef False + else do let visobj = case (state, objectsToDraw) of + (y:_, _) -> y -- draw head object + ([], y:_) -> y -- empty state so just draw first object + ([], []) -> VisObjects [] -- nothing available + makePictures visobj cam + + exitOverride k0 k1 _k2 _k3 = case (k0,k1) of + -- ESC button exits the program + (Char '\27', Down) -> exitSuccess + -- space bar starts screenshots + (Char ' ', Down) -> writeIORef areWeDrawingRef True + _ -> do + (state0', cs) <- takeMVar stateMVar + putMVar stateMVar (state0', cameraKeyboardMouse cs k0 k1) + GLUT.postRedisplay Nothing + + motionCallback' pos = do + (state0', cs) <- takeMVar stateMVar + putMVar stateMVar (state0', cameraMotion cs pos) + GLUT.postRedisplay Nothing + +-- passiveMotionCallback' pos = case userPassiveMotionCallback of +-- Nothing -> return () +-- Just cb -> do +-- (state0', cs) <- takeMVar stateMVar +-- putMVar stateMVar (cb state0' pos, cs) +-- GLUT.postRedisplay Nothing + + GLUT.displayCallback $= drawFun + GLUT.reshapeCallback $= Just reshape + GLUT.keyboardMouseCallback $= Just exitOverride + GLUT.motionCallback $= Just motionCallback' +-- GLUT.passiveMotionCallback $= Just passiveMotionCallback' + + -- start main loop + GLUT.mainLoop diff --git a/src/Vis/VisObject.hs b/src/Vis/VisObject.hs new file mode 100644 --- /dev/null +++ b/src/Vis/VisObject.hs @@ -0,0 +1,435 @@ +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# Language StandaloneDeriving #-} +{-# Language DeriveFunctor #-} +{-# Language DeriveGeneric #-} +{-# Language TypeSynonymInstances #-} + +module Vis.VisObject ( VisObject(..) + , drawObjects + , LoadedObjModel(..) + , loadObjModel + , setPerspectiveMode + ) where + +import GHC.Generics ( Generic ) + +import Control.Monad ( when ) +import qualified Data.Binary as B +import qualified Data.Foldable as F +import Data.Maybe ( fromJust, isJust ) +import Data.Vector.Binary () +import qualified Data.Vector.Storable as VS +import Data.Word ( Word8 ) +import Graphics.GL +import qualified Graphics.Rendering.OpenGL as GL +import qualified Graphics.UI.GLUT as GLUT +import Graphics.UI.GLUT ( BitmapFont(..), Capability(..), Color4(..), Face(..) + , Flavour(..), MatrixMode(..), PrimitiveMode(..), Size(..) + , Vertex3(..), Vector3(..) + , ($=) + ) + +import SpatialMath + +import qualified Vis.GlossColor as GlossColor + +glColorOfColor :: GlossColor.Color -> Color4 GLfloat +glColorOfColor = (\(r,g,b,a) -> fmap realToFrac (Color4 r g b a)) . GlossColor.rgbaOfColor + +setColor :: GlossColor.Color -> IO () +setColor = GLUT.color . glColorOfColor + +setMaterialDiffuse :: GlossColor.Color -> IO () +setMaterialDiffuse col = GLUT.materialDiffuse Front $= (glColorOfColor col) + +data VisObject a = VisObjects [VisObject a] + | Trans (V3 a) (VisObject a) + | RotQuat (Quaternion a) (VisObject a) + | RotDcm (M33 a) (VisObject a) + | RotEulerRad (Euler a) (VisObject a) + | RotEulerDeg (Euler a) (VisObject a) -- degrees more efficient + | Scale (a,a,a) (VisObject a) + | Cylinder (a,a) GlossColor.Color + | Box (a,a,a) Flavour GlossColor.Color + | Cube a Flavour GlossColor.Color + | Sphere a Flavour GlossColor.Color + | Ellipsoid (a,a,a) Flavour GlossColor.Color + | Line (Maybe a) [V3 a] GlossColor.Color + | Line' (Maybe a) [(V3 a,GlossColor.Color)] + | Arrow (a,a) (V3 a) GlossColor.Color + | Axes (a,a) + | Plane (V3 a) GlossColor.Color GlossColor.Color + | Triangle (V3 a) (V3 a) (V3 a) GlossColor.Color + | Quad (V3 a) (V3 a) (V3 a) (V3 a) GlossColor.Color + | Text3d String (V3 a) BitmapFont GlossColor.Color + | Text2d String (a,a) BitmapFont GlossColor.Color + | Points [V3 a] (Maybe GLfloat) GlossColor.Color + | ObjModel LoadedObjModel GlossColor.Color + deriving (Generic, Functor) + +data LoadedObjModel = LoadedObjModel (VS.Vector Double) (VS.Vector Double) Int deriving (Generic) + +instance B.Binary LoadedObjModel + +toFlavour :: Bool -> Flavour +toFlavour False = Solid +toFlavour True = Wireframe + +fromFlavour :: Flavour -> Bool +fromFlavour Solid = False +fromFlavour Wireframe = True + +instance B.Binary Flavour where + put = B.put . fromFlavour + get = fmap toFlavour B.get + + +fromBitmapFont :: BitmapFont -> Word8 +fromBitmapFont Fixed8By13 = 0 :: Word8 +fromBitmapFont Fixed9By15 = 1 :: Word8 +fromBitmapFont TimesRoman10 = 2 :: Word8 +fromBitmapFont TimesRoman24 = 3 :: Word8 +fromBitmapFont Helvetica10 = 4 :: Word8 +fromBitmapFont Helvetica12 = 5 :: Word8 +fromBitmapFont Helvetica18 = 6 :: Word8 + +toBitmapFont :: Word8 -> BitmapFont +toBitmapFont 0 = Fixed8By13 +toBitmapFont 1 = Fixed9By15 +toBitmapFont 2 = TimesRoman10 +toBitmapFont 3 = TimesRoman24 +toBitmapFont 4 = Helvetica10 +toBitmapFont 5 = Helvetica12 +toBitmapFont 6 = Helvetica18 +toBitmapFont k = error $ "deserializing BitmapFont got bad value (" ++ show k ++ ")" + +instance B.Binary BitmapFont where + put = B.put . fromBitmapFont + get = fmap toBitmapFont B.get + + +fromColor :: GlossColor.Color -> (Float,Float,Float,Float) +fromColor = GlossColor.rgbaOfColor + +toColor :: (Float,Float,Float,Float) -> GlossColor.Color +toColor (r,g,b,a) = GlossColor.makeColor r g b a + +instance B.Binary (GlossColor.Color) where + put = B.put . fromColor + get = fmap toColor B.get + + +instance B.Binary a => B.Binary (VisObject a) + +setPerspectiveMode :: IO () +setPerspectiveMode = do + (_, Size w h) <- GLUT.get GLUT.viewport + GLUT.matrixMode $= Projection + GLUT.loadIdentity + GLUT.perspective 40 (fromIntegral w / fromIntegral h) 0.1 1000 + GLUT.matrixMode $= Modelview 0 + +drawObjects :: VisObject GLdouble -> IO () +drawObjects objects = do + setPerspectiveMode + drawObject objects + +drawObject :: VisObject GLdouble -> IO () +-- list of objects +drawObject (VisObjects xs) = mapM_ drawObject xs + +-- list of objects +drawObject (Trans (V3 x y z) visobj) = + GLUT.preservingMatrix $ do + GLUT.translate (Vector3 x y z :: Vector3 GLdouble) + drawObject visobj + +drawObject (RotQuat quat visobj) = drawObject (RotDcm (dcmOfQuat quat) visobj) + +drawObject (RotDcm (V3 (V3 m00 m01 m02) (V3 m10 m11 m12) (V3 m20 m21 m22)) visobject) = + GLUT.preservingMatrix $ do + mat <- GLUT.newMatrix GLUT.ColumnMajor + [ m00, m01, m02, 0 + , m10, m11, m12, 0 + , m20, m21, m22, 0 + , 0, 0, 0, 1 + ] + :: IO (GLUT.GLmatrix GLdouble) + GLUT.multMatrix mat + drawObject visobject + +drawObject (RotEulerRad euler visobj) = + drawObject $ RotEulerDeg (fmap ((180/pi)*) euler) visobj + +drawObject (RotEulerDeg (Euler yaw pitch roll) visobj) = + GLUT.preservingMatrix $ do + GLUT.rotate yaw (Vector3 0 0 1) + GLUT.rotate pitch (Vector3 0 1 0) + GLUT.rotate roll (Vector3 1 0 0) + drawObject visobj + +drawObject (Scale (sx,sy,sz) visobj) = + GLUT.preservingMatrix $ do + GLUT.normalize $= Enabled + GLUT.scale sx sy sz + drawObject visobj + GLUT.normalize $= Disabled + +-- triangle +drawObject (Triangle (V3 x0 y0 z0) (V3 x1 y1 z1) (V3 x2 y2 z2) col) = + GLUT.preservingMatrix $ do + setMaterialDiffuse col + setColor col + glBegin GL_TRIANGLES + glVertex3d x0 y0 z0 + glVertex3d x1 y1 z1 + glVertex3d x2 y2 z2 + glEnd + +-- quad +drawObject (Quad (V3 x0 y0 z0) (V3 x1 y1 z1) (V3 x2 y2 z2) (V3 x3 y3 z3) col) = + GLUT.preservingMatrix $ do + GLUT.lighting $= Disabled + setColor col + glBegin GL_QUADS + glVertex3d x0 y0 z0 + glVertex3d x1 y1 z1 + glVertex3d x2 y2 z2 + glVertex3d x3 y3 z3 + glEnd + GLUT.lighting $= Enabled + +-- cylinder +drawObject (Cylinder (height,radius) col) = + GLUT.preservingMatrix $ do + setMaterialDiffuse col + setColor col + + -- GLUT.translate (Vector3 0 0 (-height/2) :: Vector3 GLdouble) + + let nslices = 10 :: Int + nstacks = 10 :: Int + + -- Pre-computed circle + sinCosTable = map (\q -> (sin q, cos q)) angles + where + angle = 2*pi/(fromIntegral nslices) + angles = reverse $ map ((angle*) . fromIntegral) [0..(nslices+1)] + + -- Cover the base and top + glBegin GL_TRIANGLE_FAN + glNormal3d 0 0 (-1) + glVertex3d 0 0 0 + mapM_ (\(s,c) -> glVertex3d (c*radius) (s*radius) 0) sinCosTable + glEnd + + glBegin GL_TRIANGLE_FAN + glNormal3d 0 0 1 + glVertex3d 0 0 height + mapM_ (\(s,c) -> glVertex3d (c*radius) (s*radius) height) (reverse sinCosTable) + glEnd + + let -- Do the stacks + -- Step in z and radius as stacks are drawn. + zSteps = map (\k -> (fromIntegral k)*height/(fromIntegral nstacks)) [0..nstacks] + drawSlice z0 z1 (s,c) = do + glNormal3d c s 0 + glVertex3d (c*radius) (s*radius) z0 + glVertex3d (c*radius) (s*radius) z1 + + drawSlices (z0,z1) = do + glBegin GL_QUAD_STRIP + mapM_ (drawSlice z0 z1) sinCosTable + glEnd + + mapM_ drawSlices $ zip (init zSteps) (tail zSteps) + +-- sphere +drawObject (Sphere r flav col) = + GLUT.preservingMatrix $ do + setMaterialDiffuse col + setColor col + GLUT.renderObject flav (GLUT.Sphere' (realToFrac r) 20 20) + +-- ellipsoid +drawObject (Ellipsoid (sx,sy,sz) flav col) = drawObject $ Scale (sx,sy,sz) $ Sphere 1 flav col + +-- box +drawObject (Box (dx,dy,dz) flav col) = drawObject $ Scale (dx,dy,dz) $ Cube 1 flav col + +drawObject (Cube r flav col) = + GLUT.preservingMatrix $ do + setMaterialDiffuse col + setColor col + GLUT.renderObject flav (GLUT.Cube (realToFrac r)) + +-- line +drawObject (Line width path col) = + GLUT.preservingMatrix $ do + GLUT.lighting $= Disabled + setColor col + lineWidth0 <- GLUT.get GLUT.lineWidth + case width of + Just w -> GLUT.lineWidth $= realToFrac w + Nothing -> return () + + GLUT.renderPrimitive LineStrip $ mapM_ (\(V3 x' y' z') -> GLUT.vertex $ Vertex3 x' y' z') path + GLUT.lineWidth $= lineWidth0 + GLUT.lighting $= Enabled + +-- line where you set the color at each vertex +drawObject (Line' width pathcols) = + GLUT.preservingMatrix $ do + GLUT.lighting $= Disabled + + lineWidth0 <- GLUT.get GLUT.lineWidth + case width of + Just w -> GLUT.lineWidth $= realToFrac w + Nothing -> return () + + glBegin GL_LINE_STRIP + let f (xyz, col) = do + let V3 x y z = fmap realToFrac xyz + setMaterialDiffuse col + setColor col + glVertex3f x y z + mapM_ f pathcols + glEnd + GLUT.lineWidth $= lineWidth0 + GLUT.lighting $= Enabled + +-- plane +drawObject (Plane (V3 x y z) col1 col2) = + GLUT.preservingMatrix $ do + let normInv = 1/(sqrt $ x*x + y*y + z*z) + x' = x*normInv + y' = y*normInv + z' = z*normInv + r = 10 + n = 5 + eps = 0.01 + GLUT.rotate ((acos z')*180/pi :: GLdouble) (Vector3 (-y') x' 0) + + glBegin GL_QUADS + setColor col2 + + let r' = realToFrac r + glVertex3f r' r' 0 + glVertex3f (-r') r' 0 + glVertex3f (-r') (-r') 0 + glVertex3f r' (-r') 0 + glEnd + + glDisable GL_BLEND + let drawWithEps eps' = do + mapM_ drawObject $ concat [[ Line Nothing + [ V3 (-r) y0 eps' + , V3 r y0 eps' + ] col1 + , Line Nothing + [ V3 x0 (-r) eps', + V3 x0 r eps' + ] col1 + ] | x0 <- [-r,-r+r/n..r], y0 <- [-r,-r+r/n..r]] + drawWithEps eps + drawWithEps (-eps) + + glEnable GL_BLEND + + +-- arrow +drawObject (Arrow (size, aspectRatio) (V3 x y z) col) = + GLUT.preservingMatrix $ do + let numSlices = 8 + numStacks = 15 + cylinderRadius = 0.5*size/aspectRatio + cylinderHeight = size + coneRadius = 2*cylinderRadius + coneHeight = 2*coneRadius + + rotAngle = acos(z/(sqrt(x*x + y*y + z*z) + 1e-15))*180/pi :: GLdouble + rotAxis = Vector3 (-y) x 0 + + GLUT.rotate rotAngle rotAxis + + -- cylinder + drawObject $ Cylinder (cylinderHeight, cylinderRadius) col + -- cone + setMaterialDiffuse col + setColor col + GLUT.translate (Vector3 0 0 cylinderHeight :: Vector3 GLdouble) + GLUT.renderObject Solid (GLUT.Cone coneRadius coneHeight numSlices numStacks) + +drawObject (Axes (size, aspectRatio)) = GLUT.preservingMatrix $ do + let xAxis = Arrow (size, aspectRatio) (V3 1 0 0) (GlossColor.makeColor 1 0 0 1) + yAxis = Arrow (size, aspectRatio) (V3 0 1 0) (GlossColor.makeColor 0 1 0 1) + zAxis = Arrow (size, aspectRatio) (V3 0 0 1) (GlossColor.makeColor 0 0 1 1) + drawObject $ VisObjects [xAxis, yAxis, zAxis] + +drawObject (Text3d string (V3 x y z) font col) = GLUT.preservingMatrix $ do + GLUT.lighting $= Disabled + setColor col + glRasterPos3d x y z + GLUT.renderString font string + GLUT.lighting $= Enabled + +drawObject (Text2d string (x,y) font col) = GLUT.preservingMatrix $ do + GLUT.lighting $= Disabled + setColor col + + GLUT.matrixMode $= Projection + GLUT.loadIdentity + + (_, Size w h) <- GLUT.get GLUT.viewport + GLUT.ortho2D 0 (fromIntegral w) 0 (fromIntegral h) + GLUT.matrixMode $= Modelview 0 + GLUT.loadIdentity + + glRasterPos2d x y + GLUT.renderString font string + + setPerspectiveMode + GLUT.lighting $= Enabled + +drawObject (Vis.VisObject.Points xyzs ps col) = + GLUT.preservingMatrix $ do + GLUT.lighting $= Disabled + setColor col + s' <- GLUT.get GLUT.pointSize + when (isJust ps) $ GLUT.pointSize $= (fromJust ps) + GLUT.renderPrimitive GLUT.Points $ + mapM_ (\(V3 x' y' z') -> GLUT.vertex $ Vertex3 x' y' z') xyzs + GLUT.pointSize $= s' + GLUT.lighting $= Enabled + +drawObject (Vis.VisObject.ObjModel (LoadedObjModel vvec nvec numVerts) col) = + GLUT.preservingMatrix $ do + setMaterialDiffuse col + setColor col + + -- enable vertex/normal arrays + -- todo: Should this be done every time? + -- Either enable at the start, or push/pop to preserve user attributes + GL.clientState GL.VertexArray $= GL.Enabled + GL.clientState GL.NormalArray $= GL.Enabled + + -- set the vertex and normal arrays + let va = GL.VertexArrayDescriptor 3 GL.Double 0 + na = GL.VertexArrayDescriptor 3 GL.Double 0 + VS.unsafeWith vvec $ \vptr -> GL.arrayPointer GL.VertexArray $= va vptr + VS.unsafeWith nvec $ \nptr -> GL.arrayPointer GL.NormalArray $= na nptr + -- draw the triangles + GL.drawArrays GL.Triangles 0 (fromIntegral numVerts) + + -- disable vertex/normal arrays + GL.clientState GL.VertexArray $= GL.Disabled + GL.clientState GL.NormalArray $= GL.Disabled + +-- | turn a list of vertex/normal tuples into vertex/normal arrays +loadObjModel :: F.Foldable f => f (V3 Double, V3 Double) -> LoadedObjModel +loadObjModel vns = LoadedObjModel (VS.fromList vs) (VS.fromList ns) n + where + vs = F.concatMap (\(V3 x y z) -> [x,y,z]) vs' + ns = F.concatMap (\(V3 x y z) -> [x,y,z]) ns' + (vs',ns') = unzip $ F.toList vns + n = length vs'