OpenGL 2.1 compatibility
[maximus:butterflies.git] / flat / Main.hs
1 {-# LANGUAGE TypeSynonymInstances #-}
2 module Main (main) where
3
4 import Control.Monad (when)
5 import Foreign (Ptr, nullPtr, castPtr, plusPtr, advancePtr, allocaBytes, with, withArray, peek, poke, pokeByteOff)
6 import Foreign.C (CUChar)
7 import Foreign.C.String (withCString, peekCString)
8 import Foreign.ForeignPtr (withForeignPtr)
9 import System.Exit (exitSuccess)
10
11 import Graphics.Rendering.OpenGL.Raw.Core21
12 import Graphics.Rendering.OpenGL.Raw.ARB.ShaderObjects (glUniformMatrix4fv)
13 import Graphics.Rendering.OpenGL.Raw.ARB.FramebufferObject (glGenerateMipmap)
14 import Graphics.Rendering.OpenGL.Capture (capturePPM)
15 import Graphics.UI.GLUT (getArgsAndInitialize, createWindow, displayCallback, ($=), swapBuffers, reportErrors, mainLoop)
16 import qualified Data.ByteString as BS
17 import Data.Array.Repa.IO.DevIL (runIL, readImage, Image(RGBA))
18 import Data.Array.Repa.Repr.ForeignPtr (toForeignPtr)
19
20 import Paths_butterflies (getDataFileName)
21
22 import Geometry.Flat.TwoD.Space
23 import Geometry.Flat.TwoD.Tessellation.Triangular
24
25 swarm' p q = tessellate p q 3 (Point (-12) (-12)) (Point 12 12)
26
27 class GLPoke t where glPoke :: t -> Ptr t -> IO (Ptr t)
28 instance GLPoke t => GLPoke [t] where
29   glPoke [] p = return p
30   glPoke (x:xs) p = glPoke x (castPtr p) >>= glPoke xs . castPtr
31
32 instance GLPoke GLfloat where glPoke x p = poke p x >> return (advancePtr p 1)
33 instance GLPoke Double where
34   glPoke x p = do
35     p <- glPoke (realToFrac x :: GLfloat) (castPtr p)
36     return (castPtr p)
37 instance GLPoke Point where
38   glPoke (Point x y) p = do
39     p <- glPoke x (castPtr p)
40     p <- glPoke y p
41     return (castPtr p)
42 instance GLPoke Vertex where
43   glPoke (Vertex vp vt h0 h1 h2) p = do
44     p <- glPoke [vp, vt] (castPtr p)
45     p <- glPoke [h0, h1, h2] (castPtr p)
46     return (castPtr p)
47 instance GLPoke a => GLPoke (Triangle a) where
48   glPoke (Triangle a b c) p = do
49     p <- glPoke [a,b,c] (castPtr p)
50     return (castPtr p)
51
52 vert = unlines
53   [ "#version 120"
54   , "uniform mat4 mvp;"
55   , "attribute vec2 p0;"
56   , "attribute vec2 t0;"
57   , "attribute vec3 c0;"
58   , "varying vec2 t;"
59   , "flat varying vec3 c;"
60   , "void main() {"
61   , "  gl_Position = vec4(vec2(vec4(p0, 0.0, 1.0) * mvp), 0.0, 1.0);"
62   , "  t = t0;"
63   , "  c = c0;"
64   , "}"
65   ]
66
67 frag = unlines
68   [ "#version 120"
69   , "uniform sampler2D tex;"
70   , "uniform sampler1D pal;"
71   , "varying vec2 t;"
72   , "flat varying vec3 c;"
73   , "const float phi1 = (sqrt(5.0) - 1.0) / 2.0;"
74   , "const float phi2 = (sqrt(5.0) - 2.0) / 2.0;"
75   , "vec4 colour(float i) {"
76   , "  float j = 1.0/6.0 - phi1 * i;"
77   , "  float k = phi2 * i;"
78   , "  j -= floor(j);"
79   , "  k -= floor(k);"
80   , "  k *= -0.5;"
81   , "  k +=  1.0;"
82   , "  return vec4(texture1D(pal, j).rgb * k, 1.0);"
83   , "}"
84   , "void main() {"
85   , "  vec4 w = texture2D(tex, t);"
86   , "  vec4 f = vec4(0.0);"
87   , "  if (w.a < 0.5) {"
88   , "    f = vec4(0.5, 0.5, 0.5, 1.0);"
89   , "  } else if (w.r > 0.5 && w.g > 0.5 && w.b > 0.5) {"
90   , "    f = vec4(1.0, 1.0, 1.0, 1.0);"
91   , "  } else if (w.r > 0.5) {"
92   , "    f = colour(c.r);"
93   , "  } else if (w.g > 0.5) {"
94   , "    f = colour(c.g);"
95   , "  } else if (w.b > 0.5) {"
96   , "    f = colour(c.b);"
97   , "  } else {"
98   , "    f = vec4(0.0, 0.0, 0.0, 1.0);"
99   , "  }"
100   , "  gl_FragColor = f;"
101   , "}"
102   ]
103
104 main = do
105   (_, [sp, sq]) <- getArgsAndInitialize
106   _ <- createWindow "butterflies"
107   program <- compileProgram
108   glUseProgram program
109   loadTextures
110   let ip = read sp
111       iq = read sq
112       swarm = swarm' ip iq
113       count = length swarm * 3
114       stride = 4 * (2 + 2 + 3)
115       bytes = count * fromIntegral stride
116   allocaBytes bytes $ \p -> do
117     glPoke swarm p
118     vbo <- with 0 $ \q -> glGenBuffers 1 q >> peek q
119     glBindBuffer gl_ARRAY_BUFFER vbo
120     glBufferData gl_ARRAY_BUFFER (fromIntegral bytes) p gl_STATIC_DRAW
121     att <- withCString "p0" $ glGetAttribLocation program
122     glVertexAttribPointer (fromIntegral att) 2 gl_FLOAT (fromIntegral gl_FALSE) stride (plusPtr nullPtr 0)
123     glEnableVertexAttribArray (fromIntegral att)
124     att <- withCString "t0" $ glGetAttribLocation program
125     glVertexAttribPointer (fromIntegral att) 2 gl_FLOAT (fromIntegral gl_FALSE) stride (plusPtr nullPtr (2 * 4))
126     glEnableVertexAttribArray (fromIntegral att)
127     att <- withCString "c0" $ glGetAttribLocation program
128     glVertexAttribPointer (fromIntegral att) 3 gl_FLOAT (fromIntegral gl_FALSE) stride (plusPtr nullPtr (4 * 4))
129     glEnableVertexAttribArray (fromIntegral att)
130   let s = 10
131       l = -s
132       r = s
133       t = -s
134       b = s
135       n = -1
136       f = 1
137       ortho = [ 2 / (r - l), 0, 0, -(r + l) / (r - l)
138               , 0, 2 / (t - b), 0, -(t + b) / (t - b)
139               , 0, 0, 2 / (f - n), -(f + n) / (f - n)
140               , 0, 0, 0, 1 ]
141   withArray ortho $ \p -> do
142     loc <- withCString "mvp" $ glGetUniformLocation program
143     glUniformMatrix4fv loc 1 (fromIntegral gl_FALSE) p
144   loc <- withCString "tex" $ glGetUniformLocation program
145   glUniform1i loc 0
146   loc <- withCString "pal" $ glGetUniformLocation program
147   glUniform1i loc 1
148   glClearColor 0.5 0.5 0.5 1
149   displayCallback $= do
150     glClear gl_COLOR_BUFFER_BIT
151     glDrawArrays gl_TRIANGLES 0 (fromIntegral count)
152     swapBuffers
153     capturePPM >>= BS.writeFile (show (ip * ip + iq * iq + ip * iq) ++ "-" ++ show ip ++ "-" ++ show iq ++ ".ppm")
154     reportErrors
155     exitSuccess
156   mainLoop
157
158 loadTextures = do
159   RGBA img <- getDataFileName "butterfly.png" >>= runIL . readImage
160   withForeignPtr (toForeignPtr img) $ \p -> do
161     tex <- with 0 $ \q -> glGenTextures 1 q >> peek q
162     glBindTexture gl_TEXTURE_2D tex
163     glTexImage2D gl_TEXTURE_2D 0 (fromIntegral gl_RGBA) 1024 1024 0 gl_RGBA gl_UNSIGNED_BYTE p
164     glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER (fromIntegral gl_LINEAR_MIPMAP_LINEAR)
165     glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER (fromIntegral gl_LINEAR)
166     glGenerateMipmap gl_TEXTURE_2D
167   glActiveTexture gl_TEXTURE1
168   RGBA img <- getDataFileName "palette.png" >>= runIL . readImage
169   withForeignPtr (toForeignPtr img) $ \p -> do
170     tex <- with 0 $ \q -> glGenTextures 1 q >> peek q
171     glBindTexture gl_TEXTURE_1D tex
172     glTexImage1D gl_TEXTURE_1D 0 (fromIntegral gl_RGBA) 256 0 gl_RGBA gl_UNSIGNED_BYTE p
173     glTexParameteri gl_TEXTURE_1D gl_TEXTURE_MIN_FILTER (fromIntegral gl_LINEAR_MIPMAP_LINEAR)
174     glTexParameteri gl_TEXTURE_1D gl_TEXTURE_MAG_FILTER (fromIntegral gl_LINEAR)
175     glGenerateMipmap gl_TEXTURE_1D
176
177 compileProgram = do
178   program <- glCreateProgram
179   compileShader program gl_VERTEX_SHADER vert
180   compileShader program gl_FRAGMENT_SHADER frag
181   glLinkProgram program
182   debugProgram program
183   return program
184
185 compileShader program t src = do
186   shader <- glCreateShader t
187   withCString src $ \srcp -> with srcp $ \srcpp -> glShaderSource shader 1 srcpp nullPtr
188   glCompileShader shader
189   glAttachShader program shader
190   glDeleteShader shader
191
192 debugProgram program = do
193   if program /= 0
194     then do
195       linked <- with 0 $ \p -> glGetProgramiv program gl_LINK_STATUS p >> peek p
196       when (linked /= fromIntegral gl_TRUE) $ putStrLn "link failed"
197       len <- with 0 $ \p -> glGetProgramiv program gl_INFO_LOG_LENGTH p >> peek p
198       when (len > 1) $ do
199         allocaBytes (fromIntegral len + 1) $ \p -> glGetProgramInfoLog program len nullPtr p >> pokeByteOff p (fromIntegral len) (0 :: CUChar) >> peekCString p >>= putStrLn
200     else putStrLn "no program"