Partially working ellipse shader

shader/circle.vert

@@ -13,7 +13,7 @@ uniform mat4 worldMat;
 
 void main()
 {
-  gl_Position = worldMat * vec4(position.xyz,1);
+  gl_Position = worldMat * vec4(position,1);
   vColor = color;
   vRad = rad;
 }

shader/ellipse.frag

@@ -0,0 +1,26 @@
+#version 430 core
+in vec4 gColor;
+in vec2 gFocusA;
+in vec2 gFocusB;
+in float gRad;
+
+out vec4 fColor;
+//out float gl_FragDepth;
+
+void main()
+{
+  vec2 pos = gl_FragCoord.xy;
+ // fColor = vec4( gColor.xyz , 0 );
+ // fColor = vec4( gColor.xyz , 1 - step(distance(pos,cenPos.xy),gRad) );
+ // fColor = vec4( gColor.xyz , distance(pos,cenPos.xy)/gRad );
+//  fColor = vec4( gColor.rgb, gColor.a * (1-step(gRad/2,distance(pos,cenPosT))) );
+  gl_FragDepth = max( gl_FragCoord.z 
+                    , step(gRad/2
+                          , distance(pos,gFocusA) + distance(gFocusA,gFocusB)
+                            //+ distance(pos,gFocusB)
+                          )
+                    );
+  fColor = gColor;
+//  fColor = vec4 (1,1,1,1);
+}
+//note it is the fragdepth that stops this from being square

shader/ellipse.geom

@@ -0,0 +1,45 @@
+#version 430 core
+layout (lines) in;
+layout (triangle_strip, max_vertices = 4) out;
+in vec4 vCol[];
+in float vRad[];
+out vec4 gColor;
+out float gRad;
+out vec2 gFocusA;
+out vec2 gFocusB;
+
+uniform vec2 winSize;
+uniform float zoom;
+
+void main()
+{
+  vec3 focusA = gl_in[0].gl_Position.xyz;
+  vec3 focusB = gl_in[1].gl_Position.xyz;
+  gColor = vCol[0];
+  gRad = vRad[0] * zoom * 2 ;
+
+  gFocusA = vec2 ( (focusA.x + 1) * 0.5 * winSize.x , (focusA.y + 1) * 0.5 * winSize.y);
+//  focusA = vec3 ( 0 , 0, focusA.z);
+  gFocusB = vec2 ( (focusB.x + 1) * 0.5 * winSize.x , (focusB.y + 1) * 0.5 * winSize.y);
+  float am = 0.5;
+
+  gl_Position = vec4 (focusA.x + gRad/winSize.x, focusA.y + gRad/winSize.y, focusA.z , 1);
+//  gl_Position = vec4 (focusA.x + am, focusA.y + am, -1 , 1);
+//  gl_Position = vec4 (focusA , 1);
+  EmitVertex();
+  gl_Position = vec4 (focusA.x - gRad/winSize.x, focusA.y + gRad/winSize.y, focusA.z , 1);
+//  gl_Position = vec4 (focusA.x - am, focusA.y + am, -1 , 1);
+//  gl_Position = vec4 (0 ,0.5 ,-1 , 1);
+//  gl_Position = vec4 (0 + gRad ,0 ,-1 , 1);
+  EmitVertex();
+  gl_Position = vec4 (focusA.x + gRad/winSize.x, focusA.y - gRad/winSize.y, focusA.z , 1);
+//  gl_Position = vec4 (focusA.x + am, focusA.y - am, -1 , 1);
+//  gl_Position = vec4 (0.5 ,0.5 ,-1 , 1);
+  EmitVertex();
+  gl_Position = vec4 (focusA.x - gRad/winSize.x, focusA.y - gRad/winSize.y, focusA.z , 1);
+//  gl_Position = vec4 (focusA.x - am, focusA.y - am, -1 , 1);
+//  gl_Position = vec4 (0.5 ,0 ,-1 , 1);
+  EmitVertex();
+
+  EndPrimitive();
+}

shader/ellipse.vert

