--------------------------------------------------------------------------------
-- |
-- Module      :  Rendering
-- Copyright   :  (c) Vladimir Lopatin 2022
-- License     :  BSD-3-Clause
--
-- Maintainer  :  Vladimir Lopatin <madjestic13@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- Utilities for handling OpenGL buffers and rendering.
--
--------------------------------------------------------------------------------


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP    #-}

module Graphics.RedViz.Rendering
  ( openWindow
  , closeWindow
  , render
  , renderString  
  , initVAO
  , bindUniforms
  , bindTexture
  , bindTextureObject
  , loadTex
  , Backend (..)
  , BackendOptions (..)
  ) where

import Control.Monad
import Data.Maybe                             (fromMaybe)
import Data.Text                              (Text)
import Data.UUID
import Data.List.Split                        (splitOn)
import Foreign.C
import Foreign.Marshal.Array                  (withArray)
import Foreign.Ptr                            (plusPtr, nullPtr)
import Foreign.Storable                       (sizeOf)
import Graphics.Rendering.OpenGL as GL hiding (color, normal, Size)
import SDL                             hiding (Point, Event, Timer, (^+^), (*^), (^-^), dot, project, Texture)
import Linear.Vector
import Data.Foldable     as DF (toList)
import Linear.Projection as LP (infinitePerspective)
import Unsafe.Coerce
import Control.Lens       hiding (indexed)
import Graphics.GLUtil                        (readTexture, texture2DWrap)

import Graphics.RedViz.LoadShaders
import Graphics.RedViz.Descriptor
import Graphics.RedViz.Material          as M
import Graphics.RedViz.Texture           as T
import Graphics.RedViz.Drawable

-- import Debug.Trace as DT

debug :: Bool
#ifdef DEBUG
debug = True
#else
debug :: Bool
debug = Bool
False
#endif


data Backend
  = OpenGL
  | Vulkan

data BackendOptions
  =  BackendOptions
     {
       BackendOptions -> PrimitiveMode
primitiveMode :: PrimitiveMode -- Triangles | Points
     , BackendOptions -> Color4 GLfloat
bgrColor      :: Color4 GLfloat
     , BackendOptions -> GLfloat
ptSize        :: Float
     } deriving Int -> BackendOptions -> ShowS
[BackendOptions] -> ShowS
BackendOptions -> String
(Int -> BackendOptions -> ShowS)
-> (BackendOptions -> String)
-> ([BackendOptions] -> ShowS)
-> Show BackendOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BackendOptions] -> ShowS
$cshowList :: [BackendOptions] -> ShowS
show :: BackendOptions -> String
$cshow :: BackendOptions -> String
showsPrec :: Int -> BackendOptions -> ShowS
$cshowsPrec :: Int -> BackendOptions -> ShowS
Show

openWindow :: Text -> (CInt, CInt) -> IO SDL.Window
openWindow :: Text -> (CInt, CInt) -> IO Window
openWindow Text
title (CInt
sizex,CInt
sizey) =
  do
    [InitFlag] -> IO ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Functor m, MonadIO m) =>
f InitFlag -> m ()
SDL.initialize [InitFlag
SDL.InitVideo]
    Hint RenderScaleQuality
SDL.HintRenderScaleQuality Hint RenderScaleQuality -> RenderScaleQuality -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= RenderScaleQuality
SDL.ScaleLinear
    do RenderScaleQuality
renderQuality <- Hint RenderScaleQuality -> IO RenderScaleQuality
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
SDL.get Hint RenderScaleQuality
SDL.HintRenderScaleQuality
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RenderScaleQuality
renderQuality RenderScaleQuality -> RenderScaleQuality -> Bool
forall a. Eq a => a -> a -> Bool
/= RenderScaleQuality
SDL.ScaleLinear) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         String -> IO ()
putStrLn String
"Warning: Linear texture filtering not enabled!"

    let config :: OpenGLConfig
config = OpenGLConfig :: V4 CInt -> CInt -> CInt -> CInt -> Profile -> OpenGLConfig
OpenGLConfig { glColorPrecision :: V4 CInt
glColorPrecision = CInt -> CInt -> CInt -> CInt -> V4 CInt
forall a. a -> a -> a -> a -> V4 a
V4 CInt
8 CInt
8 CInt
8 CInt
0
                              , glDepthPrecision :: CInt
glDepthPrecision = CInt
24
                              , glStencilPrecision :: CInt
glStencilPrecision = CInt
8
                              , glMultisampleSamples :: CInt
glMultisampleSamples = CInt
8
                              --, glProfile = Compatibility Normal 2 1
                              , glProfile :: Profile
glProfile = Mode -> CInt -> CInt -> Profile
Core Mode
Normal CInt
4 CInt
5
                              }

    StateVar (Maybe ComparisonFunction)
depthFunc StateVar (Maybe ComparisonFunction)
-> Maybe ComparisonFunction -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= ComparisonFunction -> Maybe ComparisonFunction
forall a. a -> Maybe a
Just ComparisonFunction
Less

    Window
window <- Text -> WindowConfig -> IO Window
forall (m :: * -> *). MonadIO m => Text -> WindowConfig -> m Window
SDL.createWindow
              Text
title
              WindowConfig
SDL.defaultWindow
              { windowInitialSize :: V2 CInt
SDL.windowInitialSize = CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 CInt
sizex CInt
sizey
              , windowGraphicsContext :: WindowGraphicsContext
SDL.windowGraphicsContext = OpenGLConfig -> WindowGraphicsContext
OpenGLContext OpenGLConfig
config
              }

    Window -> IO ()
forall (m :: * -> *). MonadIO m => Window -> m ()
SDL.showWindow Window
window
    GLContext
_ <- Window -> IO GLContext
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Window -> m GLContext
SDL.glCreateContext Window
window

    Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
window

closeWindow :: SDL.Window -> IO ()
closeWindow :: Window -> IO ()
closeWindow Window
window =
  do
    Window -> IO ()
forall (m :: * -> *). MonadIO m => Window -> m ()
SDL.destroyWindow Window
window
    IO ()
forall (m :: * -> *). MonadIO m => m ()
SDL.quit

