justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Partially working ellipse shader

Browse Source
This commit is contained in:
jgk
2021-03-10 03:29:10 +01:00
parent bfbd0b6fef
commit cddf7d1f8f
12 changed files with 229 additions and 172 deletions
Download Patch File Download Diff File Expand all files Collapse all files
shader/circle.vert
+1 -1
View File
@@ -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
+26
View File
@@ -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
+45
View File
@@ -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
+19
View File
@@ -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
+14
View File
@@ -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
+1
View File
@@ -364,6 +364,7 @@ startCr = basicCreature
,teslaGun
,latchkey 0
,frontArmour
,miniGun
]
++ repeat NoItem))
-- startInv
src/Dodge/Rendering.hs
+3 -105
View File
@@ -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
+56 -45
View File
@@ -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')
src/Picture.hs
+5
View File
@@ -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
+2
View File
@@ -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
+14 -10
View File
@@ -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
src/Picture/Render.hs
+43 -11
View File
@@ -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)