@@ -0,0 +1,19 @@
+#version 430 core
+layout (location = 0) in vec3 position;
+layout (location = 1) in vec4 col;
+layout (location = 2) in float rad;
+out vec4 vCol;
+out float vRad;
+
+uniform vec2 winSize;
+uniform float zoom;
+uniform vec2 translation;
+uniform float rotation;
+uniform mat4 worldMat;
+
+void main()
+{
+  gl_Position = worldMat * vec4(position,1);
+  vRad = rad;
+  vCol = col;
+}

src/Dodge/Base.hs

@@ -21,6 +21,20 @@ import qualified Data.Set as S
 
 -- }}}
 --
+leftPad :: Int -> a -> [a] -> [a]
+leftPad i x xs = reverse $ take i $ reverse xs ++ repeat x
+
+rightPad :: Int -> a -> [a] -> [a]
+rightPad i x xs = take i $ xs ++ repeat x
+
+midPad :: Int -> a -> [a] -> [a] -> [a]
+midPad i x xs ys = xs ++ replicate j x ++ ys
+    where j = i - (length xs + length ys)
+
+midPadL :: Int -> a -> [a] -> [a] -> [a]
+midPadL i x xs ys = take j (xs ++ repeat x) ++ ys
+    where j = i - length ys
+
 you :: World -> Creature
 you w = _creatures w IM.! _yourID w
 

src/Dodge/Critters.hs

@@ -364,6 +364,7 @@ startCr = basicCreature
                             ,teslaGun
                             ,latchkey 0
                             ,frontArmour
+                            ,miniGun
                             ] 
                             ++ repeat NoItem)) 
                           -- startInv

src/Dodge/Rendering.hs