renderString :: (Drawable -> IO ()) -> [Drawable] -> String -> IO ()
renderString :: (Drawable -> IO ()) -> [Drawable] -> String -> IO ()
renderString Drawable -> IO ()
cmds [Drawable]
fntsDrs String
str =
    --mapM_ cmds $ format $ drawableString fntsDrs "Hello, World!"--str
  (Drawable -> IO ()) -> [Drawable] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Drawable -> IO ()
cmds ([Drawable] -> IO ()) -> [Drawable] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Drawable] -> [Drawable]
format ([Drawable] -> [Drawable]) -> [Drawable] -> [Drawable]
forall a b. (a -> b) -> a -> b
$ [Drawable] -> String -> [Drawable]
drawableString [Drawable]
fntsDrs String
str

-- | given a string of drawables, return a formatted string (e.g. add offsets for drawable chars)
format :: [Drawable] -> [Drawable]
format :: [Drawable] -> [Drawable]
format [Drawable]
drs = [Drawable]
drw
  where
    drw :: [Drawable]
drw = ((Drawable, Int) -> Drawable) -> [(Drawable, Int)] -> [Drawable]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Drawable, Int) -> Drawable
formatting ([Drawable] -> [Int] -> [(Drawable, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Drawable]
drs [Int
0..])

formatting :: (Drawable, Int) -> Drawable
formatting :: (Drawable, Int) -> Drawable
formatting (Drawable
drw, Int
offset) = Drawable
drw'
  where
    -- uns  = view uniforms drw
    rot0 :: V3 (V3 Double)
rot0 = Getting (V3 (V3 Double)) (V4 (V4 Double)) (V3 (V3 Double))
-> V4 (V4 Double) -> V3 (V3 Double)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V3 (V3 Double)) (V4 (V4 Double)) (V3 (V3 Double))
forall (t :: * -> *) (v :: * -> *) a.
(Representable t, R3 t, R3 v) =>
Lens' (t (v a)) (M33 a)
_m33 (Getting (V4 (V4 Double)) Drawable (V4 (V4 Double))
-> Drawable -> V4 (V4 Double)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Uniforms -> Const (V4 (V4 Double)) Uniforms)
-> Drawable -> Const (V4 (V4 Double)) Drawable
Lens' Drawable Uniforms
uniforms ((Uniforms -> Const (V4 (V4 Double)) Uniforms)
 -> Drawable -> Const (V4 (V4 Double)) Drawable)
-> ((V4 (V4 Double) -> Const (V4 (V4 Double)) (V4 (V4 Double)))
    -> Uniforms -> Const (V4 (V4 Double)) Uniforms)
-> Getting (V4 (V4 Double)) Drawable (V4 (V4 Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V4 (V4 Double) -> Const (V4 (V4 Double)) (V4 (V4 Double)))
-> Uniforms -> Const (V4 (V4 Double)) Uniforms
Lens' Uniforms (V4 (V4 Double))
u_xform) Drawable
drw)
    tr0 :: V3 Double
tr0  = Getting (V3 Double) (V4 (V4 Double)) (V3 Double)
-> V4 (V4 Double) -> V3 Double
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (V3 Double) (V4 (V4 Double)) (V3 Double)
forall (t :: * -> *) (v :: * -> *) a.
(Representable t, R3 t, R4 v) =>
Lens' (t (v a)) (V3 a)
translation (Getting (V4 (V4 Double)) Drawable (V4 (V4 Double))
-> Drawable -> V4 (V4 Double)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Uniforms -> Const (V4 (V4 Double)) Uniforms)
-> Drawable -> Const (V4 (V4 Double)) Drawable
Lens' Drawable Uniforms
uniforms ((Uniforms -> Const (V4 (V4 Double)) Uniforms)
 -> Drawable -> Const (V4 (V4 Double)) Drawable)
-> ((V4 (V4 Double) -> Const (V4 (V4 Double)) (V4 (V4 Double)))
    -> Uniforms -> Const (V4 (V4 Double)) Uniforms)
-> Getting (V4 (V4 Double)) Drawable (V4 (V4 Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V4 (V4 Double) -> Const (V4 (V4 Double)) (V4 (V4 Double)))
-> Uniforms -> Const (V4 (V4 Double)) Uniforms
Lens' Uniforms (V4 (V4 Double))
u_xform) Drawable
drw)
    s1 :: Double
s1   = Double
0.085  -- scale Offset
    s2 :: V3 (V3 Double)
s2   = V3 (V3 Double)
1.0    -- scale Size
    h :: Double
h    = -Double
0.4   -- horizontal offset
    v :: Double
v    = Double
1.1    -- vertical   offset
    offsetM44 :: V4 (V4 Double)
offsetM44 =
      V3 (V3 Double) -> V3 Double -> V4 (V4 Double)
forall a. Num a => M33 a -> V3 a -> M44 a
mkTransformationMat
      (V3 (V3 Double)
rot0 V3 (V3 Double) -> V3 (V3 Double) -> V3 (V3 Double)
forall a. Num a => a -> a -> a
* V3 (V3 Double)
s2)
      (V3 Double
tr0 V3 Double -> V3 Double -> V3 Double
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ Double -> Double -> Double -> V3 Double
forall a. a -> a -> a -> V3 a
V3 (Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offsetDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
s1) Double
v Double
0)
    drw' :: Drawable
drw' = ASetter Drawable Drawable (V4 (V4 Double)) (V4 (V4 Double))
-> V4 (V4 Double) -> Drawable -> Drawable
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Uniforms -> Identity Uniforms) -> Drawable -> Identity Drawable
Lens' Drawable Uniforms
uniforms ((Uniforms -> Identity Uniforms) -> Drawable -> Identity Drawable)
-> ((V4 (V4 Double) -> Identity (V4 (V4 Double)))
    -> Uniforms -> Identity Uniforms)
-> ASetter Drawable Drawable (V4 (V4 Double)) (V4 (V4 Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V4 (V4 Double) -> Identity (V4 (V4 Double)))
-> Uniforms -> Identity Uniforms
Lens' Uniforms (V4 (V4 Double))
u_xform) V4 (V4 Double)
offsetM44 Drawable
drw

-- | Alphabet of drawables -> String -> String of drawables
drawableString :: [Drawable] -> String -> [Drawable]
drawableString :: [Drawable] -> String -> [Drawable]
drawableString [Drawable]
drs String
str = [Drawable]
drws
  where
    drws :: [Drawable]
