Michelangelo 0.1.0.3 → 0.2.0.0

raw patch · 6 files changed

+228/−83 lines, 6 files

Files

Michelangelo.cabal +2/−2
src/Graphics/Michelangelo/Lenses.hs +53/−0
src/Graphics/Michelangelo/Mesh.hs +11/−10
src/Graphics/Michelangelo/Shaders.hs +51/−51
src/Graphics/Michelangelo/Shapes.hs +91/−4
src/Graphics/Michelangelo/Types.hs +20/−16

Michelangelo.cabal view

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.1.0.3
+version:             0.2.0.0
 
 -- A short (one-line) description of the package.
 synopsis:            OpenGL for dummies
@@ -54,7 +54,7 @@   -- Modules exported by the library.
   exposed-modules:     Graphics.Michelangelo.Types,   Graphics.Michelangelo.Utils, Graphics.Michelangelo.Transformations, Graphics.Michelangelo.Shapes,
                        Graphics.Michelangelo.Shaders, Graphics.Michelangelo.Scene, Graphics.Michelangelo.Mesh,            Graphics.Michelangelo.Entity,
-                       Graphics.Michelangelo.Camera
+                       Graphics.Michelangelo.Camera,  Graphics.Michelangelo.Lenses
 
   -- Modules included in this library but not exported.
   -- other-modules:

+ src/Graphics/Michelangelo/Lenses.hs view

