Two Triangles (garish)

src/IO.hs

@@ -0,0 +1,171 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module IO (Descriptor, openWindow, shutdownWindow, view) where
+
+-- IMPORTS --
+
+import qualified Data.ByteString as BS
+import qualified Graphics.Rendering.OpenGL as GL
+import Graphics.Rendering.OpenGL (($=))
+import qualified Graphics.UI.GLFW as GLFW
+
+import Control.Exception
+import Control.Monad
+import Foreign.Ptr
+import Foreign.Marshal.Array
+import Foreign.Storable
+
+import Relude
+import Model
+
+-- VIEW --
+
+view :: GLFW.Window -> Descriptor -> Model -> IO ()
+view window descriptor@(Descriptor vertices firstIndex numVertices) model = do
+  GL.clearColor $= GL.Color4 1 0 1 1
+  GL.clear [GL.ColorBuffer]
+  GL.bindVertexArrayObject $= Just vertices
+  GL.drawArrays GL.Triangles firstIndex numVertices
+  GLFW.swapBuffers window
+  GLFW.pollEvents
+
+-- SHADER DATA STRUCTURES --
+
+data Descriptor
+  = Descriptor
+      { vertexArray :: GL.VertexArrayObject
+      , firstindex :: GL.ArrayIndex
+      , numArrayIndicies :: GL.NumArrayIndices
+      }
+
+data ShaderInfo
+  = ShaderInfo
+      GL.ShaderType
+      ShaderSource
+  deriving (Eq, Ord, Show)
+
+data ShaderSource
+  = ByteStringSource BS.ByteString
+  | StringSource String
+  | FileSource FilePath
+  deriving (Eq, Ord, Show)
+
+-- INIT RENDERER --
+
+bufferOffset :: Integral a => a -> Ptr b
+bufferOffset integral = plusPtr nullPtr $ fromIntegral integral
+
+initResources :: IO Descriptor
+initResources = do
+  verticesGLArray <- GL.genObjectName
+  GL.bindVertexArrayObject $= Just verticesGLArray
+  let 
+    verticesArray =
+      [ GL.Vertex2 0.9 0.9
+      , GL.Vertex2 0.9 (-0.85)
+      , GL.Vertex2 (-0.85) 0.9
+      , GL.Vertex2 (-0.9) (-0.9)
+      , GL.Vertex2 (-0.9) 0.85
+      , GL.Vertex2 0.85 (-0.9)
+      ] :: [GL.Vertex2 GL.GLfloat]
+    numVertices = length verticesArray
+  arrayBuffer <- GL.genObjectName
+  GL.bindBuffer GL.ArrayBuffer $= Just arrayBuffer
+  withArray verticesArray $ \ptr -> do
+    let
+      size
+        = fromIntegral
+        $ (*)
+          numVertices
+          $ sizeOf
+            $ case viaNonEmpty head verticesArray of
+                Nothing -> (GL.Vertex2 0 0) :: (GL.Vertex2 GL.GLfloat)
+                Just a -> a
+    GL.bufferData GL.ArrayBuffer $= (size, ptr, GL.StaticDraw)
+  program <- loadShaders
+    [ ShaderInfo GL.VertexShader (FileSource "vert.glsl")
+    , ShaderInfo GL.FragmentShader (FileSource "frag.glsl")
+    ]
+  GL.currentProgram $= Just program
+  let
+    firstIndex = 0
+    vPosition = GL.AttribLocation 0
+  GL.vertexAttribPointer vPosition $=
+    (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 (bufferOffset firstIndex))
+  GL.vertexAttribArray vPosition $= GL.Enabled
+  return $ Descriptor verticesGLArray firstIndex $ fromIntegral numVertices
+
+-- LOAD SHADERS --
+
+getSource :: ShaderSource -> IO BS.ByteString
+getSource (ByteStringSource bs) = return bs
+getSource (StringSource str) = return $ GL.packUtf8 str
+getSource (FileSource path) = BS.readFile path
+
+loadShaders :: [ShaderInfo] -> IO GL.Program
+loadShaders infos =
+  GL.createProgram `bracketOnError` GL.deleteObjectName $ \program -> do
+    loadCompileAttach program infos
+    GL.linkProgram program
+    return program
+
+loadCompileAttach :: GL.Program -> [ShaderInfo] -> IO ()
+loadCompileAttach _ [] = return ()
+loadCompileAttach program (ShaderInfo shType source : infos) =
+  GL.createShader shType `bracketOnError` GL.deleteObjectName $ \shader -> do
+    src <- getSource source
+    GL.shaderSourceBS shader $= src
+    GL.compileShader shader
+    GL.attachShader program shader
+    loadCompileAttach program infos
+
+-- INPUT --
+
+keyPressed :: GLFW.KeyCallback
+keyPressed window GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = shutdownWindow window
+keyPressed _ _ _ _ _ = return ()
+
+-- WINDOW --
+
+openWindow :: String -> IO (GLFW.Window, Descriptor)
+openWindow
+  title
+  = do
+    GLFW.init
+    GLFW.defaultWindowHints
+    GLFW.windowHint (GLFW.WindowHint'ContextVersionMajor 4)
+    GLFW.windowHint (GLFW.WindowHint'ContextVersionMinor 5)
+    GLFW.windowHint (GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core)
+    monitor <- GLFW.getPrimaryMonitor
+
+    -- get an error n ur cooked. TODO graceful failure here
+    Just window <- GLFW.createWindow 256 256 title monitor Nothing
+
+    GLFW.makeContextCurrent (Just window)
+    GLFW.setWindowCloseCallback window (Just shutdownWindow)
+    GLFW.setWindowSizeCallback window (Just resizeWindow)
+    GLFW.setKeyCallback window (Just keyPressed)
+    descriptor <- initResources
+    return (window, descriptor)
+
+shutdownWindow :: GLFW.WindowCloseCallback
+shutdownWindow window =
+  do
+    closeWindow window
+    _ <- exitSuccess
+    return ()
+
+resizeWindow :: GLFW.WindowSizeCallback
+resizeWindow _ w h =
+  do
+    GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
+    GL.matrixMode $= GL.Projection
+    GL.loadIdentity
+    GL.ortho2D 0 (realToFrac w) (realToFrac h) 0
+
+closeWindow :: GLFW.Window -> IO ()
+closeWindow window =
+  do
+    GLFW.destroyWindow window
+    GLFW.terminate

src/Main.hs

@@ -1,79 +1,35 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Main (main) where
 
 -- IMPORTS --
 
-import Graphics.Rendering.OpenGL as GL
-import Graphics.UI.GLFW as GLFW
+import Graphics.UI.GLFW (Window)
+import IO (Descriptor, openWindow, view)
+import Model (Model, model)
 import Relude
 import Relude.Monad (forever)
+import Update (update)
 
 -- MAIN --
 
 main :: IO ()
-main = do
-  putStrLn "haskengl 2025 Andromeda; WTFPL"
-  window <- openWindow "window :)"
-  onPaint window
-  closeWindow window
-  return ()
-
--- EVENTS --
-
-keyPressed :: GLFW.KeyCallback
-keyPressed window GLFW.Key'Escape _ GLFW.KeyState'Pressed _ = shutdownWindow window
-keyPressed _ _ _ _ _ = return ()
-
--- PAINT --
-
-onPaint :: GLFW.Window -> IO ()
-onPaint window =
+main =
   do
-    GL.clearColor $= Color4 1 0 1 1
-    GL.clear [ColorBuffer]
-    GLFW.swapBuffers window
-    forever $ do
-      GLFW.pollEvents
-      onPaint window
-
--- WINDOW --
-
-openWindow :: String -> IO GLFW.Window
-openWindow
-  title
-  = do
-    GLFW.init
-    GLFW.defaultWindowHints
-    GLFW.windowHint (GLFW.WindowHint'ContextVersionMajor 4)
-    GLFW.windowHint (GLFW.WindowHint'ContextVersionMinor 5)
-    GLFW.windowHint (GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core)
-    monitor <- GLFW.getPrimaryMonitor
-    Just window <- GLFW.createWindow 256 256 title monitor Nothing -- get an error n ur cooked. TODO graceful failure here
-    GLFW.makeContextCurrent (Just window)
-    GLFW.maximizeWindow window
-    GLFW.setWindowCloseCallback window (Just shutdownWindow)
-    GLFW.setWindowSizeCallback window (Just resizeWindow)
-    GLFW.setKeyCallback window (Just keyPressed)
-    return window
-
-shutdownWindow :: GLFW.WindowCloseCallback
-shutdownWindow window =
-  do
-    closeWindow window
-    _ <- exitSuccess
+    (window, descriptor) <- openWindow "window :)"
+    putTextLn "has window"
+    _ <- loop window descriptor update view model
     return ()
 
-resizeWindow :: GLFW.WindowSizeCallback
-resizeWindow _ w h =
+loop
+  :: Window
+  -> Descriptor
+  -> (Model -> Model)
+  -> (Window -> Descriptor -> Model -> IO ())
+  -> Model -> IO Model
+loop window descriptor update view model =
   do
-    GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
-    GL.matrixMode $= GL.Projection
-    GL.loadIdentity
-    GL.ortho2D 0 (realToFrac w) (realToFrac h) 0
-
-closeWindow :: GLFW.Window -> IO ()
-closeWindow window =
-  do
-    GLFW.destroyWindow window
-    GLFW.terminate
+    let model = update model
+    view window descriptor model
+    loop window descriptor update view model

src/Model.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model (Model, model) where
+
+-- IMPORTS --
+
+import Relude
+
+-- TYPES --
+
+data Model = Model
+               { counter :: Integer
+               }
+
+-- DEFAULTS --
+model = Model
+          { counter = 0
+          }

src/Update.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Update (update) where
+
+-- IMPORTS --
+
+import Model
+import Relude
+
+-- UPDATE --
+
+update :: Model -> Model
+update model =
+  model