@@ -2,7 +2,9 @@ module Dodge.Rendering where
 -- imports {{{
 import Dodge.Data
 import Dodge.Base
-import Dodge.Inventory
+--import Dodge.Inventory
+
+import Dodge.Rendering.HUD
 
 import Geometry
 import Picture
@@ -14,7 +16,6 @@ import Control.Monad.State
 import Data.List
 import Data.Bifunctor
 
-
 import Data.Function
 import Control.Applicative
 import Control.Lens
@@ -56,109 +57,6 @@ fixedCoordPictures w = pictures
                                     ]
                 where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
 
-closeObjectTexts :: World -> Picture
-closeObjectTexts w = pictures $ (zipWith ren [0..] $ map toTs $ _closeActiveObjects w)
-                                ++ maybeToList maybeLine
-    where toTs (Left x)  = (_itInvColor $ _flIt x, _itName $ _flIt x)
-          toTs (Right x) = (white, _btText x)
-          ren i (c,t) = scale (2/_windowX w) (2/_windowY w)
-                        . tran
-                        . translate (xtran i) (0 - 20 * fromIntegral i)
-                        . scale 0.1 0.1 $ color c $ text t
-          tran = case freeSlot of
-                Just i -> translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral i +1))
-                Nothing -> translate (0.25*_windowX w) (0.25*_windowY w)
-          freeSlot = checkInvSlotsYou' (fmap _flIt mayIt) w
-          mayObj = listToMaybe $ _closeActiveObjects w
-          mayIt = mayObj >>= maybeLeft
-          maybeLeft (Left x) = Just x
-          maybeLeft _  = Nothing
-          pushout = 200
-          xtran 0 = case mayIt of Nothing -> 25
-                                  _       -> -25
-          xtran _ = 0
-          objPos obj = case obj of Left flit -> _flItPos flit
-                                   Right bt  -> _btPos bt
-          objText obj = case obj of Left flit -> _itName $ _flIt flit
-                                    Right bt  -> _btText bt
-          mayScreenPos = fmap objPos mayObj >>= (\thePos -> Just (sc $ rotateV (0 - _cameraRot w) $ _cameraZoom w *.* (thePos -.- _cameraPos w)))
-          sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
-          maybeLine = do 
-                itScreenPos <- mayScreenPos
-                theText <- fmap objText mayObj
-                let textWidth = 9 * fromIntegral (length theText)
-                let col = fromMaybe white $ fmap (_itInvColor . _flIt) mayIt
-                let p = case freeSlot of
-                      Just i -> ( textWidth + xtran 0 + pushout - halfWidth w
-                                , halfHeight w - 20* (fromIntegral i +1) + 2.5
-                                )
-                      Nothing -> ( 0.25*_windowX w
-                                 , 0.25*_windowY w
-                                 )
-                let p' = case freeSlot of
-                      Just i -> ( pushout - halfWidth w + 130
-                                , halfHeight w - 20* (fromIntegral i +1) + 2.5
-                                )
-                      Nothing -> ( 0.25*_windowX w
-                                 , 0.25*_windowY w
-                                 )
-                return $ lineCol 
-                            [(itScreenPos, withAlpha 0 col)
-                            ,(sc p'      , col)
-                            ,(sc p       , col)
-                            ]
-
-activeObjectText :: World -> Picture
-activeObjectText w = case closestActiveObject w of
-    Nothing -> Blank
-    Just (Right bt)  -> pictures 
-                            [ scale (2/_windowX w) (2/_windowY w) 
-                                    $ translate (0.35*_windowX w) (0.25*_windowY w)
-                                    $ scale 0.1 0.1 $ text $ _btText bt
-                            , lineCol [(p         , withAlpha 0 white)
-                                      ,((0.5,0.5) , white            )
-                                      ,((0.65,0.5), white            )
-                                      ]
-                            ]
-        where sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
-              p = sc $ rotateV (0 - _cameraRot w) $ _cameraZoom w *.* (_btPos bt -.- _cameraPos w)
-    Just (Left flit) 
-            -> pictures 
-                [ color col $ scale (2/_windowX w) (2/_windowY w) 
-                        $ t
-                        $ scale 0.1 0.1 $ text itText
-                , lineCol [(itScreenPos, withAlpha 0 col)
-                          ,(sc p'      , col)
-                          ,(sc p       , col)
-                          ]
-                ]
-        where sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
-              col = _itInvColor theIt
-              theIt = _flIt flit
-              itScreenPos = sc $ rotateV (0 - _cameraRot w) $ _cameraZoom w *.* (_flItPos flit -.- _cameraPos w)
-
-              freeSlot = checkInvSlotsYou theIt w
-              t = case freeSlot of
-                    Just i -> translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral i +1))
-                    Nothing -> translate (0.25*_windowX w) (0.25*_windowY w)
-              p = case freeSlot of
-                    Just i -> ( pushout - halfWidth w + textWidth
-                              , halfHeight w - 20* (fromIntegral i +1) + 2.5
-                              )
-                    Nothing -> ( 0.25*_windowX w
-                               , 0.25*_windowY w
-                               )
-              p' = case freeSlot of
-                    Just i -> ( pushout - halfWidth w + 130
-                              , halfHeight w - 20* (fromIntegral i +1) + 2.5
-                              )
-                    Nothing -> ( 0.25*_windowX w
-                               , 0.25*_windowY w
-                               )
-              itText = _itName $ _flIt flit
-              textWidth = 9 * fromIntegral (length itText)
-              pushout = 80
-
 
 worldPictures :: World -> Picture
 worldPictures w

src/Dodge/Weapons.hs

@@ -77,16 +77,14 @@ pistol = Weapon
     , _itInvColor = white
     }
 defaultGun = pistol
-defaultAutoGun = autoGun {_itScrollUp = const id, _itScrollDown = const id}
+defaultAutoGun = autoGun {_itScrollUp = const id
+                         , _itScrollDown = const id, _itInvDisplay = basicWeaponDisplay}
 basicWeaponDisplay :: Item -> String
-basicWeaponDisplay it = _itName it ++ " " ++ aIfLoaded ++ "/" ++ availableAmmo
+basicWeaponDisplay it = midPadL 10 ' ' (_itName it) (' ' : aIfLoaded)
+--basicWeaponDisplay it = rightPad 8 ' ' (_itName it) ++ leftPad 3 ' ' aIfLoaded 
+--                            ++ "/" ++ leftPad 3 ' ' availableAmmo
     where 
         availableAmmo = show $ _wpMaxAmmo it
---        availableAmmo = if _unlimitedAmmo w
---                        then show $ _wpMaxAmmo it
---                        else show $ case _crAmmo (you w) M.!? _wpAmmoType it of
---                                      Nothing -> 0
---                                      Just x  -> x
         aIfLoaded = case (_wpReloadState it) of 
                                0 -> show $ _wpLoadedAmmo it
                                x -> "R" ++ show x