drws = (Char -> Drawable) -> String -> [Drawable]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Drawable] -> Char -> Drawable
drawableChar [Drawable]
drs) String
str

-- | Alphabet of drawables -> Char -> a drawable char
drawableChar :: [Drawable] -> Char -> Drawable
drawableChar :: [Drawable] -> Char -> Drawable
drawableChar [Drawable]
drs Char
chr =
  case Char
chr of
    Char
'0' -> [Drawable] -> Drawable
forall a. [a] -> a
head [Drawable]
drs
    Char
'1' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
1
    Char
'2' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
2
    Char
'3' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
3
    Char
'4' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
4
    Char
'5' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
5
    Char
'6' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
6
    Char
'7' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
7
    Char
'8' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
8
    Char
'9' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
9
    Char
'a' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
10
    Char
'b' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
11
    Char
'c' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
12
    Char
'd' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
13
    Char
'e' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
14
    Char
'f' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
15
    Char
'g' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
16
    Char
'h' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
17
    Char
'H' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
17
    Char
'i' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
18
    Char
'j' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
19
    Char
'k' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
20
    Char
'l' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
21
    Char
'm' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
22
    Char
'n' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
23
    Char
'o' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
24
    Char
'p' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
25
    Char
'q' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
26
    Char
'r' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
27
    Char
's' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
28
    Char
't' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
29
    Char
'u' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
30
    Char
'v' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
31
    Char
'w' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
32
    Char
'W' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
32
    Char
'x' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
33
    Char
'y' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
34
    Char
'z' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
35
    Char
'+' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
36
    Char
'-' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
37
    Char
'=' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
38
    Char
'>' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
39
    Char
',' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
40
    Char
'.' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
41
    Char
'?' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
42
    Char
'!' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
43
    Char
' ' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
44
    Char
'*' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
45
    Char
'/' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
46
    Char
':' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
47
    Char
'\'' -> [Drawable]
drs[Drawable] -> Int -> Drawable
forall a. [a] -> Int -> a
!!Int
48
    Char
_   -> [Drawable] -> Drawable
forall a. [a] -> a
head [Drawable]
drs

render :: [Texture] -> [(UUID, GLuint)] ->  BackendOptions -> Drawable -> IO ()
render :: [Texture]
-> [(UUID, GLuint)] -> BackendOptions -> Drawable -> IO ()
render [Texture]
txs [(UUID, GLuint)]
hmap BackendOptions
opts (Drawable String
_ Uniforms
unis (Descriptor VertexArrayObject
vao' NumArrayIndices
numIndices') Program
_) =
  do
    -- print $ "render.name : " ++ name
    -- print $ "render.unis :" ++ show unis ++ "\n render.txs :" ++ show txs ++ "\n render.hmap : " ++ show hmap
    [Texture] -> Uniforms -> [(UUID, GLuint)] -> IO ()
bindUniforms [Texture]
txs Uniforms
unis [(UUID, GLuint)]
hmap
    StateVar (Maybe VertexArrayObject)
bindVertexArrayObject StateVar (Maybe VertexArrayObject)
-> Maybe VertexArrayObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= VertexArrayObject -> Maybe VertexArrayObject
forall a. a -> Maybe a
Just VertexArrayObject
vao'

    StateVar GLfloat
GL.pointSize StateVar GLfloat -> GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= BackendOptions -> GLfloat
ptSize BackendOptions
opts --0.001
    --GL.pointSmooth $= Enabled

    PrimitiveMode -> NumArrayIndices -> DataType -> Ptr Any -> IO ()
forall a.
PrimitiveMode -> NumArrayIndices -> DataType -> Ptr a -> IO ()
drawElements (BackendOptions -> PrimitiveMode
primitiveMode BackendOptions
opts) NumArrayIndices
numIndices' DataType
GL.UnsignedInt Ptr Any
forall a. Ptr a
nullPtr

    StateVar (Maybe Face)
cullFace  StateVar (Maybe Face) -> Maybe Face -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Face -> Maybe Face
forall a. a -> Maybe a
Just Face
Back
    StateVar (Maybe ComparisonFunction)
depthFunc StateVar (Maybe ComparisonFunction)
-> Maybe ComparisonFunction -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= ComparisonFunction -> Maybe ComparisonFunction
forall a. a -> Maybe a
Just ComparisonFunction
Less

bindTextureObject :: GLuint -> TextureObject -> IO ()
bindTextureObject :: GLuint -> TextureObject -> IO ()
bindTextureObject GLuint
uid TextureObject
tx0 = do
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Binding Texture Object : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ TextureObject -> String
forall a. Show a => a -> String
show TextureObject
tx0 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" at TextureUnit : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GLuint -> String
forall a. Show a => a -> String
show GLuint
uid
  TextureTarget2D -> StateVar Capability
forall t. ParameterizedTextureTarget t => t -> StateVar Capability
texture TextureTarget2D
Texture2D        StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
  StateVar TextureUnit
activeTexture            StateVar TextureUnit -> TextureUnit -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLuint -> TextureUnit
TextureUnit GLuint
uid
  TextureTarget2D -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
textureBinding TextureTarget2D
Texture2D StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just TextureObject
tx0

bindTexture :: [(UUID, GLuint)] -> Texture -> IO ()
bindTexture :: [(UUID, GLuint)] -> Texture -> IO ()
bindTexture [(UUID, GLuint)]
hmap Texture
tx =
  do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Binding Texture : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Texture -> String
forall a. Show a => a -> String
show Texture
tx String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" at TextureUnit : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GLuint -> String
forall a. Show a => a -> String
show GLuint
txid
    TextureTarget2D -> StateVar Capability
forall t. ParameterizedTextureTarget t => t -> StateVar Capability
texture TextureTarget2D
Texture2D        StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
    StateVar TextureUnit
activeTexture            StateVar TextureUnit -> TextureUnit -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLuint -> TextureUnit
TextureUnit GLuint
txid
    --activeTexture            $= TextureUnit (DT.trace ("bindTexture.txid : " ++ show txid) txid)
    TextureObject
tx0 <- String -> IO TextureObject
loadTex (String -> IO TextureObject) -> String -> IO TextureObject
forall a b. (a -> b) -> a -> b
$ Getting String Texture String -> Texture -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Texture String
Lens' Texture String
path Texture
tx --TODO : replace that with a hashmap lookup?
    TextureTarget2D -> StateVar (Maybe TextureObject)
forall t.
BindableTextureTarget t =>
t -> StateVar (Maybe TextureObject)
textureBinding TextureTarget2D
Texture2D StateVar (Maybe TextureObject) -> Maybe TextureObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= TextureObject -> Maybe TextureObject
forall a. a -> Maybe a
Just TextureObject
tx0
      where
        txid :: GLuint
txid = GLuint -> Maybe GLuint -> GLuint
forall a. a -> Maybe a -> a
fromMaybe GLuint
0 (UUID -> [(UUID, GLuint)] -> Maybe GLuint
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Getting UUID Texture UUID -> Texture -> UUID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UUID Texture UUID
Lens' Texture UUID
uuid Texture
tx) [(UUID, GLuint)]
hmap)

