-
Notifications
You must be signed in to change notification settings - Fork 0
/
Hier.hs
94 lines (84 loc) · 2.75 KB
/
Hier.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
-- Fishtank: 3D OpenGL demo with flocking boids
-- Author: Matthew Danish. License: BSD3 (see LICENSE file)
--
-- Hierarchical object construction: a tree of OpenGL commands with
-- quaternions and translations specified for each node. Compiles
-- into display lists for eventual display.
module Hier ( Hier(..), Compiled, drawCompiled, compileHier, makeHier
, getCompiledPart, drawCompiledPart, drawModifiedCompiled ) where
import Graphics.Rendering.OpenGL.GL
import Data.IORef ( IORef, newIORef )
import Util
import Data.Maybe
import Data.List ( lookup )
import Control.Monad
import qualified Data.Quaternion as Q
type Triple = (GLdouble, GLdouble, GLdouble)
data Hier a = H { hierDraw :: IO ()
, hierTrans :: Triple
, hierQuat :: Q.Quat GLdouble
, hierData :: a
, hierChildren :: [Hier a] }
newtype Compiled a =
C (DisplayList, IORef Triple, IORef (Q.Quat GLdouble), IORef a, [Compiled a])
drawCompiled (C (dl, r_t, r_q, _, cs)) =
preservingMatrix $ do
t <- get r_t
q <- get r_q
translated t
m <- newMatrix ColumnMajor (Q.rowMajorElems q) :: IO (GLmatrix GLdouble)
multMatrix m
callList dl
mapM_ drawCompiled cs
drawModifiedCompiled changes (C (dl, r_t, r_q, r_x, cs)) =
preservingMatrix $ do
t <- get r_t
q <- get r_q
x <- get r_x
translated t
let q' = case lookup x changes of
Just r -> r `Q.mul` q
Nothing -> q
m <- newMatrix ColumnMajor (Q.rowMajorElems q') :: IO (GLmatrix GLdouble)
multMatrix m
callList dl
mapM_ (drawModifiedCompiled changes) cs
drawCompiledPart a (C (dl, r_t, r_q, r_x, cs)) =
preservingMatrix $ do
t <- get r_t
q <- get r_q
translated t
m <- newMatrix ColumnMajor (Q.rowMajorElems q) :: IO (GLmatrix GLdouble)
multMatrix m
x <- get r_x
if x == a then callList dl else return ()
mapM_ (drawCompiledPart a) cs
makeHier draw t q dat cs =
H { hierDraw = draw
, hierTrans = t
, hierQuat = q
, hierData = dat
, hierChildren = cs }
compileHier (H { hierDraw = dr
, hierTrans = t
, hierQuat = q
, hierData = dat
, hierChildren = hs }) = do
cs <- mapM compileHier hs
dl <- defineNewList Compile dr
r_t <- newIORef t
r_q <- newIORef q
r_d <- newIORef dat
return $ C (dl, r_t, r_q, r_d, cs)
getCompiledPart a (c@(C (dl, r_t, r_q, r_x, cs))) = do
x <- get r_x
if x == a
then return (Just c)
else do
let loop [] = return Nothing
loop (c:cs) = do
m_c' <- getCompiledPart a c
case m_c' of
Just c' -> return (Just c')
Nothing -> loop cs
loop cs