technically works: Perspective, matrices, other fun stuff

2025-12-02 19:35:44 +01:00
parent ed61ff3868
commit d5719e36ba
13 changed files with 226 additions and 112 deletions
--- a/src/Haskengl/IO.hs
+++ b/src/Haskengl/IO.hs
@@ -1,69 +1,86 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

-module IO (openWindow, shutdownWindow, view) where
+module Haskengl.IO (openWindow, shutdownWindow, view) where

 -- IMPORTS --

 import qualified Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL (($=))
-import qualified Graphics.UI.GLFW as GLFW
-import qualified Language.GLSL as GLSL
+import           Graphics.Rendering.OpenGL (($=))
+import qualified Graphics.UI.GLFW          as GLFW
+import qualified Language.GLSL             as GLSL
+import qualified Linear                    as L
+import Linear.V4 (V4(..))

 import Control.Exception
 import Control.Monad
-import Data.Text (unpack)
+import Data.Text             (unpack)
 import Foreign.Ptr
 import Foreign.Marshal.Array
 import Foreign.Storable

-import LoadShaders
 import Relude
-import Shaders
-import Types
+
+import Haskengl.IO.Shaders.LoadShaders
+import Haskengl.IO.Shaders.Shaders
+import Haskengl.Types
+import Haskengl.Math.Transforms

 -- VIEW --

 backgroundColor :: GL.Color4 GL.GLfloat
-backgroundColor = GL.Color4 0 0 0 1
+backgroundColor = GL.Color4 1 0 1 1

 view :: GLFW.Window -> DisplayableObjects -> Model -> IO ()
 view window objects model = do
  GL.clearColor $= backgroundColor
  GL.clear [GL.ColorBuffer]
-  displayObjects window objects
+  displayObjects objects
  GLFW.swapBuffers window
  GLFW.pollEvents

 -- SHADER STUFF --

-displayObjects :: GLFW.Window -> DisplayableObjects -> IO (DisplayableObjects)
-displayObjects _ [] = return []
-displayObjects window ((DisplayableObject vao numVertices _ primitiveMode):objects) = do
+projection :: L.M44 GL.GLfloat
+projection = L.perspective (45 * 3.141592653 / 180) 1 0.1 100
+
+displayObjects :: DisplayableObjects -> IO (DisplayableObjects)
+displayObjects [] = return []
+displayObjects ((DisplayableObject vao _ numVertices _ primitiveMode):objects) = do
  GL.bindVertexArrayObject $= Just vao
  GL.drawArrays primitiveMode 0 numVertices
-  displayObjects window objects
+  displayObjects objects

 -- INIT RENDERER --

 bufferOffset :: Integral a => a -> Ptr b
 bufferOffset integral = plusPtr nullPtr $ fromIntegral integral

-verticesArray :: [GL.Vertex2 GL.GLfloat]
+toGLMatrix :: L.M44 GL.GLfloat -> [GL.GLfloat]
+toGLMatrix (V4 (V4 c00 c01 c02 c03)
+                  (V4 c10 c11 c12 c13)
+                  (V4 c20 c21 c22 c23)
+                  (V4 c30 c31 c32 c33)) =
+  [ c00, c01, c02, c03
+  , c10, c11, c12, c13
+  , c20, c21, c22, c23
+  , c30, c31, c32, c33
+  ]
+
+verticesArray :: [GL.Vertex3 GL.GLfloat]
 verticesArray =
