Work towards doing transformations using uniforms

app/Main.hs

@@ -60,17 +60,14 @@ main = do
                                             (_windowX w,_windowY w) 
                                             (wallsForGloom' w)
                                             (lightsForGloom' w)
-                                            (draw blank w)
+                                            (worldPictures w)
+                      blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+                      renderTree (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w)
+                                            (_windowX w,_windowY w) 
+                                            (picToList 1 $ fixedCoordPictures w)
                       playSoundQueue (_soundData preData) (_soundQueue w)
                       newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
                       return $ preData {_soundData = newSoundData}
-                      --renderPicture' preData (_windowX w,_windowY w) (Circle 5)
---            renderPicture' preData 
---                          (pictures [scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]
---                                    ,scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]
---                                    ,color red $ scale 0.0005 0.0005 $ text "asdf"
---                                    ]
---                          )
         )
         (flip $ menuEvents $ flip handleEvent)
         (\w -> Just $ update w)

shader/arc.vert

@@ -4,6 +4,12 @@ layout (location = 1) in vec4 color;
 layout (location = 2) in vec4 saEaRadWdth;
 out vec4 vColor;
 out vec4 vparams;
+
+uniform vec2 winSize;
+uniform float zoom;
+uniform vec2 translation;
+uniform float rotation;
+
 void main()
 {
   gl_Position = vec4(position,1);

shader/background.geom

@@ -5,6 +5,8 @@ in vec4 vParams [];
 in vec2 vWinSize [];
 out vec2 gTexPos;
 
+uniform vec2 translation;
+
 vec2 rotBy( float rot, vec2 v)
 {
   return vec2 ( v.x * cos(rot) - v.y * sin(rot)
@@ -15,7 +17,7 @@ vec2 rotBy( float rot, vec2 v)
 
 void main()
 {
-  vec2 cPos = vec2(vParams[0].x / 250 , vParams[0].y /250 );
+  vec2 cPos = vec2(translation.x / 250 , translation.y /250 );
   float zoom = vParams[0].w;
   float rot  = 0 - vParams[0].z;
       

shader/background.vert

@@ -1,8 +1,14 @@
 #version 430 core
 layout (location = 0) in vec4 params;
-layout (location = 1) in vec2 winSize;
+layout (location = 1) in vec2 winSizea;
 out vec4 vParams;
 out vec2 vWinSize;
+
+uniform vec2 winSize;
+uniform float zoom;
+uniform vec2 translation;
+uniform float rotation;
+
 void main()
 {
   gl_Position = vec4(0,0,0,0);

shader/basic.vert

@@ -2,6 +2,12 @@
 layout (location = 0) in vec3 position;
 layout (location = 1) in vec4 color;
 out vec4 vColor;
+
+uniform vec2 winSize;
+uniform float zoom;
+uniform float rotation;
+uniform vec2 translation;
+
 void main()
 {
   gl_Position = vec4(position,1);

shader/basicTexture.vert

@@ -3,6 +3,11 @@ layout (location = 0) in vec3 aPos;
 layout (location = 1) in vec4 aColor;
 layout (location = 2) in vec2 aTexCoord;
 
+uniform vec2 winSize;
+uniform float zoom;
+uniform vec2 translation;
+uniform float rotation;
+
 out vec4 vColor;
 out vec2 vTexCoord;
 

shader/circle.vert

@@ -4,6 +4,12 @@ layout (location = 1) in vec4 color;
 layout (location = 2) in float rad;
 out vec4 vColor;
 out float vRad;
+
+uniform vec2 winSize;
+uniform float zoom;
+uniform vec2 translation;
+uniform float rotation;
+
 void main()
 {
   gl_Position = vec4(position,1);

shader/fadeCircle.vert

@@ -1,6 +1,12 @@
 #version 430 core
 layout (location = 0) in vec4 position;
 out vec2 vParams;
+
+uniform vec2 winSize;
+uniform float zoom;
+uniform vec2 translation;
+uniform float rotation;
+
 void main()
 {
   gl_Position = vec4(position.xy,0,1);

shader/wallShadow.vert

@@ -4,6 +4,11 @@ layout (location = 1) in vec4 backPoss;
 
 out vec4 vBackPoss;
 
+uniform vec2 winSize;
+uniform float zoom;
+uniform float rotation;
+uniform vec2 translation;
+
 void main()
 {
   gl_Position = poss;

src/Dodge/Rendering.hs

@@ -22,65 +22,42 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 
 -- }}}
---
+fixedCoordPictures :: World -> Picture
-drawTest :: World -> Picture
+fixedCoordPictures w = pictures
-drawTest w = screenT $ color red $  circle 200
+             [ scaler $ onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels]
-    where (x,y) = (_windowX w,_windowY w)
+             , scaler $ hudDrawings w
-          screenT = scale (1/x) (1/y)
+             , scaler $ onLayer MenuLayer menuScreen
-
-
-draw' :: Picture -> World -> ([((Float,Float),(Float,Float))]
-                             ,[((Float,Float),Float,Float)]
-                             ,Picture,Picture)
-draw' p w = (\(x,y) -> (wallsForGloom w,lightsForGloom w,x,y)) (draw'' p w)
-
-draw :: Picture -> World -> Picture
-draw p w = (\(x,y) -> f $ pictures [x,y]) $ draw'' p w
-    where f = scale (2/_windowX w) (2/_windowY w)
-
-draw'' :: Picture -> World -> (Picture , Picture)
-draw'' b w-- | (Char 'm') `S.member` _keys w
-        --            = let a = (-500,30)
-        --                  b = (200,0)
-        --              in pictures [ color white $ polygon screenBox
-        --                       , color blue $ circleSolid 40
-        --                       , line [a,b]
-        --                       , uncurry translate (ssaTriPoint a (0,0) b 40)
-        --                                  $ color red  $ circleSolid 5
-        --                       ]
-    = case _mapDisplay w of
-         (True, z) -> (blank
-                      ,pictures [color white $ circleSolid 3
-                                ,scale z z $ rotate (0 - (_cameraRot w))
-                                    $ uncurry translate ((0,0) -.- _cameraCenter w) 
-                                    $ pictures $ mapMaybe mapWall $ IM.elems $ _walls w]
-                       ) 
-         _ -> ( blank
-              --,pictures $ map fst pics
-              ,collectDrawings w
-              )
---                    ++ map screenShift (pathsTest ++ map drawNode (labNodes $ _pathGraph w))
-    where yourPos = _crPos $ you w
-          backgroundTile = [screenShift $ translate (5*512*x) (5*512*y) $ scale 5 5 b | x <- [x1..x2] , y <- [y1..y2] ]
-                where (x',y') = yourPos
-                      (x'',y'') = (fromIntegral $ round (x'/(512*5)), fromIntegral $ round (y'/(512*5)))
-                      x1 = (x''-1)
-                      x2 = (x''+1)
-                      y1 = (y''-1)
-                      y2 = (y''+1)
-          screenShift = scale zoom zoom . rotate (0 - (_cameraRot w) )
-                                            . uncurry translate ((0,0) -.- _cameraPos w)
-          zoom = _cameraZoom w
-          pathsTest = map drawPair $ _pathGraph' w
-          drawPair (x,y) = color cyan $ pictures [line [x,y]
-                           --         , uncurry translate x $ scale 0.05 0.05 $ text $ show x
              ]
-          drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i
+    where scaler = scale (2 / _windowX w) (2 / _windowY w)
+          itLabels     = pictures $ map (drawItemName w) (IM.elems (_floorItems w))
+          ppLabels     = pictures $ map (drawPPText w) (IM.elems (_pressPlates w))
+          btLabels     = pictures $ map (drawButText w) (IM.elems (_buttons w))
+          menuScreen :: Picture
+          menuScreen = case _menuState w of
+                        InGame -> blank 
+                        LevelMenu x -> 
+                            pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w
+                            tst (-100) 100 0.4 ("LEVEL "++show x)
+                            ,controlsList
+                            ]
+                        PauseMenu   -> pictures 
+                                    [--color (withAlpha 0.5 black) $ polygon $ screenBox w
+                                    tst (-100) 100 0.4 "PAUSED"
+                                    ,tst (-100) 50 0.2 "n - new level"
+                                    ,tst (-100) 0 0.2 "r - restart"
+                                    , controlsList
+                                    ]
+                        GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
+                                    ,tst (-100) 100 0.4 "GAME OVER"
+                                    ,tst (-100) 50 0.2 "n - new level"
+                                    ,tst (-100) 0 0.2 "r - restart"
+                                    ,controlsList
+                                    ]
+                where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
 
-collectDrawings :: World -> Picture
+worldPictures :: World -> Picture
-collectDrawings w = pictures 
+worldPictures w
-             [screenShift $
+    = pictures $ map screenShift $ concat
-                        pictures $ concat
                                  [ decPicts 
                                  , ppPicts 
                                  , itFloorPicts 
@@ -94,15 +71,99 @@ collectDrawings w = pictures
                                  , wallShadows
                                  , smokeShadows
                                  ]
-             , onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels]
+    where
-             , hudDrawings w
+          screenShift = scale zoomx zoomy . rotate (0 - (_cameraRot w) )
-             , onLayer MenuLayer menuScreen
+                                            . uncurry translate ((0,0) -.- _cameraPos w)
+          zoomx =  2 * _cameraZoom w / _windowX w
+          zoomy =  2 * _cameraZoom w / _windowY w
+          scaler = scale (2 / _windowX w) (2 / _windowY w)
+          decPicts      = IM.elems $ _decorations w
+          ptPicts       = map _ptPict (IM.elems (_particles w))
+          ptPicts'      = map _ptPict' $ _particles' w
+          afterPtPicts' = map _ptPict' $ _afterParticles' w
+          buttonPicts   = map btDraw (IM.elems (_buttons w))
+          ppPicts       = map ppDraw (IM.elems (_pressPlates w))
+          crPicts       = map crDraw $ IM.elems $ _creatures w
+          clPicts       = map clDraw $ IM.elems $ _clouds w
+          wallShadows   = map (drawWallShadow w) $ wallShadowsToDraw w
+          smokeShadows  = map (drawSmokeShadow w) $ _smoke w
+          wlPicts       = map drawWall (wallsToDraw w)
+          itFloorPicts  = map (drawItem) (IM.elems (_floorItems w))
+          yourPos = _crPos $ you w
+          yourRot = _crDir $ you w
+          yourRad = _crRad $ you w
+         -- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w)))
+         --                                       (map (_itFloorPict . _flIt) (IM.elems (_floorItems w)))
+          itLabels     = pictures $ map (drawItemName w) (IM.elems (_floorItems w))
+          ppLabels     = pictures $ map (drawPPText w) (IM.elems (_pressPlates w))
+          btLabels     = pictures $ map (drawButText w) (IM.elems (_buttons w))
+          menuScreen :: Picture
+          menuScreen = case _menuState w of
+                        InGame -> blank 
+                        LevelMenu x -> 
+                            pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w
+                            tst (-100) 100 0.4 ("LEVEL "++show x)
+                            ,controlsList
+                            ]
+                        PauseMenu   -> pictures 
+                                    [--color (withAlpha 0.5 black) $ polygon $ screenBox w
+                                    tst (-100) 100 0.4 "PAUSED"
+                                    ,tst (-100) 50 0.2 "n - new level"
+                                    ,tst (-100) 0 0.2 "r - restart"
+                                    , controlsList
+                                    ]
+                        GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
+                                    ,tst (-100) 100 0.4 "GAME OVER"
+                                    ,tst (-100) 50 0.2 "n - new level"
+                                    ,tst (-100) 0 0.2 "r - restart"
+                                    ,controlsList
+                                    ]
+                where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
+
+draw :: World -> Picture
+draw w
+    = case _mapDisplay w of
+         (True, z) -> scaler $ pictures [color white $ circleSolid 3
+                                ,scale z z $ rotate (0 - (_cameraRot w))
+                                    $ uncurry translate ((0,0) -.- _cameraCenter w) 
+                                    $ pictures $ mapMaybe mapWall $ IM.elems $ _walls w]
+         _ -> collectDrawings w
+    where yourPos = _crPos $ you w
+          f = scale (2/_windowX w) (2/_windowY w)
+          pathsTest = map drawPair $ _pathGraph' w
+          drawPair (x,y) = color cyan $ pictures [line [x,y]
+                           --         , uncurry translate x $ scale 0.05 0.05 $ text $ show x
+                                    ]
+          drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i
+          scaler = scale (2 / _windowX w) (2 / _windowY w)
+
+collectDrawings :: World -> Picture
+collectDrawings w = pictures $ (map screenShift $
+                                 concat
+                                 [ decPicts 
+                                 , ppPicts 
+                                 , itFloorPicts 
+                                 , crPicts
+                                 , clPicts
+                                 , buttonPicts 
+                                 , ptPicts 
+                                 , ptPicts'
+                                 , afterPtPicts'
+                                 , wlPicts
+                                 , wallShadows
+                                 , smokeShadows
+                                 ]) ++
+             [ scaler $ onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels]
+             , scaler $ hudDrawings w
+             , scaler $ onLayer MenuLayer menuScreen
              ]
 --                                <> [onLayer GloomLayer $ theLighting w]
     where