bindUniforms :: [Texture] -> Uniforms -> [(UUID, GLuint)] -> IO ()
bindUniforms :: [Texture] -> Uniforms -> [(UUID, GLuint)] -> IO ()
bindUniforms [Texture]
txs Uniforms
unis [(UUID, GLuint)]
hmap =
  do
    let programDebug :: IO Program
programDebug = [ShaderInfo] -> IO Program
loadShaders
                       [ ShaderType -> ShaderSource -> ShaderInfo
ShaderInfo ShaderType
VertexShader   (String -> ShaderSource
FileSource (Material -> String
_vertShader Material
u_mat' ))   -- u_mat is only used for debug
                       , ShaderType -> ShaderSource -> ShaderInfo
ShaderInfo ShaderType
FragmentShader (String -> ShaderSource
FileSource (Material -> String
_fragShader Material
u_mat' )) ]
    Program
program0 <- if Bool
debug then IO Program
programDebug else Program -> IO Program
forall (f :: * -> *) a. Applicative f => a -> f a
pure Program
u_prog'
    StateVar (Maybe Program)
currentProgram StateVar (Maybe Program) -> Maybe Program -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Program -> Maybe Program
forall a. a -> Maybe a
Just Program
program0

    let u_mouse0 :: Vector2 GLfloat
u_mouse0      = GLfloat -> GLfloat -> Vector2 GLfloat
forall a. a -> a -> Vector2 a
Vector2 (Double -> GLfloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> GLfloat) -> Double -> GLfloat
forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Double
forall a b. (a, b) -> a
fst (Double, Double)
u_mouse') (Double -> GLfloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> GLfloat) -> Double -> GLfloat
forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Double
forall a b. (a, b) -> b
snd (Double, Double)
u_mouse') :: Vector2 GLfloat
    UniformLocation
location0         <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation Program
program0 String
"u_mouse'")
    UniformLocation -> StateVar (Vector2 GLfloat)
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
location0 StateVar (Vector2 GLfloat) -> Vector2 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Vector2 GLfloat
u_mouse0

    let resX :: Double
resX          = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a. Enum a => a -> Int
fromEnum (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ (CInt, CInt) -> CInt
forall a b. (a, b) -> a
fst (CInt, CInt)
u_res' :: Double
        resY :: Double
resY          = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a. Enum a => a -> Int
fromEnum (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ (CInt, CInt) -> CInt
forall a b. (a, b) -> b
snd (CInt, CInt)
u_res' :: Double
        u_res0 :: Vector2 GLfloat
u_res0         = GLfloat -> GLfloat -> Vector2 GLfloat
forall a. a -> a -> Vector2 a
Vector2 (Double -> GLfloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
resX) (Double -> GLfloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
resY) :: Vector2 GLfloat

    UniformLocation
location1         <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation Program
program0 String
"u_resolution")
    UniformLocation -> StateVar (Vector2 GLfloat)
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
location1 StateVar (Vector2 GLfloat) -> Vector2 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Vector2 GLfloat
u_res0

    UniformLocation
location2         <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation Program
program0 String
"u_time'")
    UniformLocation -> StateVar Double
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
location2 StateVar Double -> Double -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Double
u_time' :: GLdouble)

    let apt :: Double
apt = Double
u_cam_a' -- aperture
        foc :: Double
foc = Double
u_cam_f' -- focal length
        proj :: V4 (V4 Double)
proj =
          Double -> Double -> Double -> V4 (V4 Double)
forall a. Floating a => a -> a -> a -> M44 a
LP.infinitePerspective
          (Double
2.0 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
atan ( Double
aptDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2.0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
foc )) -- FOV
          (Double
resXDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
resY)                    -- Aspect
          Double
0.01                           -- Near

    GLmatrix GLfloat
persp             <- MatrixOrder -> [GLfloat] -> IO (GLmatrix GLfloat)
forall (m :: * -> *) c.
(Matrix m, MatrixComponent c) =>
MatrixOrder -> [c] -> IO (m c)
GL.newMatrix MatrixOrder
RowMajor ([GLfloat] -> IO (GLmatrix GLfloat))
-> [GLfloat] -> IO (GLmatrix GLfloat)
forall a b. (a -> b) -> a -> b
$ V4 (V4 Double) -> [GLfloat]
toList' V4 (V4 Double)
proj   :: IO (GLmatrix GLfloat)
    UniformLocation
location3         <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation Program
program0 String
"persp")
    UniformLocation -> StateVar (GLmatrix GLfloat)
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
location3 StateVar (GLmatrix GLfloat) -> GLmatrix GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLmatrix GLfloat
persp

    --print $ show u_cam'
    GLmatrix GLfloat
camera            <- MatrixOrder -> [GLfloat] -> IO (GLmatrix GLfloat)
forall (m :: * -> *) c.
(Matrix m, MatrixComponent c) =>
MatrixOrder -> [c] -> IO (m c)
GL.newMatrix MatrixOrder
RowMajor ([GLfloat] -> IO (GLmatrix GLfloat))
-> [GLfloat] -> IO (GLmatrix GLfloat)
forall a b. (a -> b) -> a -> b
$ V4 (V4 Double) -> [GLfloat]
toList' V4 (V4 Double)
u_cam' :: IO (GLmatrix GLfloat)
    UniformLocation
location4         <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation Program
program0 String
"camera")
    UniformLocation -> StateVar (GLmatrix GLfloat)
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
location4 StateVar (GLmatrix GLfloat) -> GLmatrix GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLmatrix GLfloat
camera

    GLmatrix GLfloat
xform             <- MatrixOrder -> [GLfloat] -> IO (GLmatrix GLfloat)
forall (m :: * -> *) c.
(Matrix m, MatrixComponent c) =>
MatrixOrder -> [c] -> IO (m c)
GL.newMatrix MatrixOrder
RowMajor ([GLfloat] -> IO (GLmatrix GLfloat))
-> [GLfloat] -> IO (GLmatrix GLfloat)
forall a b. (a -> b) -> a -> b
$ V4 (V4 Double) -> [GLfloat]
toList' V4 (V4 Double)
xform' :: IO (GLmatrix GLfloat)
    UniformLocation
location5         <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation Program
program0 String
"xform")
    UniformLocation -> StateVar (GLmatrix GLfloat)
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
location5 StateVar (GLmatrix GLfloat) -> GLmatrix GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLmatrix GLfloat
xform

    GLmatrix GLfloat
xform1            <- MatrixOrder -> [GLfloat] -> IO (GLmatrix GLfloat)
forall (m :: * -> *) c.
(Matrix m, MatrixComponent c) =>
MatrixOrder -> [c] -> IO (m c)
GL.newMatrix MatrixOrder
RowMajor ([GLfloat] -> IO (GLmatrix GLfloat))
-> [GLfloat] -> IO (GLmatrix GLfloat)
forall a b. (a -> b) -> a -> b
$ V4 (V4 Double) -> [GLfloat]
toList' V4 (V4 Double)
u_xform' :: IO (GLmatrix GLfloat)
    UniformLocation
location6         <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation Program
program0 String
"xform1")
    UniformLocation -> StateVar (GLmatrix GLfloat)
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
location6 StateVar (GLmatrix GLfloat) -> GLmatrix GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLmatrix GLfloat
xform1

    let sunP :: Vector3 GLfloat
