-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy pathlesson12.hs
187 lines (172 loc) · 7.1 KB
/
lesson12.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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
--
-- This code was created by Jeff Molofee '99 (ported to Haskell GHC 2005)
--
module Main where
import qualified Graphics.UI.GLFW as GLFW
-- everything from here starts with gl or GL
import Graphics.Rendering.OpenGL.Raw
import Graphics.Rendering.GLU.Raw ( gluPerspective )
import Data.Bits ( (.|.) )
import System.Exit ( exitWith, ExitCode(..) )
import Control.Monad ( forever, forM_ )
import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )
import Foreign ( withForeignPtr, plusPtr, alloca, peek )
import qualified Data.ByteString.Internal as BSI
import Util ( Image(..), bitmapLoad )
import Paths_nehe_tuts
boxcol :: [(GLfloat, GLfloat, GLfloat)]
boxcol = [(1, 0, 0), (1, 0.5, 0), (1, 1, 0),
(0, 1, 0), (0, 1, 1)]
topcol :: [(GLfloat, GLfloat, GLfloat)]
topcol = [(0.5, 0, 0), (0.5, 0.25, 0), (0.5, 0.5, 0),
(0, 0.5, 0), (0, 0.5, 0.5)]
buildLists :: IO (GLuint, GLuint)
buildLists = do
box <- glGenLists 2
glNewList box gl_COMPILE
glBegin gl_QUADS
glTexCoord2f 1 1 >> glVertex3f (-1) (-1) (-1) -- Top Right Of The Texture and Quad
glTexCoord2f 0.0 1.0 >> glVertex3f 1.0 (-1.0) (-1.0) -- Top Left Of The Texture and Quad
glTexCoord2f 0.0 0.0 >> glVertex3f 1.0 (-1.0) 1.0 -- Bottom Left Of The Texture and Quad
glTexCoord2f 1.0 0.0 >> glVertex3f (-1.0) (-1.0) 1.0 -- Bottom Right Of The Texture and Quad
-- Front Face
glTexCoord2f 0.0 0.0 >> glVertex3f (-1.0) (-1.0) 1.0 -- Bottom Left Of The Texture and Quad
glTexCoord2f 1.0 0.0 >> glVertex3f 1.0 (-1.0) 1.0 -- Bottom Right Of The Texture and Quad
glTexCoord2f 1.0 1.0 >> glVertex3f 1.0 1.0 1.0 -- Top Right Of The Texture and Quad
glTexCoord2f 0.0 1.0 >> glVertex3f (-1.0) 1.0 1.0 -- Top Left Of The Texture and Quad
-- Back Face
glTexCoord2f 1.0 0.0 >> glVertex3f (-1.0) (-1.0) (-1.0) -- Bottom Right Of The Texture and Quad
glTexCoord2f 1.0 1.0 >> glVertex3f (-1.0) 1.0 (-1.0) -- Top Right Of The Texture and Quad
glTexCoord2f 0.0 1.0 >> glVertex3f 1.0 1.0 (-1.0) -- Top Left Of The Texture and Quad
glTexCoord2f 0.0 0.0 >> glVertex3f 1.0 (-1.0) (-1.0) -- Bottom Left Of The Texture and Quad
-- Right face
glTexCoord2f 1.0 0.0 >> glVertex3f 1.0 (-1.0) (-1.0) -- Bottom Right Of The Texture and Quad
glTexCoord2f 1.0 1.0 >> glVertex3f 1.0 1.0 (-1.0) -- Top Right Of The Texture and Quad
glTexCoord2f 0.0 1.0 >> glVertex3f 1.0 1.0 1.0 -- Top Left Of The Texture and Quad
glTexCoord2f 0.0 0.0 >> glVertex3f 1.0 (-1.0) 1.0 -- Bottom Left Of The Texture and Quad
-- Left Face
glTexCoord2f 0.0 0.0 >> glVertex3f (-1.0) (-1.0) (-1.0) -- Bottom Left Of The Texture and Quad
glTexCoord2f 1.0 0.0 >> glVertex3f (-1.0) (-1.0) 1.0 -- Bottom Right Of The Texture and Quad
glTexCoord2f 1.0 1.0 >> glVertex3f (-1.0) 1.0 1.0 -- Top Right Of The Texture and Quad
glTexCoord2f 0.0 1.0 >> glVertex3f (-1.0) 1.0 (-1.0) -- Top Left Of The Texture and Quad
glEndList
let top = box + 1
glNewList top gl_COMPILE
glBegin gl_QUADS
glTexCoord2f 0 1 >> glVertex3f (-1) 1 (-1)
glTexCoord2f 0 0 >> glVertex3f (-1) 1 1
glTexCoord2f 1 0 >> glVertex3f 1 1 1
glTexCoord2f 1 1 >> glVertex3f 1 1 (-1)
glEnd
glEndList
return (box, top)
initGL :: GLFW.Window -> IO GLuint
initGL win = do
tex <- loadTextures
glEnable gl_TEXTURE_2D
glShadeModel gl_SMOOTH
glClearColor 0 0 0 0.5
glClearDepth 1
glEnable gl_DEPTH_TEST
glEnable gl_LEQUAL
glEnable gl_LIGHT0
glEnable gl_LIGHTING
glEnable gl_COLOR_MATERIAL
glHint gl_PERSPECTIVE_CORRECTION_HINT gl_NICEST
(w,h) <- GLFW.getFramebufferSize win
resizeScene win w h
return tex
loadTextures :: IO GLuint
loadTextures = do
fp <- getDataFileName "cube.bmp"
Just (Image w h pd) <- bitmapLoad fp
putStrLn $ "Image w = " ++ show w
putStrLn $ "Image h = " ++ show h
tex <- alloca $ \p -> do
glGenTextures 1 p
peek p
let (ptr, off, _) = BSI.toForeignPtr pd
_ <- withForeignPtr ptr $ \p -> do
let p' = p `plusPtr` off
glNearest = fromIntegral gl_NEAREST
-- create linear filtered texture
glBindTexture gl_TEXTURE_2D tex
glTexImage2D gl_TEXTURE_2D 0 3
(fromIntegral w) (fromIntegral h)
0 gl_RGB gl_UNSIGNED_BYTE p'
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER glNearest
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER glNearest
return tex
shutdown :: GLFW.WindowCloseCallback
shutdown win = do
GLFW.destroyWindow win
GLFW.terminate
_ <- exitWith ExitSuccess
return ()
resizeScene :: GLFW.WindowSizeCallback
resizeScene win w 0 = resizeScene win w 1 -- prevent divide by zero
resizeScene _ width height = do
glViewport 0 0 (fromIntegral width) (fromIntegral height)
glMatrixMode gl_PROJECTION
glLoadIdentity
gluPerspective 45 (fromIntegral width/fromIntegral height) 0.1 100
glMatrixMode gl_MODELVIEW
glLoadIdentity
glFlush
drawScene :: GLuint -> IORef GLfloat -> IORef GLfloat
-> GLuint -> GLuint -> GLFW.Window -> IO ()
drawScene tex xrot yrot box top _ = do
glClear $ fromIntegral $ gl_COLOR_BUFFER_BIT
.|. gl_DEPTH_BUFFER_BIT
glBindTexture gl_TEXTURE_2D tex
xr <- readIORef xrot
yr <- readIORef yrot
forM_ [(x,y) | y <- [1..5], x <- [0..y-1] ] $ \(x,y) -> do
glLoadIdentity
let x' = fromIntegral x
y' = fromIntegral y
color (r,g,b) = glColor3f r g b
glTranslatef (1.4+x'*2.8-y'*1.4) (((6-y')*2.4)-7) (-20)
glRotatef (45.0-(2.0*y')+xr) 1 0 0
glRotatef (45-yr) 0 1 0
color (boxcol !! (y-1))
glCallList box
color (topcol !! (y-1))
glCallList top
glFlush
keyPressed :: IORef GLfloat -> IORef GLfloat -> GLFW.KeyCallback
keyPressed _ _ win GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = shutdown win
keyPressed xrot _ _ GLFW.Key'Up _ GLFW.KeyState'Pressed _ = modifyIORef xrot (subtract 0.8)
keyPressed xrot _ _ GLFW.Key'Down _ GLFW.KeyState'Pressed _ = modifyIORef xrot (+0.8)
keyPressed _ yrot _ GLFW.Key'Left _ GLFW.KeyState'Pressed _ = modifyIORef yrot (subtract 0.8)
keyPressed _ yrot _ GLFW.Key'Right _ GLFW.KeyState'Pressed _ = modifyIORef yrot (+0.8)
keyPressed _ _ _ _ _ _ _ = return ()
main :: IO ()
main = do
True <- GLFW.init
-- select type of display mode:
-- Double buffer
-- RGBA color
-- Alpha components supported
-- Depth buffer
GLFW.defaultWindowHints
-- open a window
Just win <- GLFW.createWindow 800 600 "Lesson 12" Nothing Nothing
GLFW.makeContextCurrent (Just win)
xrot <- newIORef 0
yrot <- newIORef 0
-- initialize our window.
tex <- initGL win
(box, top) <- buildLists
GLFW.setWindowRefreshCallback win $
Just (drawScene tex xrot yrot box top)
GLFW.setFramebufferSizeCallback win (Just resizeScene)
-- register the function called when the keyboard is pressed.
GLFW.setKeyCallback win $
Just (keyPressed xrot yrot)
GLFW.setWindowCloseCallback win (Just shutdown)
-- GLFW.getWindowRefreshRate >>= print
forever $ do
GLFW.pollEvents
drawScene tex xrot yrot box top win
GLFW.swapBuffers win