@@ -102,7 +100,7 @@ autoEffectGun name eff = defaultAutoGun
     }
 
 autoGun = defaultGun 
-    { _itName = "AUTOGUN AUTO"
+    { _itName = "AUTOGUN"
     , _itIdentity = AutoGun
     , _wpMaxAmmo = 30
     , _wpLoadedAmmo = 30
@@ -127,7 +125,18 @@ autoGun = defaultGun
     , _itAttachment = Just $ ItMode 0
     , _itScrollUp = incMode
     , _itScrollDown = incMode
+    , _itInvDisplay = displayAutoGun
     }
+displayAutoGun :: Item -> String
+displayAutoGun it@(Weapon {_itAttachment = mayMode})
+        = midPadL 10 ' ' "AUTOGUN" (' ':aIfLoaded)  ++ (' ':phaseS)
+  where aIfLoaded = case (_wpReloadState it) of
+                        0 -> show $ _wpLoadedAmmo it
+                        x -> "R" ++ show x
+        phaseS = case mayMode of
+                    Just (ItMode 0) -> "M"
+                    Just (ItMode 1) -> "S"
+                    Just (ItMode 2) -> "B"
 autoFireMode = shootWithSound (fromIntegral autoGunSound) 
                    $ withRecoil 40
                    $ torqueBefore 0.05
@@ -143,12 +152,10 @@ incMode :: Int -> World -> World
 incMode _ w 
     = case newMode of
         0 -> w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode .~ 0
-               & creatures . ix 0 . crInv . ix itRef . itName .~ "AUTOGUN AUTO"
                & creatures . ix 0 . crInv . ix itRef . itHammer .~ NoHammer
                & creatures . ix 0 . crInv . ix itRef . itEffect .~ NoItEffect
                & creatures . ix 0 . crInv . ix itRef . wpFire .~ autoFireMode
         1 -> w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode .~ 1
-               & creatures . ix 0 . crInv . ix itRef . itName .~ "AUTOGUN SINGLE"
                & creatures . ix 0 . crInv . ix itRef . itHammer .~ HammerUp
                & creatures . ix 0 . crInv . ix itRef . itEffect .~ wpRecock
                & creatures . ix 0 . crInv . ix itRef . wpFire .~ singleFireMode
@@ -163,9 +170,9 @@ decMode _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . i
           oldMode = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itMode
           newMode = fromMaybe 1 $ fmap f oldMode
           f x = mod (x-1) 2
-          g 1 = " SINGLE"
+          g 1 = "-S"
-          g 2 = " BURST"
+          g 2 = "-B"
-          g 0 = " AUTO"
+          g 0 = "-A"
 
 rezGun = defaultGun
     { _itName = "REANIMATOR"
@@ -192,7 +199,7 @@ rezGun = defaultGun
                                             ]
     }
 teslaGun = defaultAutoGun 