sunP = GLfloat -> GLfloat -> GLfloat -> Vector3 GLfloat
forall a. a -> a -> a -> Vector3 a
GL.Vector3 GLfloat
299999999999.0 GLfloat
0.0 GLfloat
0.0 :: GL.Vector3 GLfloat
    UniformLocation
location7 <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation Program
program0 String
"sunP")
    UniformLocation -> StateVar (Vector3 GLfloat)
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
location7 StateVar (Vector3 GLfloat) -> Vector3 GLfloat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Vector3 GLfloat
sunP

    --- | Allocate Textures

    -- putStrLn $ "bindUniforms.txNames : "  ++ show txNames
    -- putStrLn $ "bindUniforms.txuids   : " ++ show txuids
    (Texture -> IO ()) -> [Texture] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Program -> [(UUID, GLuint)] -> Texture -> IO ()
allocateTextures Program
program0 [(UUID, GLuint)]
hmap) [Texture]
txs
    --mapM_ (allocateTextures program0 (DT.trace ("bindUniforms.hmap : " ++ show hmap) hmap)) txs

    --- | Unload buffers
    --bindVertexArrayObject         $= Nothing
    --bindBuffer ElementArrayBuffer $= Nothing
      where
        Uniforms Material
u_mat' Program
u_prog' (Double, Double)
u_mouse' Double
u_time' (CInt, CInt)
u_res' V4 (V4 Double)
u_cam' Double
u_cam_a' Double
u_cam_f' V4 (V4 Double)
u_xform' = Uniforms
unis
        toList' :: V4 (V4 Double) -> [GLfloat]