-  [ GL.Vertex2 0.9 0.9
-  , GL.Vertex2 0.5 0.9
-  , GL.Vertex2 0.9 0.5
-  , GL.Vertex2 0.5 0.5
-  , GL.Vertex2 0.9 0.0
-  , GL.Vertex2 0.5 0.0
+  [ GL.Vertex3 0.3    0.3    0.5
+  , GL.Vertex3 (-0.3) 0.3    0
+  , GL.Vertex3 0.3    (-0.3) 0
+  , GL.Vertex3 (-0.3) (-0.3) (-0.5)
  ]

 testArray :: [GL.Vertex3 GL.GLfloat]
 testArray =
-  [ GL.Vertex3 0.5 1 0.5
-  , GL.Vertex3 (-0.5) (-0.5) (-0.5)
-  , GL.Vertex3 0 0 0
+  [ GL.Vertex3 1.5 1.5 0
+  , GL.Vertex3 0.5 1.5 0
+  , GL.Vertex3 1.5 0.5 0
+  , GL.Vertex3 0.5 0.5 0
  ]

 generateRGBA :: Int -> [GL.Color4 GL.GLfloat]
@@ -81,7 +98,7 @@ sizeOfArray :: (Storable a, Num b) => [a] -> b
 sizeOfArray [] = 0
 sizeOfArray (x:xs) = fromIntegral $ (*) ( 1 + length xs) $ sizeOf x

-createVBO :: Storable (a GL.GLfloat) => [a GL.GLfloat] -> GL.NumComponents -> GL.AttribLocation -> IO GL.BufferObject
+createVBO :: (Storable (a GL.GLfloat), Vertex (a GL.GLfloat)) => [a GL.GLfloat] -> GL.NumComponents -> GL.AttribLocation -> IO GL.BufferObject
 createVBO array numComponents attribLocation = do
  buffer <- GL.genObjectName
  GL.bindBuffer GL.ArrayBuffer $= Just buffer
@@ -100,7 +117,7 @@ createVBO array numComponents attribLocation = do
  GL.vertexAttribArray attribLocation $= GL.Enabled
  return buffer

-createDisplayableObject :: Storable (a GL.GLfloat) => [a GL.GLfloat] -> GL.NumComponents -> GL.PrimitiveMode -> IO DisplayableObject
+createDisplayableObject :: (Storable (a GL.GLfloat), Vertex (a GL.GLfloat)) => [a GL.GLfloat] -> GL.NumComponents -> GL.PrimitiveMode -> IO DisplayableObject
 createDisplayableObject array numComponents primitiveMode = do
  vao <- GL.genObjectName
  GL.bindVertexArrayObject $= Just vao
@@ -109,16 +126,22 @@ createDisplayableObject array numComponents primitiveMode = do
  return
    (DisplayableObject
      vao
+      (AbsoluteObject $ map (AbsolutePoint . toPoint) array)
      (fromIntegral $ length array)
      numComponents
      primitiveMode
    )

-initResources :: IO DisplayableObjects
-initResources = do
-  verticesObject <- createDisplayableObject verticesArray 2 GL.TriangleStrip
+initResources :: GLFW.Window -> IO DisplayableObjects
+initResources window = do
+  -- init objects
+
+  verticesObject <- createDisplayableObject verticesArray 3 GL.TriangleStrip
  testObject <- createDisplayableObject testArray 3 GL.TriangleStrip
-  
+
+  putStrLn (unpack $ GLSL.generateGLSL vertShader)
+  putStrLn (unpack $ GLSL.generateGLSL fragShader)
+
  -- load shaders
  program <- loadShaders
    [ ShaderInfo GL.VertexShader (StringSource $ unpack $ GLSL.generateGLSL vertShader)
@@ -127,6 +150,29 @@ initResources = do

  GL.currentProgram $= Just program

+  GLFW.swapBuffers window
+  GLFW.swapBuffers window
+  GLFW.swapBuffers window
+  (w, h) <- GLFW.getFramebufferSize window
+
+  let
+    perspectiveMatrix = toGLMatrix $ L.perspective (78 * 3.141592653 / 180) ((fromIntegral w) / (fromIntegral h)) 0.1 100 L.!*! L.lookAt (L.V3 0 0 (-3)) (L.V3 0 0 0) (L.V3 0 1 0)
+  putStrLn $ show perspectiveMatrix
+
+  let
+    projectionMatrix =
+      [ 1, 0, 0.0, 0.0
+      , 0, 1, 0.0, 0.0
+      , 0, 0, 1.0, 0.3
+      , 0, 0, (-0.3), 1.0] :: [GL.GLfloat]
+
+  projection <- GL.newMatrix GL.ColumnMajor perspectiveMatrix :: IO (GL.GLmatrix GL.GLfloat)
+  location0 <- GL.get $ GL.uniformLocation program "projection"
+  GL.uniform location0 $= projection
+
+  putStrLn $ show projection
+  putStrLn $ show location0
+
  return [verticesObject, testObject]

 -- INPUT --
@@ -145,17 +191,15 @@ openWindow
    GLFW.defaultWindowHints
    GLFW.windowHint (GLFW.WindowHint'ContextVersionMajor 4)
    GLFW.windowHint (GLFW.WindowHint'ContextVersionMinor 5)
+    GLFW.windowHint (GLFW.WindowHint'Samples (Just 16))
    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)
-    objects <- initResources
+    objects <- initResources window
    return (window, objects)

 shutdownWindow :: GLFW.WindowCloseCallback
@@ -169,9 +213,6 @@ 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 =
--- a/src/Haskengl/IO/Shaders/LoadShaders.hs
+++ b/src/Haskengl/IO/Shaders/LoadShaders.hs
@@ -13,7 +13,7 @@
 --
 --------------------------------------------------------------------------------

-module LoadShaders (
+module Haskengl.IO.Shaders.LoadShaders (
   ShaderSource(..), ShaderInfo(..), loadShaders
 ) where

--- a/src/Haskengl/IO/Shaders/Shaders.hs
+++ b/src/Haskengl/IO/Shaders/Shaders.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

-module Shaders (fragShader, vertShader) where
+module Haskengl.IO.Shaders.Shaders (fragShader, vertShader) where

 -- IMPORTS --

@@ -24,12 +24,14 @@ vertShader =
  , VariableDeclaration (Just $ Location 0) In vertexPosition
  , VariableDeclaration (Just $ Location 1) In vertexColor
  , VariableDeclaration Nothing Out fragColorOut
+  , VariableDeclaration Nothing Uniform projection
  , MainStart
-  , VariableAssignment GL_POSITION vertexPosition
+  , DangerousExpression "gl_Position = projection * vec4(vertexPosition, 1.0);"
  , VariableAssignment fragColorOut vertexColor
  ]

 fragColor = Variable "fragColor" $ GLSLVec4 GLSLFloat
 fragColorOut = Variable "fragColorOut" $ GLSLVec4 GLSLFloat
-vertexPosition = Variable "vertexPosition" $ GLSLVec4 GLSLFloat
+vertexPosition = Variable "vertexPosition" $ GLSLVec3 GLSLFloat
 vertexColor = Variable "vertexColor" $ GLSLVec4 GLSLFloat
+projection = Variable "projection" $ GLSLMat4 GLSLFloat
--- a/src/Haskengl/Main.hs
+++ b/src/Haskengl/Main.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+  Module      : Haskengl
+  Description : 4D side project
+  Copyright   : Andromeda 2025
+  License     : WTFPL
+  Maintainer  : Matrix @Andromeda:tchncs.de
+  Stability   : Experimental
+ -}
+module Haskengl.Main (main) where
+
+-- IMPORTS --
+
+import Graphics.UI.GLFW (Window)
+import Relude
+import Relude.Monad (forever)
+
+import Haskengl.IO
+import Haskengl.Math.Transforms
+import Haskengl.Types
+import Haskengl.Update
+
+-- MAIN --
+
+main :: IO ()
+main =
+  do
+    (window, objects) <- openWindow "window :)"
+    loop window objects update view model
+    return ()
+
+-- | Elm-like 'gameloop'
+loop
+  :: Window -- ^ The window to display on
+  -> DisplayableObjects -- ^ Objects to be displayed
+  -> (Model -> Model) -- ^ Update function
+  -> (Window -> DisplayableObjects -> Model -> IO ()) -- ^ View function
+  -> Model -- ^ Model
+  -> IO ()
+loop window objects update view model =
+  do
+    let model = update model
+    view window objects model
+    loop window objects update view model
--- a/src/Haskengl/Math/Transforms.hs
+++ b/src/Haskengl/Math/Transforms.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Transforms has a pile of utility functions for data type conversion
+module Haskengl.Math.Transforms (addCamera, Vertex(..)) where
+
+-- IMPORTS --
+
+import qualified Graphics.Rendering.OpenGL as GL
+
+import Foreign.Storable
+
+import Relude
+
+import Haskengl.Types
+
+-- classes --
+
+class Vertex a where
+  toPoint :: a -> Point
+  fromPoint :: Point -> Maybe a
+  fromPointLossy :: Point -> a
+
+instance Vertex Point where
+  toPoint point = point
+  fromPoint point = Just point
+  fromPointLossy point = point
+
+instance Vertex (GL.Color4 GL.GLfloat) where
+  toPoint (GL.Color4 x y z k) = Point x y z k
+  fromPoint (Point x y z k) = Just $ GL.Color4 x y z k
+  fromPointLossy (Point x y z k) = GL.Color4 x y z k
+
+instance Vertex (GL.Vertex4 GL.GLfloat) where
+  toPoint (GL.Vertex4 x y z k) = Point x y z k
+  fromPoint (Point x y z k) = Just $ GL.Vertex4 x y z k
+  fromPointLossy (Point x y z k) = GL.Vertex4 x y z k
+
+instance Vertex (GL.Vertex3 GL.GLfloat) where
+  toPoint (GL.Vertex3 x y z) = Point x y z 0
+  fromPoint (Point x y z 0) = Just $ GL.Vertex3 x y z
+  fromPoint (Point x y z _) = Nothing
+  fromPointLossy (Point x y z _) = GL.Vertex3 x y z
+
+instance Vertex (GL.Vertex2 GL.GLfloat) where
+  toPoint (GL.Vertex2 x y) = Point x y 0 0
+  fromPoint (Point x y 0 0) = Just $ GL.Vertex2 x y
+  fromPoint (Point x y _ _) = Nothing
+  fromPointLossy (Point x y _ _) = GL.Vertex2 x y
+
+addCamera :: Point -> Point -> Point
+addCamera camera@(Point 0 0 cz 0) point@(Point x y z k) =
+  Point
+    (cz * x / (cz - z))
+    (cz * y / (cz - z))
+    z
+    (cz * k / (cz - z))
--- a/src/Haskengl/Types.hs
+++ b/src/Haskengl/Types.hs
@@ -1,7 +1,8 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

-module Types (DisplayableObject(..), DisplayableObjects(..), Model, model, Triangle(..), triangle, Point(..), point) where
+{- | Basic Types -}
+module Haskengl.Types (DisplayableObject(..), DisplayableObjects(..), Model(..), model, AbsoluteObject(..), Point(..), point) where

 -- IMPORTS --

@@ -17,19 +18,22 @@ type DisplayableObjects = [DisplayableObject]

 data DisplayableObject =
  DisplayableObject
-    GL.VertexArrayObject
-    GL.NumArrayIndices
-    GL.NumComponents
-    GL.PrimitiveMode
+    GL.VertexArrayObject -- ^ VAO
+    AbsoluteObject
+    GL.NumArrayIndices -- ^ The length of the array / number of vertides
+    GL.NumComponents -- ^ Dimensionality of the array element; 4 for vec4
+    GL.PrimitiveMode -- ^ How to render the VAO

 -- model --

+-- | state
 data Model = Model
-               { counter :: Integer
+               { objects :: DisplayableObjects
               }

 -- absolute objects

+-- | object with a defined position
 data AbsoluteObject
  = AbsoluteObject [AbsoluteObject]
  | AbsolutePoint Point
@@ -43,20 +47,24 @@ data Point
      , k :: Float
      }

+-- | straight line between 2 points
 data Line
  = Line Point Point

+-- | triangle between 3 points
 data Triangle
  = Triangle Point Point Point

 -- relative objects

+-- | object without a defined position
 data RelativeObject
  = RelativeObject [RelativeObject]
  | RelativeHVolume HVolume
  | RelativeVolume Volume
  | RelativeSurface Surface

+-- | hyper volume
 data HVolume
  = HSphere Float
  | HPrism Float Volume
@@ -74,7 +82,7 @@ data Surface
 model :: Model
 model =
  Model
-    { counter = 0
+    { objects = []
    }

 -- absolutes
--- a/src/Haskengl/Update.hs
+++ b/src/Haskengl/Update.hs
@@ -1,16 +1,17 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}

-module Update (update) where
+-- | Contains update logic
+module Haskengl.Update (update) where

 -- IMPORTS --

 import Relude

-import Types
+import Haskengl.Types

 -- UPDATE --

 update :: Model -> Model
-update model =
+update model@(Model objects) =
  model
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,36 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Main (main) where
-
-- IMPORTS --
-
-import Graphics.UI.GLFW (Window)
-import Relude
-import Relude.Monad (forever)
-
-import IO
-import Transforms
-import Types
-import Update
-
-- MAIN --
-
-main :: IO ()
-main =
-  do
-    (window, objects) <- openWindow "window :)"
-    _ <- loop window objects update view model
-    return ()
-
-loop
-  :: Window
-  -> DisplayableObjects
-  -> (Model -> Model)
-  -> (Window -> DisplayableObjects -> Model -> IO ())
-  -> Model -> IO Model
-loop window objects update view model =
-  do
-    let model = update model
-    view window objects model
-    loop window objects update view model
--- a/src/Transforms.hs
+++ b/src/Transforms.hs
@@ -1,17 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Transforms (pointToVertex) where
-
-- IMPORTS --
-
-import qualified Graphics.Rendering.OpenGL as GL
-import Graphics.Rendering.OpenGL (($=))
-
-import Relude
-
-import IO
-import Types
-
-pointToVertex :: Point -> GL.Vertex4 GL.GLfloat
-pointToVertex (Point x y z k) = GL.Vertex4 x y z k