-    { _itName = "TESLAGUN"
+    { _itName = "TESLA"
     , _itIdentity = TeslaGun
     , _wpMaxAmmo = 200
     , _wpLoadedAmmo = 200
@@ -239,39 +246,39 @@ lasGun = defaultAutoGun
     , _itAttachment = Just $ ItPhaseV 1
     , _itScrollUp = incPhaseV 
     , _itScrollDown = decPhaseV
+    , _itInvDisplay = displayLasGun
     }
+displayLasGun :: Item -> String
+displayLasGun it@(Weapon {_itAttachment = mayPhase})
+        = midPadL 10 ' ' "LASER" (' ':aIfLoaded)  ++ (' ':phaseS)
+  where aIfLoaded = case (_wpReloadState it) of
+                        0 -> show $ _wpLoadedAmmo it
+                        x -> "R" ++ show x
+        phaseS = case mayPhase of
+                    Just (ItPhaseV 0.2) -> "V"
+                    Just (ItPhaseV 1)   -> "/"
+                    Just (ItPhaseV 5)   -> "Z"
+
 incPhaseV :: Int -> World -> World
 incPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV %~ f
-                  & creatures . ix 0 . crInv . ix itRef . itName .~ "LASGUN" ++ g newPhaseV
     where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel
           oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV
           newPhaseV = fromMaybe 1 $ fmap f oldPhaseV
-          f 0.2 = 0.5
+          f 0.2 = 1
-          f 0.5 = 1
+          --f 0.5 = 1
-          f 1 = 2
+          f 1 = 5
-          f 2 = 5
+          --f 2 = 5
           f 5 = 5
-          g 0.2 = " //\\\\"
-          g 0.5 = " ///\\"
-          g 1 = " ////"
-          g 2 = " \\///"
-          g 5 = " \\\\//"
 decPhaseV :: Int -> World -> World
 decPhaseV _ w = w & creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV %~ f
-                  & creatures . ix 0 . crInv . ix itRef . itName .~ "LASGUN" ++ g newPhaseV
     where itRef = fromMaybe (-2) $ w ^? creatures . ix 0 . crInvSel
           oldPhaseV = w ^? creatures . ix 0 . crInv . ix itRef . itAttachment . _Just . itPhaseV
           newPhaseV = fromMaybe 1 $ fmap f oldPhaseV
           f 0.2 = 0.2
-          f 0.5 = 0.2
+          --f 0.5 = 0.2
-          f 1 = 0.5
+          f 1 = 0.2
-          f 2 = 1
+          --f 2 = 1
-          f 5 = 2
+          f 5 = 1
-          g 0.2 = " //\\\\"
-          g 0.5 = " ///\\"
-          g 1 = " ////"
-          g 2 = " \\///"
-          g 5 = " \\\\//"
 forceFieldGun = defaultGun 
     { _itName = "FORCEFIELD"
     , _itIdentity = ForceFieldGun
@@ -332,7 +339,7 @@ tractorGun = defaultAutoGun
     , _itEquipPict = drawWeapon $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ]
     }
 launcher = defaultGun 