toList' = (Double -> GLfloat) -> [Double] -> [GLfloat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> GLfloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac([Double] -> [GLfloat])
-> (V4 (V4 Double) -> [Double]) -> V4 (V4 Double) -> [GLfloat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[[Double]] -> [Double]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat([[Double]] -> [Double])
-> (V4 (V4 Double) -> [[Double]]) -> V4 (V4 Double) -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((V4 Double -> [Double]) -> [V4 Double] -> [[Double]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap V4 Double -> [Double]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList([V4 Double] -> [[Double]])
-> (V4 (V4 Double) -> [V4 Double]) -> V4 (V4 Double) -> [[Double]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.V4 (V4 Double) -> [V4 Double]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) :: V4 (V4 Double) -> [GLfloat]
        xform' :: V4 (V4 Double)
xform'  = --- | = Object Position - Camera Position
          V4 (V4 Double) -> V4 (V4 Double)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
transpose (V4 (V4 Double) -> V4 (V4 Double))
-> V4 (V4 Double) -> V4 (V4 Double)
forall a b. (a -> b) -> a -> b
$
          V3 (V4 Double) -> V4 Double -> V4 (V4 Double)
forall a. V3 (V4 a) -> V4 a -> M44 a
fromV3M44
          ( V4 (V4 Double)
u_xform' V4 (V4 Double)
-> Getting (V3 (V4 Double)) (V4 (V4 Double)) (V3 (V4 Double))
-> V3 (V4 Double)
forall s a. s -> Getting a s a -> a
^.Getting (V3 (V4 Double)) (V4 (V4 Double)) (V3 (V4 Double))
forall (t :: * -> *) a. R3 t => Lens' (t a) (V3 a)
_xyz )
          ( V3 Double -> Double -> V4 Double
forall a. V3 a -> a -> V4 a
fromV3V4 (V4 (V4 Double) -> V4 (V4 Double)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
transpose V4 (V4 Double)
u_xform' V4 (V4 Double)
-> Getting (V3 Double) (V4 (V4 Double)) (V3 Double) -> V3 Double
forall s a. s -> Getting a s a -> a
^.(V4 Double -> Const (V3 Double) (V4 Double))
-> V4 (V4 Double) -> Const (V3 Double) (V4 (V4 Double))
forall (t :: * -> *) a. R4 t => Lens' (t a) a
_w((V4 Double -> Const (V3 Double) (V4 Double))
 -> V4 (V4 Double) -> Const (V3 Double) (V4 (V4 Double)))
-> ((V3 Double -> Const (V3 Double) (V3 Double))
    -> V4 Double -> Const (V3 Double) (V4 Double))
-> Getting (V3 Double) (V4 (V4 Double)) (V3 Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(V3 Double -> Const (V3 Double) (V3 Double))
-> V4 Double -> Const (V3 Double) (V4 Double)
forall (t :: * -> *) a. R3 t => Lens' (t a) (V3 a)
_xyz V3 Double -> V3 Double -> V3 Double
forall a. Num a => a -> a -> a
+ V4 (V4 Double) -> V4 (V4 Double)
forall (g :: * -> *) (f :: * -> *) a.
(Distributive g, Functor f) =>
f (g a) -> g (f a)
transpose V4 (V4 Double)
u_cam' V4 (V4 Double)
-> Getting (V3 Double) (V4 (V4 Double)) (V3 Double) -> V3 Double
forall s a. s -> Getting a s a -> a
^.(V4 Double -> Const (V3 Double) (V4 Double))
-> V4 (V4 Double) -> Const (V3 Double) (V4 (V4 Double))
forall (t :: * -> *) a. R4 t => Lens' (t a) a
_w((V4 Double -> Const (V3 Double) (V4 Double))
 -> V4 (V4 Double) -> Const (V3 Double) (V4 (V4 Double)))
-> ((V3 Double -> Const (V3 Double) (V3 Double))
    -> V4 Double -> Const (V3 Double) (V4 Double))
-> Getting (V3 Double) (V4 (V4 Double)) (V3 Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(V3 Double -> Const (V3 Double) (V3 Double))
-> V4 Double -> Const (V3 Double) (V4 Double)
forall (t :: * -> *) a. R3 t => Lens' (t a) (V3 a)
_xyz) Double
1.0 ) :: M44 Double

allocateTextures :: Program -> [(UUID, GLuint)] -> Texture -> IO ()
allocateTextures :: Program -> [(UUID, GLuint)] -> Texture -> IO ()
allocateTextures Program
program0 [(UUID, GLuint)]
hmap Texture
tx =
  do
    UniformLocation
location <- GettableStateVar UniformLocation
-> GettableStateVar UniformLocation
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation Program
program0 (Getting String Texture String -> Texture -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Texture String
Lens' Texture String
T.name Texture
tx))
    UniformLocation -> StateVar TextureUnit
forall a. Uniform a => UniformLocation -> StateVar a
uniform UniformLocation
location StateVar TextureUnit -> TextureUnit -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLuint -> TextureUnit
TextureUnit GLuint
txid
      where
        txid :: GLuint
txid = GLuint -> Maybe GLuint -> GLuint
forall a. a -> Maybe a -> a
fromMaybe GLuint
0 (UUID -> [(UUID, GLuint)] -> Maybe GLuint
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Getting UUID Texture UUID -> Texture -> UUID
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UUID Texture UUID
Lens' Texture UUID
uuid Texture
tx) [(UUID, GLuint)]
hmap)

fromList :: [a] -> M44 a
fromList :: [a] -> M44 a
fromList [a]
xs = V4 a -> V4 a -> V4 a -> V4 a -> M44 a
forall a. a -> a -> a -> a -> V4 a
V4
              (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 ([a] -> a
forall a. [a] -> a
head [a]
xs ) ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
1 )([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
2 )([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
3))
              (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
4 ) ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
5 )([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
6 )([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
7))
              (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
8 ) ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
9 )([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
10)([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
11))
              (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
12) ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
13)([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
14)([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!Int
15))

fromV3M44 :: V3 (V4 a) -> V4 a -> M44 a
fromV3M44 :: V3 (V4 a) -> V4 a -> M44 a
fromV3M44 V3 (V4 a)
v3 = V4 a -> V4 a -> V4 a -> V4 a -> M44 a
forall a. a -> a -> a -> a -> V4 a
V4 (V3 (V4 a)
v3 V3 (V4 a) -> Getting (V4 a) (V3 (V4 a)) (V4 a) -> V4 a
forall s a. s -> Getting a s a -> a
^. Getting (V4 a) (V3 (V4 a)) (V4 a)
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) (V3 (V4 a)
v3 V3 (V4 a) -> Getting (V4 a) (V3 (V4 a)) (V4 a) -> V4 a
forall s a. s -> Getting a s a -> a
^. Getting (V4 a) (V3 (V4 a)) (V4 a)
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) (V3 (V4 a)
v3 V3 (V4 a) -> Getting (V4 a) (V3 (V4 a)) (V4 a) -> V4 a
forall s a. s -> Getting a s a -> a
^. Getting (V4 a) (V3 (V4 a)) (V4 a)
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z)

fromV3V4 :: V3 a -> a -> V4 a
fromV3V4 :: V3 a -> a -> V4 a
fromV3V4 V3 a
v3 = a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 (V3 a
v3 V3 a -> Getting a (V3 a) a -> a
forall s a. s -> Getting a s a -> a
^. Getting a (V3 a) a
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x) (V3 a
v3 V3 a -> Getting a (V3 a) a -> a
forall s a. s -> Getting a s a -> a
^. Getting a (V3 a) a
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) (V3 a
v3 V3 a -> Getting a (V3 a) a -> a
forall s a. s -> Getting a s a -> a
^. Getting a (V3 a) a
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z)

nameFromPath :: FilePath -> String
nameFromPath :: ShowS
nameFromPath String
f = [String] -> String
forall a. [a] -> a
head (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"/" String
f[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
1)

initVAO :: ([Int], Int, [Float]) -> IO Descriptor
initVAO :: ([Int], Int, [GLfloat]) -> IO Descriptor
initVAO ([Int]
idx', Int
st', [GLfloat]
vs') =
  do
    let
      idx :: [GLuint]
idx = Int -> GLuint
forall a b. a -> b
unsafeCoerce (Int -> GLuint) -> [Int] -> [GLuint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
idx' :: [GLuint]
      vs :: [GLfloat]
vs  = GLfloat -> GLfloat
forall a b. a -> b
unsafeCoerce (GLfloat -> GLfloat) -> [GLfloat] -> [GLfloat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [GLfloat]
vs'  :: [GLfloat]
    --- | VAO
    VertexArrayObject
vao <- IO VertexArrayObject
forall a (m :: * -> *). (GeneratableObjectName a, MonadIO m) => m a
genObjectName
    StateVar (Maybe VertexArrayObject)
bindVertexArrayObject StateVar (Maybe VertexArrayObject)
-> Maybe VertexArrayObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= VertexArrayObject -> Maybe VertexArrayObject
forall a. a -> Maybe a
Just VertexArrayObject
vao
    --- | VBO
    BufferObject
vertexBuffer <- IO BufferObject
forall a (m :: * -> *). (GeneratableObjectName a, MonadIO m) => m a
genObjectName
    BufferTarget -> StateVar (Maybe BufferObject)
bindBuffer BufferTarget
ArrayBuffer StateVar (Maybe BufferObject) -> Maybe BufferObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= BufferObject -> Maybe BufferObject
forall a. a -> Maybe a
Just BufferObject
vertexBuffer
    [GLfloat] -> (Ptr GLfloat -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [GLfloat]
vs ((Ptr GLfloat -> IO ()) -> IO ())
-> (Ptr GLfloat -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr GLfloat
ptr ->
      do
        let sizev :: GLsizeiptr
sizev = Int -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([GLfloat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GLfloat]
vs Int -> Int -> Int
forall a. Num a => a -> a -> a
* GLfloat -> Int
forall a. Storable a => a -> Int
sizeOf ([GLfloat] -> GLfloat
forall a. [a] -> a
head [GLfloat]
vs))
        BufferTarget -> StateVar (GLsizeiptr, Ptr GLfloat, BufferUsage)
forall a. BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData BufferTarget
ArrayBuffer StateVar (GLsizeiptr, Ptr GLfloat, BufferUsage)
-> (GLsizeiptr, Ptr GLfloat, BufferUsage) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (GLsizeiptr
sizev, Ptr GLfloat
ptr, BufferUsage
StaticDraw)
    --- | EBO
    BufferObject
elementBuffer <- IO BufferObject
forall a (m :: * -> *). (GeneratableObjectName a, MonadIO m) => m a
genObjectName
    BufferTarget -> StateVar (Maybe BufferObject)
bindBuffer BufferTarget
ElementArrayBuffer StateVar (Maybe BufferObject) -> Maybe BufferObject -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= BufferObject -> Maybe BufferObject
forall a. a -> Maybe a
Just BufferObject
elementBuffer
    let numIndices :: Int
numIndices = [GLuint] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GLuint]
idx
    [GLuint] -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [GLuint]
idx ((Ptr GLuint -> IO ()) -> IO ()) -> (Ptr GLuint -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr GLuint
ptr ->
      do
        let indicesSize :: GLsizeiptr
indicesSize = Int -> GLsizeiptr
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
numIndices Int -> Int -> Int
forall a. Num a => a -> a -> a
* GLuint -> Int
forall a. Storable a => a -> Int
sizeOf ([GLuint] -> GLuint
forall a. [a] -> a
head [GLuint]
idx))
        BufferTarget -> StateVar (GLsizeiptr, Ptr GLuint, BufferUsage)
forall a. BufferTarget -> StateVar (GLsizeiptr, Ptr a, BufferUsage)
bufferData BufferTarget
ElementArrayBuffer StateVar (GLsizeiptr, Ptr GLuint, BufferUsage)
-> (GLsizeiptr, Ptr GLuint, BufferUsage) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (GLsizeiptr
indicesSize, Ptr GLuint
ptr, BufferUsage
StaticDraw)

        --- | Bind the pointer to the vertex attribute data
        let floatSize :: NumArrayIndices
floatSize  = (Int -> NumArrayIndices
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> NumArrayIndices) -> Int -> NumArrayIndices
forall a b. (a -> b) -> a -> b
$ GLfloat -> Int
forall a. Storable a => a -> Int
sizeOf (GLfloat
0.0::GLfloat)) :: GLsizei
            stride :: NumArrayIndices
stride     = Int -> NumArrayIndices
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
st' NumArrayIndices -> NumArrayIndices -> NumArrayIndices
forall a. Num a => a -> a -> a
* NumArrayIndices
floatSize

        --- | Alpha
        AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor Any)
forall a.
AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor a)
vertexAttribPointer (GLuint -> AttribLocation
AttribLocation GLuint
0) StateVar (IntegerHandling, VertexArrayDescriptor Any)
-> (IntegerHandling, VertexArrayDescriptor Any) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (IntegerHandling
ToFloat, NumArrayIndices
-> DataType
-> NumArrayIndices
-> Ptr Any
-> VertexArrayDescriptor Any
forall a.
NumArrayIndices
-> DataType -> NumArrayIndices -> Ptr a -> VertexArrayDescriptor a
VertexArrayDescriptor NumArrayIndices
1 DataType
Float NumArrayIndices
stride ((Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Any
forall a. Ptr a
nullPtr (Int -> Ptr Any)
-> (NumArrayIndices -> Int) -> NumArrayIndices -> Ptr Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumArrayIndices -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (NumArrayIndices
0 NumArrayIndices -> NumArrayIndices -> NumArrayIndices
forall a. Num a => a -> a -> a
* NumArrayIndices
floatSize)))
        AttribLocation -> StateVar Capability
vertexAttribArray   (GLuint -> AttribLocation
AttribLocation GLuint
0) StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
        --- | Colors
        AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor Any)
forall a.
AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor a)
vertexAttribPointer (GLuint -> AttribLocation
AttribLocation GLuint
1) StateVar (IntegerHandling, VertexArrayDescriptor Any)
-> (IntegerHandling, VertexArrayDescriptor Any) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (IntegerHandling
ToFloat, NumArrayIndices
-> DataType
-> NumArrayIndices
-> Ptr Any
-> VertexArrayDescriptor Any
forall a.
NumArrayIndices
-> DataType -> NumArrayIndices -> Ptr a -> VertexArrayDescriptor a
VertexArrayDescriptor NumArrayIndices
3 DataType
Float NumArrayIndices
stride ((Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Any
forall a. Ptr a
nullPtr (Int -> Ptr Any)
-> (NumArrayIndices -> Int) -> NumArrayIndices -> Ptr Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumArrayIndices -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (NumArrayIndices
1 NumArrayIndices -> NumArrayIndices -> NumArrayIndices
forall a. Num a => a -> a -> a
* NumArrayIndices
floatSize)))
        AttribLocation -> StateVar Capability
vertexAttribArray   (GLuint -> AttribLocation
AttribLocation GLuint
1) StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
        --- | Normals
        AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor Any)
forall a.
AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor a)
vertexAttribPointer (GLuint -> AttribLocation
AttribLocation GLuint
2) StateVar (IntegerHandling, VertexArrayDescriptor Any)
-> (IntegerHandling, VertexArrayDescriptor Any) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (IntegerHandling
ToFloat, NumArrayIndices
-> DataType
-> NumArrayIndices
-> Ptr Any
-> VertexArrayDescriptor Any
forall a.
NumArrayIndices
-> DataType -> NumArrayIndices -> Ptr a -> VertexArrayDescriptor a
VertexArrayDescriptor NumArrayIndices
3 DataType
Float NumArrayIndices
stride ((Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Any
forall a. Ptr a
nullPtr (Int -> Ptr Any)
-> (NumArrayIndices -> Int) -> NumArrayIndices -> Ptr Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumArrayIndices -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (NumArrayIndices
4 NumArrayIndices -> NumArrayIndices -> NumArrayIndices
forall a. Num a => a -> a -> a
* NumArrayIndices
floatSize)))
        AttribLocation -> StateVar Capability
vertexAttribArray   (GLuint -> AttribLocation
AttribLocation GLuint
2) StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
        --- | UVW
        AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor Any)
forall a.
AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor a)
vertexAttribPointer (GLuint -> AttribLocation
AttribLocation GLuint
3) StateVar (IntegerHandling, VertexArrayDescriptor Any)
-> (IntegerHandling, VertexArrayDescriptor Any) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (IntegerHandling
ToFloat, NumArrayIndices
-> DataType
-> NumArrayIndices
-> Ptr Any
-> VertexArrayDescriptor Any
forall a.
NumArrayIndices
-> DataType -> NumArrayIndices -> Ptr a -> VertexArrayDescriptor a
VertexArrayDescriptor NumArrayIndices
3 DataType
Float NumArrayIndices
stride ((Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Any
forall a. Ptr a
nullPtr (Int -> Ptr Any)
-> (NumArrayIndices -> Int) -> NumArrayIndices -> Ptr Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumArrayIndices -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (NumArrayIndices
7 NumArrayIndices -> NumArrayIndices -> NumArrayIndices
forall a. Num a => a -> a -> a
* NumArrayIndices
floatSize)))
        AttribLocation -> StateVar Capability
vertexAttribArray   (GLuint -> AttribLocation
AttribLocation GLuint
3) StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
        --- | Positions
        AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor Any)
forall a.
AttribLocation
-> StateVar (IntegerHandling, VertexArrayDescriptor a)
vertexAttribPointer (GLuint -> AttribLocation
AttribLocation GLuint
4) StateVar (IntegerHandling, VertexArrayDescriptor Any)
-> (IntegerHandling, VertexArrayDescriptor Any) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (IntegerHandling
ToFloat, NumArrayIndices
-> DataType
-> NumArrayIndices
-> Ptr Any
-> VertexArrayDescriptor Any
forall a.
NumArrayIndices
-> DataType -> NumArrayIndices -> Ptr a -> VertexArrayDescriptor a
VertexArrayDescriptor NumArrayIndices
3 DataType
Float NumArrayIndices
stride ((Ptr Any -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Any
forall a. Ptr a
nullPtr (Int -> Ptr Any)
-> (NumArrayIndices -> Int) -> NumArrayIndices -> Ptr Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumArrayIndices -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (NumArrayIndices
10 NumArrayIndices -> NumArrayIndices -> NumArrayIndices
forall a. Num a => a -> a -> a
* NumArrayIndices
floatSize)))
        AttribLocation -> StateVar Capability
vertexAttribArray   (GLuint -> AttribLocation
AttribLocation GLuint
4) StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled

    Descriptor -> IO Descriptor
forall (m :: * -> *) a. Monad m => a -> m a
return (Descriptor -> IO Descriptor) -> Descriptor -> IO Descriptor
forall a b. (a -> b) -> a -> b
$ VertexArrayObject -> NumArrayIndices -> Descriptor
Descriptor VertexArrayObject
vao (Int -> NumArrayIndices
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numIndices)

loadTex :: FilePath -> IO TextureObject
loadTex :: String -> IO TextureObject
loadTex String
f =
  do
    TextureObject
t <- (String -> TextureObject)
-> (TextureObject -> TextureObject)
-> Either String TextureObject
-> TextureObject
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> TextureObject
forall a. HasCallStack => String -> a
error TextureObject -> TextureObject
forall a. a -> a
id (Either String TextureObject -> TextureObject)
-> IO (Either String TextureObject) -> IO TextureObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either String TextureObject)
readTexture String
f
    StateVar (Repetition, Clamping)
texture2DWrap StateVar (Repetition, Clamping) -> (Repetition, Clamping) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Repetition
Repeated, Clamping
ClampToEdge)
    TextureTarget2D
-> StateVar (MinificationFilter, MagnificationFilter)
forall t.
ParameterizedTextureTarget t =>
t -> StateVar (MinificationFilter, MagnificationFilter)
textureFilter  TextureTarget2D
Texture2D StateVar (MinificationFilter, MagnificationFilter)
-> (MinificationFilter, MagnificationFilter) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= ((MagnificationFilter
Linear', MagnificationFilter -> Maybe MagnificationFilter
forall a. a -> Maybe a
Just MagnificationFilter
Nearest), MagnificationFilter
Linear')
    StateVar Capability
blend StateVar Capability -> Capability -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
    StateVar (BlendingFactor, BlendingFactor)
blendFunc StateVar (BlendingFactor, BlendingFactor)
-> (BlendingFactor, BlendingFactor) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (BlendingFactor
SrcAlpha, BlendingFactor
OneMinusSrcAlpha)
    TextureTarget2D -> IO ()
forall t. ParameterizedTextureTarget t => t -> IO ()
generateMipmap' TextureTarget2D
Texture2D
    TextureObject -> IO TextureObject
forall (m :: * -> *) a. Monad m => a -> m a
return TextureObject
t