diff options
-rw-r--r-- | Triangle.hs | 117 | ||||
-rw-r--r-- | UtilGL.hs | 138 | ||||
-rw-r--r-- | gix.hs | 31 |
3 files changed, 286 insertions, 0 deletions
diff --git a/Triangle.hs b/Triangle.hs new file mode 100644 index 0000000..cf26fe6 --- /dev/null +++ b/Triangle.hs | |||
@@ -0,0 +1,117 @@ | |||
1 | {-# LANGUAGE QuasiQuotes #-} | ||
2 | module Triangle where | ||
3 | |||
4 | import Graphics.Rendering.OpenGL as GL | ||
5 | import GI.Gtk as Gtk | ||
6 | import GI.Gdk.Objects | ||
7 | |||
8 | import Control.Concurrent | ||
9 | import Control.Monad | ||
10 | import Data.ByteString (ByteString) | ||
11 | import Foreign.Marshal (newArray) | ||
12 | import Foreign.Ptr | ||
13 | import Foreign.Storable | ||
14 | |||
15 | import UtilGL | ||
16 | |||
17 | fragment_source :: ByteString | ||
18 | fragment_source = [glslFragment| | ||
19 | #version 330 | ||
20 | in vec4 inputColor; | ||
21 | out vec4 outputColor; | ||
22 | void main() { | ||
23 | outputColor = vec4(1.0f, 0.0f, 0.0f, 0.0f); //constant red. I know it's a poor shader | ||
24 | } | ||
25 | |] | ||
26 | |||
27 | vertex_source :: ByteString | ||
28 | vertex_source = [glslVertex| | ||
29 | #version 330 | ||
30 | in vec4 position; | ||
31 | void main() { gl_Position = position; } | ||
32 | |] | ||
33 | |||
34 | data State = State | ||
35 | { stProgram :: Maybe Program | ||
36 | , stBuffer :: Maybe BufferObject | ||
37 | } | ||
38 | |||
39 | initState :: IO (MVar State) | ||
40 | initState = newMVar State | ||
41 | { stProgram = Nothing | ||
42 | , stBuffer = Nothing | ||
43 | } | ||
44 | |||
45 | drawTriangle :: MVar State -> IO () | ||
46 | drawTriangle svar = withMVar svar $ \st -> do | ||
47 | forM_ ((,) <$> stProgram st <*> stBuffer st) $ \(program,position_buffer) -> do | ||
48 | |||
49 | -- Use our shaders | ||
50 | GL.currentProgram $= Just program | ||
51 | |||
52 | -- Use the vertices in our buffer | ||
53 | GL.bindBuffer ArrayBuffer $= Just position_buffer | ||
54 | GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled | ||
55 | GL.vertexAttribPointer (GL.AttribLocation 0) $= (GL.ToFloat,VertexArrayDescriptor 4 GL.Float 0 nullPtr) | ||
56 | -- Draw the three vertices as a triangle | ||
57 | GL.drawArrays Triangles 0 3 | ||
58 | |||
59 | -- We finished using the buffers and program | ||
60 | GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Disabled | ||
61 | GL.bindBuffer ArrayBuffer $= Nothing | ||
62 | |||
63 | render :: MVar State -> GLArea -> GLContext -> IO Bool | ||
64 | render svar w gl = do | ||
65 | putStrLn "render!" | ||
66 | me <- gLAreaGetError w | ||
67 | maybe id (\e _ -> print e) me $ do | ||
68 | -- Clear the viewport | ||
69 | GL.clearColor $= GL.Color4 0 0 0 1 | ||
70 | GL.clear [ColorBuffer] | ||
71 | -- draw our object | ||
72 | drawTriangle svar | ||
73 | GL.flush | ||
74 | |||
75 | return True | ||
76 | |||
77 | realize :: MVar State -> GLArea -> IO () | ||
78 | realize svar w = do | ||
79 | putStrLn "realize!" | ||
80 | gLAreaMakeCurrent w | ||
81 | me <- gLAreaGetError w | ||
82 | maybe id (\e _ -> print e) me $ do | ||
83 | ctx <- gLAreaGetContext w | ||
84 | |||
85 | -- We only use one VAO, so we always keep it bound | ||
86 | vao <- GL.genObjectName | ||
87 | GL.bindVertexArrayObject $= Just vao | ||
88 | |||
89 | (vertex_data_sz,vertex_data) <- do | ||
90 | ptr <- newArray [ GL.Vertex4 0 0.5 0 1 | ||
91 | , GL.Vertex4 0.5 (-0.366) 0 1 | ||
92 | , GL.Vertex4 (-0.5) (-0.366) 0 1 | ||
93 | ] | ||
94 | return ( fromIntegral $ 3 * sizeOf (GL.Vertex4 0 0 0 (0 :: Float) ) | ||
95 | , ptr :: Ptr (GL.Vertex4 Float) ) | ||
96 | |||
97 | -- This is the buffer that holds the vertices | ||
98 | buffer <- GL.genObjectName | ||
99 | GL.bindBuffer ArrayBuffer $= Just buffer | ||
100 | GL.bufferData ArrayBuffer $= (vertex_data_sz, vertex_data, StaticDraw) | ||
101 | GL.bindBuffer ArrayBuffer $= Nothing | ||
102 | |||
103 | mfrag <- makeShader FragmentShader fragment_source | ||
104 | mvert <- makeShader VertexShader vertex_source | ||
105 | mprog <- makeProgram mfrag mvert | ||
106 | |||
107 | modifyMVar_ svar $ \_ -> return State | ||
108 | { stProgram = mprog | ||
109 | , stBuffer = Just buffer | ||
110 | } | ||
111 | |||
112 | return () | ||
113 | |||
114 | |||
115 | unrealize :: GLArea -> IO () | ||
116 | unrealize _ = do | ||
117 | putStrLn "unrealize!" | ||
diff --git a/UtilGL.hs b/UtilGL.hs new file mode 100644 index 0000000..22347c3 --- /dev/null +++ b/UtilGL.hs | |||
@@ -0,0 +1,138 @@ | |||
1 | {-# LANGUAGE QuasiQuotes #-} | ||
2 | module UtilGL where | ||
3 | |||
4 | import Control.Concurrent (threadDelay, yield) | ||
5 | import Control.Monad | ||
6 | import Data.Bool | ||
7 | import Data.ByteString (ByteString) | ||
8 | import Data.Maybe | ||
9 | import Data.IORef | ||
10 | import System.IO | ||
11 | import System.Directory | ||
12 | import System.Process | ||
13 | import System.Exit | ||
14 | import Graphics.Rendering.OpenGL as GL | ||
15 | import Language.Haskell.TH | ||
16 | import Language.Haskell.TH.Quote | ||
17 | import Text.Printf | ||
18 | |||
19 | data Env = Env | ||
20 | { mycolor :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat | ||
21 | } | ||
22 | |||
23 | |||
24 | cbDebugMessage :: GL.DebugMessage -> IO () | ||
25 | cbDebugMessage (DebugMessage src typ mid severity msg) = do | ||
26 | let src' = take 14 $ drop 11 $ show src ++ repeat ' ' | ||
27 | hPutStrLn stderr $ concat [src', ": ", msg] | ||
28 | |||
29 | notify :: String -> IO () | ||
30 | notify msg = do | ||
31 | cb <- get GL.debugMessageCallback | ||
32 | (maybe cbDebugMessage (const GL.debugMessageInsert) cb) | ||
33 | $ DebugMessage DebugSourceApplication DebugTypeMarker (DebugMessageID 0) DebugSeverityNotification msg | ||
34 | |||
35 | invertedColor4 :: Num a => a -> a -> a -> a -> Color4 a | ||
36 | invertedColor4 r g b a = Color4 (1-r) (1-g) (1-b) a | ||
37 | |||
38 | initGL :: IO Env | ||
39 | initGL = do | ||
40 | GL.debugOutput $=! Enabled | ||
41 | dbref <- newIORef Nothing | ||
42 | let setDebugMessageCallback _ = do | ||
43 | writeIORef dbref $ Just cbDebugMessage | ||
44 | hPutStrLn stderr "Application : Debug log enabled." | ||
45 | GL.debugMessageCallback $=! Just setDebugMessageCallback | ||
46 | GL.debugMessageInsert | ||
47 | $ DebugMessage DebugSourceApplication DebugTypeMarker (DebugMessageID 0) DebugSeverityNotification | ||
48 | "Debug log test: timeout." | ||
49 | stamp <- fmap (++ "/.config/inverted") getHomeDirectory | ||
50 | mycolor <- bool Color4 invertedColor4 <$> doesFileExist stamp | ||
51 | yield | ||
52 | threadDelay 10000 | ||
53 | dbc <- readIORef dbref | ||
54 | GL.debugMessageCallback $=! dbc | ||
55 | notify "Initialized." | ||
56 | return Env { mycolor = mycolor } | ||
57 | |||
58 | makeShader :: ShaderType -> ByteString -> IO (Maybe Shader) | ||
59 | makeShader typ src = do | ||
60 | shader <- GL.createShader typ | ||
61 | GL.shaderSourceBS shader $= src | ||
62 | GL.compileShader shader | ||
63 | stv <- get (GL.compileStatus shader) | ||
64 | nfo <- get (GL.shaderInfoLog shader) | ||
65 | when (not stv) $ hPutStrLn stderr nfo | ||
66 | return $ guard stv >> Just shader | ||
67 | |||
68 | makeProgram :: Maybe Shader -> Maybe Shader -> IO (Maybe Program) | ||
69 | makeProgram vshader fshader = mkP $ catMaybes [vshader,fshader] | ||
70 | where | ||
71 | mkP [vshader,fshader] = do | ||
72 | prog <- GL.createProgram | ||
73 | GL.attachShader prog vshader | ||
74 | GL.attachShader prog fshader | ||
75 | GL.linkProgram prog | ||
76 | stp <- get (GL.linkStatus prog) | ||
77 | nfo <- get(GL.programInfoLog prog) | ||
78 | when (not stp) $ hPutStrLn stderr nfo | ||
79 | return $ guard stp >> Just prog | ||
80 | mkP _ = return Nothing | ||
81 | |||
82 | |||
83 | |||
84 | unsupported :: Monad m => p -> m a | ||
85 | unsupported _ = fail "not supported." | ||
86 | |||
87 | qw :: QuasiQuoter | ||
88 | qw = QuasiQuoter f unsupported unsupported unsupported | ||
89 | where unsupported _ = fail "not supported." | ||
90 | f x = return $ ListE $ map (LitE . StringL) $ words x | ||
91 | |||
92 | str :: QuasiQuoter | ||
93 | str = QuasiQuoter { | ||
94 | quoteExp = stringE, | ||
95 | quotePat = unsupported, | ||
96 | quoteDec = unsupported, | ||
97 | quoteType = unsupported | ||
98 | } | ||
99 | |||
100 | glslVertex :: QuasiQuoter | ||
101 | glslVertex = QuasiQuoter glslE unsupported unsupported unsupported | ||
102 | where | ||
103 | glslE xs = do | ||
104 | let _packUtf8 = VarE $ mkName "packUtf8" | ||
105 | _string = LitE $ StringL xs | ||
106 | (code,e) <- runIO $ do | ||
107 | (gotvalidator,_,_) <- readCreateProcessWithExitCode (shell "which glslangValidator") "" | ||
108 | if gotvalidator == ExitSuccess | ||
109 | then do | ||
110 | writeFile "/tmp/glsl-shader.vert" xs | ||
111 | (code,out,err) <- readCreateProcessWithExitCode (shell "glslangValidator /tmp/glsl-shader.vert") "" | ||
112 | return $ (code, out ++ err ++ unlines (zipWith (\n s ->printf "%4d %s" n s ::String) ([1..]::[Int]) (lines xs))) | ||
113 | else | ||
114 | return (ExitSuccess, "") | ||
115 | when (code /= ExitSuccess) $ do | ||
116 | fail e | ||
117 | return $ AppE _packUtf8 _string | ||
118 | |||
119 | glslFragment :: QuasiQuoter | ||
120 | glslFragment = QuasiQuoter glslE unsupported unsupported unsupported | ||
121 | where | ||
122 | glslE xs = do | ||
123 | let _packUtf8 = VarE $ mkName "packUtf8" | ||
124 | _string = LitE $ StringL xs | ||
125 | (code,e) <- runIO $ do | ||
126 | (gotvalidator,_,_) <- readCreateProcessWithExitCode (shell "which glslangValidator") "" | ||
127 | if gotvalidator == ExitSuccess | ||
128 | then do | ||
129 | (pth,h) <-openTempFile "/tmp" "glsl.frag" | ||
130 | hPutStr h xs | ||
131 | hClose h | ||
132 | (code,out,err) <- readCreateProcessWithExitCode (shell $ "glslangValidator "++pth) "" | ||
133 | return $ (code, out ++ err ++ unlines (zipWith (\n s ->printf "%4d %s" n s ::String) ([1..]::[Int]) (lines xs))) | ||
134 | else | ||
135 | return (ExitSuccess, "") | ||
136 | when (code /= ExitSuccess) $ do | ||
137 | fail e | ||
138 | return $ AppE _packUtf8 _string | ||
@@ -0,0 +1,31 @@ | |||
1 | {-# LANGUAGE OverloadedLabels #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | module Main where | ||
4 | |||
5 | import GI.Gtk as Gtk hiding (main) | ||
6 | import qualified GI.Gtk as Gtk | ||
7 | |||
8 | import Triangle as R | ||
9 | |||
10 | |||
11 | main = do | ||
12 | _ <- Gtk.init Nothing | ||
13 | |||
14 | window <- windowNew WindowTypeToplevel | ||
15 | windowSetDefaultSize window 1000 1000 | ||
16 | windowSetTitle window "GL Area" | ||
17 | containerSetBorderWidth window 10 | ||
18 | |||
19 | gl_area <- gLAreaNew | ||
20 | containerAdd window gl_area | ||
21 | |||
22 | st <- R.initState | ||
23 | |||
24 | _ <- on gl_area #realize $ R.realize st gl_area | ||
25 | _ <- on gl_area #unrealize $ R.unrealize gl_area | ||
26 | _ <- on gl_area #render $ R.render st gl_area | ||
27 | |||
28 | _ <- on window #deleteEvent $ \_ -> mainQuit >> return True | ||
29 | widgetShowAll window | ||
30 | Gtk.main | ||
31 | |||