-    { _itName = "LAUNCHER"
+    { _itName = "ROCKO"
     , _itIdentity = Launcher
     , _wpMaxAmmo = 30
     , _wpLoadedAmmo = 30
@@ -354,7 +361,7 @@ launcher = defaultGun
     , _itEffect = NoItEffect
     }
 remoteLauncher = defaultGun 
-    { _itName = "REMOTELAUNCHER"
+    { _itName = "ROCKO-REM"
     , _itIdentity = RemoteLauncher
     , _wpMaxAmmo = 1
     , _wpLoadedAmmo = 1
@@ -375,7 +382,7 @@ remoteLauncher = defaultGun
     , _itAttachment = Just $ ItScope (0,0) 0 1 True
     }
 hvAutoGun = defaultAutoGun 
-    { _itName = "HVMACHINEGUN"
+    { _itName = "AUTO-HV"
     , _itIdentity = HvAutoGun
     , _wpMaxAmmo = 100
     , _wpLoadedAmmo = 100
@@ -402,7 +409,7 @@ hvAutoGun = defaultAutoGun
                                         hvBulHitCr' hvBulHitWall' bulHitFF'
                             
 ltAutoGun = defaultAutoGun 
-    { _itName = "AUTOPISTOL"
+    { _itName = "AUTO-LT"
     , _itIdentity = LtAutoGun
     , _wpMaxAmmo = 25
     , _wpLoadedAmmo = 25
@@ -427,7 +434,7 @@ ltAutoGun = defaultAutoGun
                                                          ]    
     }
 miniGun = defaultAutoGun 
-    { _itName = "MINIGUN"
+    { _itName = "MINI-G"
     , _itIdentity = MiniGun
     , _wpMaxAmmo = 150
     , _wpLoadedAmmo = 150
@@ -448,7 +455,7 @@ miniGun = defaultAutoGun
     , _itEquipPict = drawWeapon $ color red $ polygon $ rectNESW 9 5 (-9) (-5)
     }
 spreadGun = defaultGun 
-    { _itName = "SPREADGUN"
+    { _itName = "SPREAD"
     , _itIdentity = SpreadGun
     , _wpMaxAmmo = 5
     , _wpLoadedAmmo = 5
@@ -523,7 +530,7 @@ multGun = defaultGun
                                            , polygon [(-1.5,12),(-2,12),(-2,-12),(-1.5,-12)]
                                            ]
 longGun = defaultGun 
-    { _itName = "ELEPHANTGUN"
+    { _itName = "LONGGUN"
     , _itIdentity = LongGun
     , _wpMaxAmmo = 1
     , _wpLoadedAmmo = 1
@@ -564,7 +571,7 @@ startZoomOutLongGun  _ w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatu
 
 
 poisonSprayer = defaultAutoGun 
-    { _itName = "POISONSPRAY"
+    { _itName = "POISON"
     , _itIdentity = PoisonSprayer
     , _wpMaxAmmo = 500
     , _wpLoadedAmmo = 500
@@ -1026,9 +1033,13 @@ moveFlame rotd w pt =
                                               $ scale scaleChange 1
                                              -- $ color white
                                              -- $ circleSolid 5
-                                              $ pictures $ reverse [color white $ circleSolid 4
+--                                              $ pictures $ reverse [color white $ circleSolid 4
-                                                         ,color (withAlpha 0.5 white) $ circleSolid 5
+                                              $ pictures $ reverse 
-                                                         ]
+                                                        [color red $ ellipseSolid (0,-2) (0,2) 6
+                                                        --,color white $ ellipseSolid (2,0) (-2,0) 6
+                                                        --,color white $ ellipseSolid (2,0) (-2,0) 6
+                                                        ,color (withAlpha 0.5 white) $ circleSolid 5
+                                                        ]
                                             --  $ rotate (radToDeg (fromIntegral time * 10))
                                             --  $ polygon [(-5,-2),(5,-2),(5,2),(-5,2)]
                 pi2 p' = setLayer 1 $ onLayerL [levLayer UPtLayer,4] $ uncurry translate (prot p')

src/Picture.hs

@@ -10,6 +10,7 @@ module Picture
     , thickCircle
     , circleSolid
     , circle
+    , ellipseSolid
     , line
     , lineCol
     , text
@@ -118,6 +119,10 @@ makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
     where as = [a,a+step.. b]
           step = pi * 0.2
 
+ellipseSolid :: Point2 -> Point2 -> Float -> Picture
+{-# INLINE ellipseSolid #-}
+ellipseSolid = Ellipse 0
+
 circleSolid :: Float -> Picture
 {-# INLINE circleSolid #-}
 --circleSolid rad = polygon $ makeArc rad (0,2*pi)

src/Picture/Data.hs

@@ -61,6 +61,7 @@ data RenderType
     | RenderCirc (Point3,Point4,Float)
     | RenderArc  (Point3,Point4,Point4)
     | RenderLine [(Point3,Point4)]
+    | RenderEllipse [(Point3,Point4,Float)]
 
 data Picture
     = Blank
@@ -68,6 +69,7 @@ data Picture
     | Polygon Int [Point2]
     | PolygonCol Int [(Point2,RGBA)]
     | Circle Int Float
+    | Ellipse Int Point2 Point2 Float
     | ThickArc Int Float Float Float Float
     | Line Int [Point2]
     | LineCol Int [(Point2,RGBA)]

src/Picture/Preload.hs

@@ -22,6 +22,7 @@ data RenderData = RenderData
     , _basicShader      :: (Program, [UniformLocation])
     , _textShader       :: (Program, [UniformLocation])
     , _circShader       :: (Program, [UniformLocation])
+    , _ellipseShader    :: (Program, [UniformLocation])
     , _arcShader        :: (Program, [UniformLocation])
     , _lightmapCircleShader :: (Program, [UniformLocation])
     , _backShader       :: (Program, [UniformLocation])
@@ -30,6 +31,7 @@ data RenderData = RenderData
     , _lineVAO :: VAO
     , _textVAO :: VAO
     , _circVAO :: VAO
+    , _ellipseVAO :: VAO
     , _arcVAO  :: VAO
     , _backVAO :: VAO
     , _wallVAO :: VAO
@@ -103,6 +105,7 @@ preloadRender = do
     fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader]
     bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader]
     wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader]
+    es  <- makeSourcedShader "ellipse"     [VertexShader,GeometryShader,FragmentShader]
 
     wssLightPosUniLoc   <- GL.uniformLocation (fst wss) "lightPos"
 
@@ -145,16 +148,15 @@ preloadRender = do
 
 -- input a list of (attribute location, attrib length) pairs
 -- these will have buffers and pointers created
-    trivao  <- setupVAO [(0,3),(1,4)]
+    trivao        <- setupVAO [(0,3),(1,4)]
-    linevao <- setupVAO [(0,3),(1,4)]
+    linevao       <- setupVAO [(0,3),(1,4)]
-    textvao <- setupVAO [(0,3),(1,4),(2,3)]
+    textvao       <- setupVAO [(0,3),(1,4),(2,3)]
-    circvao <- setupVAO [(0,3),(1,4),(2,1)]
+    circvao       <- setupVAO [(0,3),(1,4),(2,1)]
-    arcvao  <- setupVAO [(0,3),(1,4),(2,4)]
+    ellipsevao    <- setupVAO [(0,3),(1,4),(2,1)]
-    backgroundvao 
+    arcvao        <- setupVAO [(0,3),(1,4),(2,4)]
-            <- setupVAO [(0,4),(1,2)]
+    backgroundvao <- setupVAO [(0,4),(1,2)]
-    wallvao <- setupVAO [(0,4),(1,4)]
+    wallvao       <- setupVAO [(0,4),(1,4)]
-    fadecircvao 
+    fadecircvao   <- setupVAO [(0,4)]
-            <- setupVAO [(0,4)]
     
     return $ RenderData
         { -- _charMap      = convertRGBA8 cmap
@@ -162,6 +164,7 @@ preloadRender = do
         ,_basicShader  = bs
         , _textShader   = ts
         , _circShader = cs
+        , _ellipseShader = es
         , _arcShader = as
         , _lightmapCircleShader = fcs
         , _backShader = bgs
@@ -169,6 +172,7 @@ preloadRender = do
         , _triVAO  = trivao
         , _textVAO = textvao
         , _circVAO = circvao
+        , _ellipseVAO = ellipsevao
         , _arcVAO  = arcvao
         , _lineVAO = linevao
         , _backVAO = backgroundvao

src/Picture/Render.hs

@@ -63,6 +63,7 @@ overPos :: (Point3 -> Point3) -> RenderType -> RenderType
 overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
 overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
 overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
+overPos f (RenderEllipse vs) = RenderEllipse $ map (\(a,b,c) -> (f a,b,c)) vs
 overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
 overPos f (RenderArc (a,b,c))  = RenderArc (f a,b,c)
 
@@ -73,11 +74,12 @@ overRot _ ren = ren
 
 overCol :: (Point4 -> Point4) -> RenderType -> RenderType
 {-# INLINE overCol #-}
-overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
+overCol f (RenderPoly vs)      = RenderPoly $ map (second $ f) vs
-overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs
+overCol f (RenderLine vs)      = RenderLine $ map (second $ f) vs
-overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
+overCol f (RenderText vs)      = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
+overCol f (RenderEllipse vs)   = RenderEllipse $ map (\(a,b,c) -> (a,f b,c)) vs
 overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
-overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
+overCol f (RenderArc (a,b,c))   = RenderArc (a,f b,c)
 
 overSca :: (Point2 -> Point2) -> RenderType -> RenderType
 {-# INLINE overSca #-}
@@ -129,6 +131,9 @@ picToAlt x (PolygonCol i vs)
 picToAlt x (Circle i r) 
     | i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
     | otherwise = Ap.empty
+picToAlt x (Ellipse i pa pb r) 
+    | i == x = Ap.pure $ RenderEllipse [(zeroZ pa,black,r),(zeroZ pb,black,r)]
+    | otherwise = Ap.empty
 picToAlt x (ThickArc i startA endA rad wdth) 
     | i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
     | otherwise = Ap.empty
@@ -160,6 +165,9 @@ picToLTree mx (PolygonCol i vs)
 picToLTree mx (Circle i r) 
     | Just i == mx || Nothing == mx = LLeaf $ RenderCirc $ ((0,0,0),black,r)
     | otherwise = LBranches []
+picToLTree mx (Ellipse i pa pb r) 
+    | Just i == mx || Nothing == mx = LLeaf $ RenderEllipse [(zeroZ pa,black,r),(zeroZ pb,black,r)]
+    | otherwise = LBranches []
 picToLTree mx (ThickArc i startA endA rad wdth) 
     | Just i == mx || Nothing == mx = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
     | otherwise = LBranches []
@@ -194,13 +202,15 @@ theFold :: TwoPtrs
         -> ThreePtrs
         -> TwoPtrs
         -> ThreePtrs
-        -> F.FoldM IO RenderType (Int,Int,Int,Int,Int)
+        -> ThreePtrs
-theFold pas pbs pcs pds pes 
+        -> F.FoldM IO RenderType (Int,Int,Int,Int,Int,Int)
-    = (,,,,) <$> pokeTwoPtrsWith pokePoly pas 
+theFold pas pbs pcs pds pes pfs
+    = (,,,,,) <$> pokeTwoPtrsWith pokePoly pas 
              <*> pokeThreePtrsWith pokeText pbs 
              <*> pokeThreePtrsWith pokeCirc pcs
              <*> pokeTwoPtrsWith pokeLine pds
              <*> pokeThreePtrsWith pokeArc pes
+             <*> pokeThreePtrsWith pokeEllipse pfs
 
 type ThreePtrs = (Ptr Float,Ptr Float,Ptr Float)
 type TwoPtrs = (Ptr Float,Ptr Float)
@@ -225,6 +235,21 @@ pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
         return $ n + 1
 pokeArc _ n _ = return n
 
+pokeEllipse:: ThreePtrs -> Int -> RenderType -> IO Int
+{-# INLINE pokeEllipse #-}
+pokeEllipse ptrs n (RenderEllipse vs) = foldM (pokeEllipseVert ptrs) n vs
+pokeEllipse _    n _ = return n
+
+pokeEllipseVert :: ThreePtrs -> Int -> (Point3,Point4,Float) -> IO Int
+{-# INLINE pokeEllipseVert #-}
+pokeEllipseVert (pa,pb,pc) n (p,c,s)
+    | n > 20000 * 2 = return n
+    | otherwise = do
+        pokeThreeOff pa n p
+        pokeFourOff  pb n c
+        pokeElemOff  pc n s
+        return $ n + 1
+
 pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
 {-# INLINE pokeTwoOff #-}
 pokeTwoOff ptr n (x,y) = do
@@ -364,6 +389,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
           ,_textShader       pdata
           ,_circShader       pdata
           ,_arcShader        pdata
+          ,_ellipseShader    pdata
           ,_lightmapCircleShader pdata
           ,_backShader       pdata
           ,_wallShadowShader pdata
@@ -437,6 +463,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
           ,_textShader       pdata
           ,_circShader       pdata
           ,_arcShader        pdata
+          ,_ellipseShader    pdata
           ] $ \shad -> do
         currentProgram $= Just (fst shad)
         uniform (snd shad !! 0)  $= Vector2 (2::Float) 2
@@ -464,13 +491,14 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
 
     pokeStartTicks <- SDL.ticks
 -- poke necessary data
-    (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) 
+    (nTriVs,nTextVs,nCircVs,nLineVs,nArcVs,nEllVs) 
 --        <- 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)
+                            (threePtrsVAO $ _ellipseVAO pdata)
                    ) $ tree
 
     pokeEndTicks <-SDL.ticks
@@ -480,10 +508,11 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
 -- before it performs another state change
     bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
     bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
-    bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
+    bindArrayBuffers nCircVs $ _vaoBufferTargets $ _circVAO pdata
     bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
     bindArrayBuffers nLineVs $ _vaoBufferTargets $ _lineVAO pdata
     bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
+    bindArrayBuffers nEllVs $ _vaoBufferTargets $ _ellipseVAO pdata
 
     depthFunc $= Just Less
 
@@ -505,9 +534,12 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
 -- draw circles
     currentProgram $= Just (fst $ _circShader pdata)
     bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
-    drawArrays Points 0 (fromIntegral $ numCircVs)
+    drawArrays Points 0 (fromIntegral $ nCircVs)
+-- draw ellipses
+    currentProgram $= Just (fst $ _ellipseShader pdata)
+    bindVertexArrayObject $= Just (_vao $ _ellipseVAO pdata)
+    drawArrays Lines 0 (fromIntegral $ nEllVs)
 -- draw arcs
--- assumes that the uniforms are set
     currentProgram $= Just (fst $ _arcShader pdata)
     bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
     drawArrays Points 0 (fromIntegral $ nArcVs)