@@ -0,0 +1,53 @@+-- |
+-- Module      : Graphics.Michelangelo.lenses
+-- Description :
+-- Copyright   : (c) Jonatan H Sundqvist, 2015
+-- License     : MIT
+-- Maintainer  : Jonatan H Sundqvist
+-- Stability   : experimental|stable
+-- Portability : POSIX (not sure)
+--
+
+-- Created November 22 2015
+
+-- TODO | -
+--        -
+
+-- SPEC | -
+--        -
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- GHC Pragmas
+--------------------------------------------------------------------------------------------------------------------------------------------
+{-# LANGUAGE TemplateHaskell        #-} --
+{-# LANGUAGE MultiParamTypeClasses  #-} -- Compilation silently fails without this...
+{-# LANGUAGE FunctionalDependencies #-} -- Ditto
+{-# LANGUAGE FlexibleInstances      #-} --
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- API
+--------------------------------------------------------------------------------------------------------------------------------------------
+module Graphics.Michelangelo.Lenses where
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- We'll need these
+--------------------------------------------------------------------------------------------------------------------------------------------
+import Control.Lens
+
+import Graphics.Michelangelo.Types
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- Lenses
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+makeFields ''Mesh
+makeFields ''Entity
+makeFields ''ShaderProgram

src/Graphics/Michelangelo/Mesh.hs view

@@ -13,6 +13,7 @@ -- TODO | - Index buffers
 --        - Use lenses (?)
 --        - Move shader-specific stuff to Shader module
+--        - Proper logging
 
 -- SPEC | -
 --        -
@@ -31,6 +32,7 @@ 
 import qualified Data.Map.Strict as Map --
 
+import Control.Lens
 import Control.Monad (liftM2, liftM) --
 import Control.Applicative ((<*>))   --
 
@@ -46,6 +48,7 @@ import Graphics.WaveFront.Parsers    as WF    --
 
 import Graphics.Michelangelo.Types
+import Graphics.Michelangelo.Lenses
 import Graphics.Michelangelo.Shaders as Shade --
 
 
@@ -59,17 +62,15 @@ renderMesh mesh = do
   GLUtil.printErrorMsg "Entering renderMesh"
   -- return $ (prepare mesh) <*> Just mesh
-  case prepare mesh of
-    Just action -> action mesh
-    _           -> return ()
+  maybe (return ()) ($ mesh) (mesh^.prepare)
   GLUtil.printErrorMsg "Shader program set"
 
   withAttributes mesh $ \ _ -> do
-    GLUtil.printErrorMsg "Entering withAttributes action"
-    Shade.setShaderUniforms (shader mesh) (Map.elems $ uniforms mesh) --
-    GLUtil.printErrorMsg "Uniforms set"
-    GL.drawArrays (primitive mesh) 0 (fromIntegral $ size mesh)       --
-    GLUtil.printErrorMsg "Arrays drawn"
+    GLUtil.printErrorMsg "Entering withAttributes action"             --
+    Shade.setShaderUniforms (mesh^.shader) (Map.elems $ _meshUniforms mesh) --
+    GLUtil.printErrorMsg "Uniforms set"                           --
+    GL.drawArrays (mesh^.primitive) 0 (fromIntegral $ mesh^.size) --
+    GLUtil.printErrorMsg "Arrays drawn"                           --
 
 
 -- |
@@ -97,7 +98,7 @@ bindAttributes :: Mesh -> IO ()
 bindAttributes mesh = do
   -- GLS.currentProgram $= Just (shader mesh)
-  Map.foldrWithKey reduce nothing (attributes mesh) -- TODO: Use Traversable instead (?)
+  Map.foldrWithKey reduce nothing (mesh^.attributes) -- TODO: Use Traversable instead (?)
   where
      reduce key (loc, buff, count) acc = acc >> bufferAttribute buff loc count --
      nothing                           = return ()                             --
@@ -105,7 +106,7 @@ 
 -- |
 unbindAttributes :: Mesh -> IO ()
-unbindAttributes mesh = Map.foldrWithKey reduce nothing (attributes mesh)
+unbindAttributes mesh = Map.foldrWithKey reduce nothing (mesh^.attributes)
   where
      reduce key (loc, buff, count) acc = acc >> (GL.vertexAttribArray loc $= GL.Enabled) --
      nothing                           = return ()                                       --

src/Graphics/Michelangelo/Shaders.hs view

@@ -79,43 +79,43 @@ -- TODO: Use Monad transformer to make 'bailing-out' easier (?)
 createShaderProgram :: String -> String -> IO (Either [String] GL.Program)
 createShaderProgram vsource psource = do
-	putStrLn "Creating shader program"
-	program <- GL.createProgram
-	vshader <- GL.createShader VertexShader
-	pshader <- GL.createShader FragmentShader
+  putStrLn "Creating shader program"
+  program <- GL.createProgram
+  vshader <- GL.createShader VertexShader
+  pshader <- GL.createShader FragmentShader
 
-	case (vsource, psource) of
-		("", _) -> return $ Left ["Empty vertex shader source"]
-		(_, "") -> return $ Left ["Empty pixel shader source"]
-		_       -> do
-			putStrLn "Setting vertex shader source"
-			shaderSourceBS vshader $= packUtf8 vsource
+  case (vsource, psource) of
+    ("", _) -> return $ Left ["Empty vertex shader source"]
+    (_, "") -> return $ Left ["Empty pixel shader source"]
+    _       -> do
+      putStrLn "Setting vertex shader source"
+      shaderSourceBS vshader $= packUtf8 vsource
 
-			putStrLn "Compiling vertex shader"
-			compileShader vshader
+      putStrLn "Compiling vertex shader"
+      compileShader vshader
 
-			putStrLn "Setting fragment shader source"
-			shaderSourceBS pshader $= packUtf8 psource
-			compileShader pshader
+      putStrLn "Setting fragment shader source"
+      shaderSourceBS pshader $= packUtf8 psource
+      compileShader pshader
 
-			-- putStrLn "Compiling shaders..."
+      -- putStrLn "Compiling shaders..."
 
-			vstatus <- GL.get $ compileStatus vshader
-			printf "Vertex shader %s compiled successfully.\n" (if vstatus then "was" else "was not")
-			pstatus <- GL.get $ compileStatus pshader
-			printf "Vertex pixel %s compiled successfully.\n" (if pstatus then "was" else "was not")
+      vstatus <- GL.get $ compileStatus vshader
+      printf "Vertex shader %s compiled successfully.\n" (if vstatus then "was" else "was not")
+      pstatus <- GL.get $ compileStatus pshader
+      printf "Vertex pixel %s compiled successfully.\n" (if pstatus then "was" else "was not")
 
-			if vstatus && pstatus
-				then do
-					putStrLn "Successfully compiled shaders. Linking program..."
-					mapM (GL.attachShader program) [vshader, pshader]
+      if vstatus && pstatus
+        then do
+          putStrLn "Successfully compiled shaders. Linking program..."
+          mapM (GL.attachShader program) [vshader, pshader]
 
-					GL.linkProgram program
-					linked <- GL.get $ GL.linkStatus program
-					if linked
-						then return $ Right program
-						else mapM GL.get [GL.shaderInfoLog vshader, GL.shaderInfoLog pshader, GL.programInfoLog program] >>= return . Left
-				else mapM (GL.get . GL.shaderInfoLog) [vshader, pshader] >>= return . Left
+          GL.linkProgram program
+          linked <- GL.get $ GL.linkStatus program
+          if linked
+            then return $ Right program
+            else mapM GL.get [GL.shaderInfoLog vshader, GL.shaderInfoLog pshader, GL.programInfoLog program] >>= return . Left
+        else mapM (GL.get . GL.shaderInfoLog) [vshader, pshader] >>= return . Left
 
 
 -- |
@@ -123,27 +123,27 @@ -- TODO: Pass in uniforms by name or by location (?)
 setShaderUniforms :: GL.Program -> [(GL.UniformLocation, UniformValue)] -> IO ()
 setShaderUniforms theprogram theuniforms = do
-	-- Set uniforms
-	-- mapM ((>> printErrorMsg "Setting uniform") . uncurry uniform) theuniforms
-	-- TODO: Refactor
-	forM theuniforms $ \(loc, value) -> case value of
-		UMatrix44 mat -> uniform loc $= mat
-		UFloat    f   -> uniform loc $= f
-		UInt      i   -> uniform loc $= i
-		-- UVec vec -> uniform loc $= vec
-	return ()
+  -- Set uniforms
+  -- mapM ((>> printErrorMsg "Setting uniform") . uncurry uniform) theuniforms
+  -- TODO: Refactor
+  forM theuniforms $ \(loc, value) -> case value of
+    UMatrix44 mat -> uniform loc $= mat
+    UFloat    f   -> uniform loc $= f
+    UInt      i   -> uniform loc $= i
+    -- UVec vec -> uniform loc $= vec
+  return ()
 
 
 -- |
 loadShaderProgram :: String -> String -> IO (Either [String] GL.Program)
 loadShaderProgram vpath ppath = do
-	[vsource, psource] <- mapM readFile [vpath, ppath]
-	catch
-	  (createShaderProgram vsource psource)            --
-	  caught -- TODO: More elaborate exception message (?)
-	where
-	  caught :: IOException -> IO (Either [String] GL.Program)
-	  caught _ = return $ Left ["Unable to open file."]
+  [vsource, psource] <- mapM readFile [vpath, ppath]
+  catch
+    (createShaderProgram vsource psource)            --
+    caught -- TODO: More elaborate exception message (?)
+  where
+    caught :: IOException -> IO (Either [String] GL.Program)
+    caught _ = return $ Left ["Unable to open file."]
 
 
 
@@ -167,7 +167,7 @@ -- |
 -- TODO: Better names (?)
 -- class UniformValue u where
-	-- setUniform :: (Storable u) => GL.GLint -> GL.GLsizei -> Ptr GL.GLfloat -> IO ()
+  -- setUniform :: (Storable u) => GL.GLint -> GL.GLsizei -> Ptr GL.GLfloat -> IO ()
 
 
 -- Scalars
@@ -175,20 +175,20 @@ 
 -- Vectors
 -- instance UniformValue (M44 Float) where
-	-- setUniform = GLRaw.glUniformMatrix3fv
+  -- setUniform = GLRaw.glUniformMatrix3fv
 
 
 -- Matrices
 -- instance UniformValue (M22 Float) where
-	-- setUniform = GLRaw.glUniformMatrix2fv
+  -- setUniform = GLRaw.glUniformMatrix2fv
 
 
 -- instance UniformValue (M33 Float) where
-	-- setUniform = GLRaw.glUniformMatrix3fv
+  -- setUniform = GLRaw.glUniformMatrix3fv
 
 
 -- instance UniformValue (M44 Float) where
-	-- setUniform = GLRaw.glUniformMatrix4fv
+  -- setUniform = GLRaw.glUniformMatrix4fv
 
 -- glUniform1f :: GLint -> GLfloat -> IO ()
 -- glUniform2f :: GLint -> GLfloat -> GLfloat -> IO ()

src/Graphics/Michelangelo/Shapes.hs view

@@ -1,17 +1,24 @@ -- |
 -- Module      : Graphics.Michelangelo.Shapes
--- Description : descr
+-- Description :
 -- Copyright   : (c) Jonatan H Sundqvist, 2015
 -- License     : MIT
 -- Maintainer  : Jonatan H Sundqvist
 -- Stability   : experimental|stable
--- Portability : POSIX (not sure)
+-- Portability : 
 --
 
 -- Created July 30 2015
 
--- TODO | -
---        -
+-- TODO | - Generic container types (eg. Monoids or OverloadedLists?)
+--        - Generic vertex types (?)
+--        - Anchored shapes (?)
+--        - Bounding boxes
+--        - Indexed shapes
+--        - Triangulation (or - more generally - tiling) of polygons
+--        - QuickCheck
+--        - Performance
+--        - Types to represent surfaces, edges, etc.
 
 -- SPEC | -
 --        -
@@ -25,10 +32,90 @@ --------------------------------------------------------------------------------------------------------------------------------------------
 -- We'll need these
 --------------------------------------------------------------------------------------------------------------------------------------------
+-- import Data.Monoid
+
 import Graphics.Michelangelo.Types
 
 
 
 --------------------------------------------------------------------------------------------------------------------------------------------
+-- Types
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+-- | A 'Face' is a list of vertices
+-- TODO: Polymorphic container
+-- TODO: Make sure all vertices lie in the same plane (using Triangles?)
+data Face v = Face [v]
+
+
+-- |
+data Edge v = Edge v v
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
+-- Data
+--------------------------------------------------------------------------------------------------------------------------------------------
+
+-- | TODO: Factor out
+π :: Floating f => f
+π = pi
+
+
+
+--------------------------------------------------------------------------------------------------------------------------------------------
 -- Functions
 --------------------------------------------------------------------------------------------------------------------------------------------
+
+-- Vertex constructors ---------------------------------------------------------------------------------------------------------------------
+
+-- | A simple list of vertices
+vlist :: a -> a -> a -> [a]
+vlist x y z = [x, y, z]
+
+-- Tessellation ----------------------------------------------------------------------------------------------------------------------------
+
+-- Two-dimensional shapes ------------------------------------------------------------------------------------------------------------------
+
+-- | Generate the vertices for a rectangular plane, centred at (0,0,0)
+plane :: Fractional f => (f -> f -> f -> a) -> f -> f -> f -> [a]
+plane f dx dy dz = [f (-dx/2) (dy/2) (dz/2), f (dx/2) (dy/2) (dz/2), f (dx/2) (-dy/2) (-dz/2), f (-dx/2) (-dy/2) (-dz/2)]
+
+
+-- | Generate the vertices for a rectangular plane, parallel with the X and Y axes and centred at (0,0,0)
+-- TODO: General 'plane' function
+planeXY :: Fractional f => (f -> f -> f -> a) -> f -> f -> [a]
+planeXY f dx dy = plane f dx dy 0
+-- planeXY dx dy = [f (-dx/2) (dy/2) 0, f (dx/2) (dy/2) 0, f (dx/2) (-dy/2) 0, f (-dx/2) (-dy/2) 0]
+
+
+-- | Generate the vertices for a rectangular plane, parallel with the X and Z axes and centred at (0,0,0)
+-- TODO: General 'plane' function
+planeXZ :: Fractional f => (f -> f -> f -> a) -> f -> f -> [a]
+planeXZ f dx dz = plane f dx 0 dz
+
+
+-- | Generate the vertices for a rectangular plane, parallel with the Y and Z axes and centred at (0,0,0)
+-- TODO: General 'plane' function
+planeYZ :: Fractional f => (f -> f -> f -> a) -> f -> f -> [a]
+planeYZ f dy dz = plane f 0 dy dz
+
+
+-- | Generate the vertices for a regular polygon, centred at (0,0,0)
+polygon :: (Floating f, Integral i) => (f -> f -> a) -> i -> f -> [a]
+polygon f sides radius = [ let θ = fromIntegral n * 2*π/fromIntegral sides in f (radius*cos θ) (radius*sin θ) | n <- [0..(sides-1)] ]
+
+-- Three-dimensional shapes ----------------------------------------------------------------------------------------------------------------
+
+-- | Generate the vertices of an axis-aligned cuboid centred at (0,0,0)
+-- TODO: Use combinatorics to generate vertices (?)
+cuboid :: Fractional f => (f -> f -> f -> a) -> f -> f -> f -> [[a]]
+cuboid f dx dy dz = [[f (-hdx)   hdy  hdz, f hdx   hdy  hdz, f hdx   hdy  (-hdz), f (-hdx)   hdy  (-hdz)],
+                     [f (-hdx) (-hdy) hdz, f hdx (-hdy) hdz, f hdx (-hdy) (-hdz), f (-hdx) (-hdy) (-hdz)]]
+  where
+    (hdx, hdy, hdz) = (dx/2, dy/2, dz/2)
+
+
+-- | Generate the vertices of an axis-aligned cube centred at (0,0,0)
+cube :: Fractional f => (f -> f -> f -> a) -> f -> [[a]]
+cube f side = cuboid f side side side

src/Graphics/Michelangelo/Types.hs view

@@ -69,15 +69,16 @@ -- TODO: Store render function (?)
 -- TODO: Restructure (?)
 -- TODO: Metadata (?)
-data Mesh = Mesh { texture    :: Maybe GL.TextureObject,   -- TODO: Allow more than one texture (?)
-                   primitive  :: GL.PrimitiveMode,         --
-                   attributes :: Map.Map String Attribute, --
-                   uniforms   :: Map.Map String (GL.UniformLocation, UniformValue),   --
-                   shader     :: GL.Program,               --
-                   prepare    :: Maybe (Mesh -> IO ()),    -- Optional rendering setup function
-                   centre     :: V3 Float,                 --
-                   bounds     :: WF.BoundingBox Float,     --
-                   size       :: Int                       --
+-- TODO: Less ugly field names (maybe tweak the name mangler?)
+data Mesh = Mesh { _meshTexture    :: Maybe GL.TextureObject,   -- TODO: Allow more than one texture (?)
+                   _meshPrimitive  :: GL.PrimitiveMode,         --
+                   _meshAttributes :: Map.Map String Attribute, --
+                   _meshUniforms   :: Map.Map String (GL.UniformLocation, UniformValue),   --
+                   _meshShader     :: GL.Program,               --
+                   _meshPrepare    :: Maybe (Mesh -> IO ()),    -- Optional rendering setup function
+                   _meshCentre     :: V3 Float,                 --
+                   _meshBounds     :: WF.BoundingBox Float,     --
+                   _meshSize       :: Int                       --
                  } --deriving (Show)
 
 
@@ -86,19 +87,22 @@ 
 
 -- |
-data ShaderProgram = ShaderProgram { _program    :: GL.Program,
-	                                   _attributes :: Map.Map String (GL.AttribLocation,  GL.VariableType),
-                                     _uniforms   :: Map.Map String (GL.UniformLocation, GL.VariableType)}
+-- TODO: Rename (?)
+-- TODO: Less ugly field names (maybe tweak the name mangler?)
+data ShaderProgram = ShaderProgram { _shaderProgramProgram    :: GL.Program,
+                                     _shaderProgramAttributes :: Map.Map String (GL.AttribLocation,  GL.VariableType),
+                                     _shaderProgramUniforms   :: Map.Map String (GL.UniformLocation, GL.VariableType)}
 
 
 -- |
 -- type Uniform   = (GL.UniformLocation, UniformValue)         --
-type Attribute = (GL.AttribLocation,  GL.BufferObject, Int) -- TODO: Are there any non-buffer attribute types, separate type (?)
+type Attribute = (GL.AttribLocation, GL.BufferObject, Int) -- TODO: Are there any non-buffer attribute types, separate type (?)
 
 -- Classes ---------------------------------------------------------------------------------------------------------------------------------
 
 -- |
 -- TODO: Better naming conventions
+-- TODO: Use type family (?)
 -- TOOD: All uniform types (matrices, vectors, scalars, variable length)
 data UniformValue = UMatrix44 (M44 Float) |
                     UVec3     (V3 Float)  |
@@ -115,16 +119,16 @@ -- TODO: Find out how to read uniform value
 -- instance GL.UniformComponent a => GL.Uniform (M44 a) where
 instance GL.Uniform (M44 Float) where
-	uniform (GL.UniformLocation loc) = GL.makeStateVar (error "Not implemented") (\u -> Marshal.with (transpose u) (\ptr -> GLRaw.glUniformMatrix4fv loc 1 0 (castPtr (ptr :: Ptr (M44 Float)))))
+  uniform (GL.UniformLocation loc) = GL.makeStateVar (error "Not implemented") (\u -> Marshal.with (transpose u) (\ptr -> GLRaw.glUniformMatrix4fv loc 1 0 (castPtr (ptr :: Ptr (M44 Float)))))
    -- uniformv loc count = uniform3v location count . (castPtr :: Ptr (Vertex3 b) -> Ptr b)
 
 
 instance GL.Uniform (Float) where
-	uniform (GL.UniformLocation loc) = GL.makeStateVar (error "Not implemented") (\f -> Marshal.with f (\ptr -> GLRaw.glUniform1fv loc 1 (castPtr (ptr :: Ptr (Float)))))
+  uniform (GL.UniformLocation loc) = GL.makeStateVar (error "Not implemented") (\f -> Marshal.with f (\ptr -> GLRaw.glUniform1fv loc 1 (castPtr (ptr :: Ptr (Float)))))
    -- uniformv loc count = uniform3v location count . (castPtr :: Ptr (Vertex3 b) -> Ptr b)
 
 
 -- |
 instance GL.Uniform (Int) where
-	uniform (GL.UniformLocation loc) = GL.makeStateVar (error "Not implemented") (\i -> Marshal.with i (\ptr -> GLRaw.glUniform1iv loc 1 (castPtr (ptr :: Ptr (Int)))))
+  uniform (GL.UniformLocation loc) = GL.makeStateVar (error "Not implemented") (\i -> Marshal.with i (\ptr -> GLRaw.glUniform1iv loc 1 (castPtr (ptr :: Ptr (Int)))))
    -- uniformv loc count = uniform3v location count . (castPtr :: Ptr (Vertex3 b) -> Ptr b)