-          screenShift = scale zoom zoom . rotate (0 - (_cameraRot w) )
+          screenShift = scale zoomx zoomy . rotate (0 - (_cameraRot w) )
                                             . uncurry translate ((0,0) -.- _cameraPos w)
-          zoom     = _cameraZoom w
+          zoomx =  2 * _cameraZoom w / _windowX w
+          zoomy =  2 * _cameraZoom w / _windowY w
+          scaler = scale (2 / _windowX w) (2 / _windowY w)
           decPicts      = IM.elems $ _decorations w
           ptPicts       = map _ptPict (IM.elems (_particles w))
           ptPicts'      = map _ptPict' $ _particles' w
@@ -444,12 +505,12 @@ ringPict = onLayer LabelLayer $ dShadCol white $ pictures [line [(-8,10),(-15,10
 
 dShadCol :: Color -> Picture -> Picture
 dShadCol c p = pictures $
-                map (flip (uncurry translate) p) [(0.2,-0.2)
+                map (flip (uncurry translate) p) [--(0.2,-0.2)
-                                                 ,(0.4,-0.4)
+                                                 --,(0.4,-0.4)
-                                                 ,(0.6,-0.6)
+                                                 --,(0.6,-0.6)
-                                                 ,(0.8,-0.8)
+                                                 --,(0.8,-0.8)
-                                                 ,(  1,-  1)
+                                                 --,(  1,-  1)
-                                                 ,(1.2,-1.2)
+                                                 (1.2,-1.2)
                                                  ] ++ [color c p]
 
 dropShadow :: Picture -> Picture

src/Picture/Data.hs

@@ -54,6 +54,8 @@ data Picture
     | SetDepth Float Picture
     | Color RGBA Picture
     | Pictures [Picture]
+    | OverPos (Point3 -> Point3) (Float -> Float) Picture
+
 
 blank :: Picture
 {-# INLINE blank #-}

src/Picture/Preload.hs

@@ -19,13 +19,13 @@ import Shaders
 data RenderData = RenderData
     { --_charMap :: Image PixelRGBA8
       _textures :: [TextureObject]
-    , _basicShader :: Program
+    , _basicShader      :: (Program, [UniformLocation])
-    , _textShader :: Program
+    , _textShader       :: (Program, [UniformLocation])
-    , _circShader :: Program
+    , _circShader       :: (Program, [UniformLocation])
-    , _arcShader  :: Program
+    , _arcShader        :: (Program, [UniformLocation])
-    , _fadeCircleShader :: Program
+    , _fadeCircleShader :: (Program, [UniformLocation])
-    , _backShader :: Program
+    , _backShader       :: (Program, [UniformLocation])
-    , _wallShadowShader :: Program
+    , _wallShadowShader :: (Program, [UniformLocation])
     , _triVAO :: VAO
     , _lineVAO :: VAO
     , _textVAO :: VAO
@@ -37,12 +37,6 @@ data RenderData = RenderData
     , _posVBO :: BufferObject
     , _colVBO :: BufferObject
     , _texVBO :: BufferObject
-    , _uniWinSize :: UniformLocation
-    , _csZoomUni :: UniformLocation
-    , _asWinUni :: UniformLocation
-    , _asZoomUni :: UniformLocation
-    , _fcsWinUni  :: UniformLocation
-    , _fcsZoomUni :: UniformLocation
     , _wssLightPos :: UniformLocation
     , _dummyVBO :: BufferObject
     , _dummyPtr :: Ptr Float
@@ -103,21 +97,15 @@ bufferOffset = plusPtr nullPtr . fromIntegral
 preloadRender :: IO RenderData
 preloadRender = do
 -- compile shader programs
-    bs <- makeBasicShader
+    bs  <- makeSourcedShader "basic"      [VertexShader,FragmentShader]
-    ts <- makeTextureShader
+    ts  <- makeSourcedShader "character"  [VertexShader,GeometryShader,FragmentShader]
-    cs <- makeCircleShader
+    cs  <- makeSourcedShader "circle"     [VertexShader,GeometryShader,FragmentShader]
-    as <- makeArcShader
+    as  <- makeSourcedShader "arc"        [VertexShader,GeometryShader,FragmentShader]
-    fcs <- makeFadeShader
+    fcs <- makeSourcedShader "fadeCircle" [VertexShader,GeometryShader,FragmentShader]
-    bgs <- makeBackgroundShader
+    bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader]
-    wss <- makeWallShadowShader
+    wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader]
 
-    winSizeUni <- GL.uniformLocation cs "winSize"
+    wssLightPosUniLoc   <- GL.uniformLocation (fst wss) "lightPos"
-    zoomUni    <- GL.uniformLocation cs "zoom"
-    asWinSizeUniLoc <- GL.uniformLocation as "winSize"
-    asZoomUniLoc    <- GL.uniformLocation as "zoom"
-    wssLightPosUniLoc   <- GL.uniformLocation wss "lightPos"
-    fcsWinSizeUniLoc <- GL.uniformLocation fcs "winSize"
-    fcsZoomUniLoc    <- GL.uniformLocation fcs "zoom"
 -- get uniform locations
 
 --setup vbos
@@ -195,13 +183,7 @@ preloadRender = do
         , _texVBO = texVBO
         , _dummyVBO = dummyvbo
         , _dummyPtr = dummyptr
-        , _uniWinSize = winSizeUni
-        , _csZoomUni  = zoomUni
-        , _asWinUni = asWinSizeUniLoc
-        , _asZoomUni = asZoomUniLoc
         , _wssLightPos = wssLightPosUniLoc
-        , _fcsWinUni = fcsWinSizeUniLoc
-        , _fcsZoomUni = fcsZoomUniLoc
         }
 
 vaoPointers :: VAO -> [Ptr Float]

src/Picture/Render.hs

@@ -93,6 +93,36 @@ charToTuple :: Char -> (Point3,Point4,Point2)
 charToTuple c = ((0,0,0),white,(offset,100))
     where offset = fromIntegral (fromEnum c) - 32
 
+picToList :: Int -> Picture -> [RenderType]
+--{-# INLINE picToList #-}
+picToList x (Polygon i ps) 
+    | i == x = [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black]
+    | otherwise = []
+picToList x (PolygonCol i vs) 
+    | i /= x = []
+    | otherwise = 
+        let (ps,cs) = unzip vs
+        in  [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs]
+picToList x (Circle i r) 
+    | i == x = [RenderCirc $ ((0,0,0),black,r)]
+    | otherwise = []
+picToList x (ThickArc i startA endA rad wdth) 
+    | i == x = [RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))]
+    | otherwise = []
+picToList x (Line i ps) 
+    | i == x = [RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white]
+    | otherwise = []
+picToList x (Text i s) 
+    | i == x = [RenderText $ stringToList s]
+    | otherwise = []
+picToList j Blank = []
+picToList j (Scale x y pic) = fmap (scaleRen x y) $ picToList j pic
+picToList j (Translate x y pic) = fmap (translateRen x y) $ picToList j pic
+picToList j (Rotate a pic) = fmap (rotateRen a) $ picToList j pic
+picToList j (SetDepth a pic) = fmap (setDepthRen a) $ picToList j pic
+picToList j (Color c pic) = fmap (colorRen c) $ picToList j pic
+picToList j (Pictures pics) = concatMap (picToList j) pics
+
 --picToFTree :: Picture -> IM.IntMap (FTree RenderType)
 --{-# INLINE picToFTree #-}
 --picToFTree (Polygon i ps) = IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
@@ -113,7 +143,7 @@ charToTuple c = ((0,0,0),white,(offset,100))
 --picToFTree (Pictures pics) = fmap FBranches $ IM.unionsWith (++) $ map (fmap return . picToFTree) pics
 
 picToFTree :: Int -> Picture -> FTree RenderType
-{-# INLINE picToFTree #-}
+--{-# INLINE picToFTree #-}
 picToFTree x (Polygon i ps) 
     | i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
     | otherwise = FLeaf RenderBlank
@@ -135,13 +165,18 @@ picToFTree x (Text i s)
     | i == x = FLeaf $ RenderText $ stringToList s
     | otherwise = FLeaf RenderBlank
 picToFTree j Blank = FLeaf RenderBlank
-picToFTree j (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree j pic
+picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic
-picToFTree j (Translate x y pic) = FBranch (translateRen x y) $ picToFTree j pic
+picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic
-picToFTree j (Rotate a pic) = FBranch (rotateRen a) $ picToFTree j pic
+picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic
-picToFTree j (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree j pic
+picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
-picToFTree j (Color c pic) = FBranch (colorRen c) $ picToFTree j pic
+picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
 picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
 
+collapseBranch :: (RenderType -> RenderType) -> FTree RenderType -> FTree RenderType
+collapseBranch f (FBranch g t) = FBranch (f . g) t
+collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts
+collapseBranch f t = FBranch f t
+
 doubleLine :: [Point2] -> [Point2]
 doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
 doubleLine _ = []
@@ -276,6 +311,21 @@ renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
 renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
     depthFunc $= Just Lequal
 
+-- set common uniforms
+    forM_ [_basicShader      pdata
+          ,_textShader       pdata
+          ,_circShader       pdata
+          ,_arcShader        pdata
+          ,_fadeCircleShader pdata
+          ,_backShader       pdata
+          ,_wallShadowShader pdata
+          ] $ \shad -> do
+        currentProgram $= Just (fst shad)
+        uniform (snd shad !! 0)  $= Vector2 winx winy
+        uniform (snd shad !! 1)  $= zoom
+        uniform (snd shad !! 2)  $= rot
+        uniform (snd shad !! 3)  $= Vector2 tranx trany
+
 -- draw lightmap
     bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
     let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata
@@ -289,97 +339,32 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     forM_ lightPoints $ \(x,y,r,lum) -> do
         cullFace $= Just Front
         clear [DepthBuffer]
-        currentProgram $= Just (_wallShadowShader pdata)
+        currentProgram $= Just (fst $ _wallShadowShader pdata)
         bindArrayBuffers (length wallPoints) $ _vaoBufferTargets $ _wallVAO pdata
         bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
         uniform (_wssLightPos pdata)  $= Vector2 (x) (y)
         blendFunc $= (Zero,One)
         drawArrays Points (fromIntegral 0) (fromIntegral $ length wallPoints)
         cullFace $= Nothing
-        currentProgram $= Just (_fadeCircleShader pdata)
+        currentProgram $= Just (fst $ _fadeCircleShader pdata)
         bindVertexArrayObject $= Just (_vao $ _fadeCircVAO pdata)
         let fadeCircPtr = (\(_,ptr,_) -> ptr) $ head $ _vaoBufferTargets $ _fadeCircVAO pdata
         pokeFourOff fadeCircPtr 0 (x,y,r,lum)
         bindArrayBuffers (1) $ _vaoBufferTargets $ _fadeCircVAO pdata
-        uniform (_fcsWinUni pdata) $= Vector2 winx winy
-        uniform (_fcsZoomUni pdata)  $= zoom
-    -- to refactor: put these uniforms in a ubo
         blendFuncSeparate    $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
         drawArrays Points (fromIntegral 0) (fromIntegral 1)
-
 -- draw picture
 -- set drawing for on top
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
     clear [DepthBuffer]
-
 -- draw layer 0
-    renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic)
+    renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToList 0 pic)
-
 -- reset blend so that light map doesn't apply
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-
+    renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToList 1 pic
-    renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic
 -- set drawing for on top
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-
+    renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToList 2 pic
-    renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic
---
----- poke necessary data
---    (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) 
-----        <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)  
---        <- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)  
---                            (threePtrsVAO $ _textVAO pdata)
---                            (threePtrsVAO $ _circVAO pdata)
---                            (twoPtrsVAO $ _lineVAO pdata)
---                            (threePtrsVAO $ _arcVAO pdata)
---                   ) $ (picToFTree 0 pic)
---
---    depthFunc $= Just Less
---
---    currentProgram $= Just (_backShader pdata)
---    bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
---    let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
---        backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
---    pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
---    pokeTwoOff backPtr2 0  (winx,winy)
---    bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
---    textureBinding Texture2D $= Just (_textures pdata !! 1)
---    drawArrays Points (fromIntegral 0) (fromIntegral 1)
---
----- draw triangles
---    currentProgram $= Just (_basicShader pdata)
---    bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
---    bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
---    drawArrays Triangles 0 (fromIntegral $ nTriVs)
----- draw circles
---    currentProgram $= Just (_circShader pdata)
---    uniform (_uniWinSize pdata) $= Vector2 winx winy
---    uniform (_csZoomUni pdata)  $= zoom
---    bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
---    bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
---    drawArrays Points 0 (fromIntegral $ numCircVs)
----- draw arcs
---    currentProgram $= Just (_arcShader pdata)
---    uniform (_asWinUni pdata) $= Vector2 winx winy
---    uniform (_asZoomUni pdata)  $= zoom
---    bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
---    bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
---    drawArrays Points 0 (fromIntegral $ nArcVs)
---
----- reset blend so that light map doesn't apply
---    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
---
----- draw lines
---    currentProgram $= Just (_basicShader pdata)
---    bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
---    bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
---    drawArrays Lines 0 (fromIntegral $ nLineVs)
----- draw text
---    currentProgram $= Just (_textShader pdata)
---    bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
---    bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
---    textureBinding Texture2D $= Just (_textures pdata !! 0)
---    drawArrays Points 0 (fromIntegral $ nTextVs)
     
 
 bufferOffset :: Integral a => a -> Ptr b
@@ -388,8 +373,9 @@ bufferOffset = plusPtr nullPtr . fromIntegral
 
 -- the following code draws a picture tree
 -- it does not set nor change the blend function or depth buffer
-renderTree :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
+-- nor does it set uniforms
-                    -> FTree RenderType -> IO ()
+renderTree :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
+                    -> f RenderType -> IO ()
 renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
 
 -- poke necessary data
@@ -404,7 +390,7 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
 
     depthFunc $= Just Less
 
-    currentProgram $= Just (_backShader pdata)
+    currentProgram $= Just (fst $ _backShader pdata)
     bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
     let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
         backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
@@ -415,37 +401,29 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
     drawArrays Points (fromIntegral 0) (fromIntegral 1)
 
     depthFunc $= Just Lequal
-
 -- draw triangles
-    currentProgram $= Just (_basicShader pdata)
+    currentProgram $= Just (fst $ _basicShader pdata)
     bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
     bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
     drawArrays Triangles 0 (fromIntegral $ nTriVs)
 -- draw circles
-    currentProgram $= Just (_circShader pdata)
+    currentProgram $= Just (fst $ _circShader pdata)
-    uniform (_uniWinSize pdata) $= Vector2 winx winy
-    uniform (_csZoomUni pdata)  $= zoom
     bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
     bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
     drawArrays Points 0 (fromIntegral $ numCircVs)
 -- draw arcs
-    currentProgram $= Just (_arcShader pdata)
+-- assumes that the uniforms are set
-    uniform (_asWinUni pdata) $= Vector2 winx winy
+    currentProgram $= Just (fst $ _arcShader pdata)
-    uniform (_asZoomUni pdata)  $= zoom
     bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
     bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
     drawArrays Points 0 (fromIntegral $ nArcVs)
-
--- reset blend so that light map doesn't apply
---    blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-
 -- draw lines
-    currentProgram $= Just (_basicShader pdata)
+    currentProgram $= Just (fst $ _basicShader pdata)
     bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
     bindArrayBuffers nLineVs $ _vaoBufferTargets $ _lineVAO pdata
     drawArrays Lines 0 (fromIntegral $ nLineVs)
 -- draw text
-    currentProgram $= Just (_textShader pdata)
+    currentProgram $= Just (fst $ _textShader pdata)
     bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
     bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
     textureBinding Texture2D $= Just (_textures pdata !! 0)

src/Shaders.hs

@@ -7,13 +7,30 @@ module Shaders
     ,makeArcShader
     ,makeBackgroundShader
     ,makeWallShadowShader
+    ,makeSourcedShader
     )
     where
 import Graphics.Rendering.OpenGL
-import Control.Monad (when)
+import Control.Monad (when, forM)
 import Text.RawString.QQ
 import qualified Data.ByteString as BS
 
+-- compile shader and get its uniform locations
+-- supposes the shader code is in the shader folder, with the string names
+-- followed by .vert/.geom/.frag
+makeSourcedShader :: String -> [ShaderType] -> IO (Program, [UniformLocation])
+makeSourcedShader s sts = do
+    sources <- forM sts $ \st -> BS.readFile ("shader/" ++ s ++ shaderTypeExt st)
+    prog <- makeShaderProgram' s $ zip sts sources
+    uniformLocations <- forM ["winSize","zoom","rotation","translation"]
+                    $ \uniString -> uniformLocation prog uniString
+    return (prog,uniformLocations)
+
+shaderTypeExt :: ShaderType -> String
+shaderTypeExt VertexShader   = ".vert"
+shaderTypeExt GeometryShader = ".geom"
+shaderTypeExt FragmentShader = ".frag"
+
 makeBasicShader :: IO Program
 makeBasicShader = do
     vsSource <- BS.readFile "shader/basic.vert"
@@ -88,6 +105,21 @@ makeTextureShader = do
                       ,(FragmentShader, fsSource )
                       ]
 
