diff --git a/shader/circle.vert b/shader/circle.vert index 29925a3c7..e7e584a65 100644 --- a/shader/circle.vert +++ b/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; } diff --git a/shader/ellipse.frag b/shader/ellipse.frag new file mode 100644 index 000000000..4ac39054b --- /dev/null +++ b/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 diff --git a/shader/ellipse.geom b/shader/ellipse.geom new file mode 100644 index 000000000..b72964605 --- /dev/null +++ b/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(); +} diff --git a/shader/ellipse.vert b/shader/ellipse.vert new file mode 100644 index 000000000..4206967cd --- /dev/null +++ b/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; +} diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index efa15d275..d8a0ab851 100644 --- a/src/Dodge/Base.hs +++ b/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 diff --git a/src/Dodge/Critters.hs b/src/Dodge/Critters.hs index f505eb204..20e949822 100644 --- a/src/Dodge/Critters.hs +++ b/src/Dodge/Critters.hs @@ -364,6 +364,7 @@ startCr = basicCreature ,teslaGun ,latchkey 0 ,frontArmour + ,miniGun ] ++ repeat NoItem)) -- startInv diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index d61b188aa..8e67c3085 100644 --- a/src/Dodge/Rendering.hs +++ b/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 diff --git a/src/Dodge/Weapons.hs b/src/Dodge/Weapons.hs index 06f966a45..67e5bdb9f 100644 --- a/src/Dodge/Weapons.hs +++ b/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 2 = " BURST" - g 0 = " AUTO" + g 1 = "-S" + g 2 = "-B" + 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.5 = 1 - f 1 = 2 - f 2 = 5 + f 0.2 = 1 + --f 0.5 = 1 + f 1 = 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 1 = 0.5 - f 2 = 1 - f 5 = 2 - g 0.2 = " //\\\\" - g 0.5 = " ///\\" - g 1 = " ////" - g 2 = " \\///" - g 5 = " \\\\//" + --f 0.5 = 0.2 + f 1 = 0.2 + --f 2 = 1 + f 5 = 1 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 - ,color (withAlpha 0.5 white) $ circleSolid 5 - ] +-- $ pictures $ reverse [color white $ circleSolid 4 + $ 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') diff --git a/src/Picture.hs b/src/Picture.hs index ea31e11f4..748243911 100644 --- a/src/Picture.hs +++ b/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) diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index b1ebad6f0..5fd655512 100644 --- a/src/Picture/Data.hs +++ b/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)] diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index fdb50643b..e5a40c888 100644 --- a/src/Picture/Preload.hs +++ b/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)] - linevao <- setupVAO [(0,3),(1,4)] - textvao <- setupVAO [(0,3),(1,4),(2,3)] - circvao <- setupVAO [(0,3),(1,4),(2,1)] - arcvao <- setupVAO [(0,3),(1,4),(2,4)] - backgroundvao - <- setupVAO [(0,4),(1,2)] - wallvao <- setupVAO [(0,4),(1,4)] - fadecircvao - <- setupVAO [(0,4)] + trivao <- setupVAO [(0,3),(1,4)] + linevao <- setupVAO [(0,3),(1,4)] + textvao <- setupVAO [(0,3),(1,4),(2,3)] + circvao <- setupVAO [(0,3),(1,4),(2,1)] + ellipsevao <- setupVAO [(0,3),(1,4),(2,1)] + arcvao <- setupVAO [(0,3),(1,4),(2,4)] + backgroundvao <- setupVAO [(0,4),(1,2)] + wallvao <- setupVAO [(0,4),(1,4)] + fadecircvao <- 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 diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index f02c3af51..45ab2bf88 100644 --- a/src/Picture/Render.hs +++ b/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 (RenderLine vs) = RenderLine $ map (second $ f) vs -overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs +overCol f (RenderPoly vs) = RenderPoly $ 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 (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) -theFold pas pbs pcs pds pes - = (,,,,) <$> pokeTwoPtrsWith pokePoly pas + -> ThreePtrs + -> F.FoldM IO RenderType (Int,Int,Int,Int,Int,Int) +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)