+makeShaderProgram' :: String -> [(ShaderType,BS.ByteString)] -> IO Program
+makeShaderProgram' str sources = do
+    shaderProgram <- createProgram
+    shaders <- mapM (compileAndCheckShader' str) sources
+    mapM_ (attachShader shaderProgram) shaders
+
+    linkProgram shaderProgram
+    linkingSuccess <- linkStatus shaderProgram
+    when (not linkingSuccess) $ do
+        infoLog <- get (programInfoLog shaderProgram)
+        putStrLn $ str ++ ": Program Linking" ++ infoLog
+
+    return shaderProgram
+
+
 makeShaderProgram :: [(ShaderType,BS.ByteString)] -> IO Program
 makeShaderProgram sources = do
     shaderProgram <- createProgram
@@ -112,3 +144,14 @@ compileAndCheckShader (shaderType,sourceCode) = do
         infoLog <- get (shaderInfoLog theShader)
         putStrLn $ "Shader compile: " ++ show shaderType ++ " : " ++ show infoLog
     return theShader
+
+compileAndCheckShader' :: String -> (ShaderType,BS.ByteString) -> IO Shader
+compileAndCheckShader' str (shaderType,sourceCode) = do
+    theShader <- createShader shaderType
+    shaderSourceBS theShader $= sourceCode
+    compileShader theShader
+    success <- compileStatus theShader
+    when (not success) $ do
+        infoLog <- get (shaderInfoLog theShader)
+        putStrLn $ str ++ ": Shader compile: " ++ show shaderType ++ " : " ++ show infoLog
+    return theShader