Implement arcs with variable width and color

shader/dualTwoD/arc.frag

@@ -7,7 +7,7 @@ layout (location=1) out vec4 fPos;
 void main()
 {
   float d = (dot(vec2(vparams.xy),vec2(vparams.xy)));
-  if ( d > 1 || d < vparams.z ) {discard;}
+  if ( d > 1 || d < (vparams.z * vparams.z) ) {discard;}
   fCol = vCol;
   fPos = vec4(vPos,1);
 }

shader/dualTwoD/arc.geom

@@ -1,37 +0,0 @@
-#version 430 core
-layout (points) in;
-layout (triangle_strip, max_vertices = 4) out;
-in vec4 vColor [];
-in vec4 vparams [];
-out vec4 gColor;
-out float gRadIn;
-out vec2 angles;
-out vec2 dist;
-
-uniform mat4 worldMat;
-
-void main()
-{
-  angles = vparams[0].xy;
-  vec4 cenPos = gl_in[0].gl_Position;
-  gColor = vColor[0];
-  float width = vparams[0].w ;
-  float rad = vparams[0].z + width;
-  gRadIn  = 1 - width * 2 / rad;
-  // I am not currently sure why the multiplicand is 4 and not 2
-
-  gl_Position = worldMat * vec4 (cenPos.x + rad, cenPos.y + rad, cenPos.z , 1);
-  dist = vec2 (1,1);
-  EmitVertex();
-  gl_Position = worldMat * vec4 (cenPos.x - rad, cenPos.y + rad, cenPos.z , 1);
-  dist = vec2 (-1,1);
-  EmitVertex();
-  gl_Position = worldMat * vec4 (cenPos.x + rad, cenPos.y - rad, cenPos.z , 1);
-  dist = vec2 (1,-1);
-  EmitVertex();
-  gl_Position = worldMat * vec4 (cenPos.x - rad, cenPos.y - rad, cenPos.z , 1);
-  dist = vec2 (-1,-1);
-  EmitVertex();
-
-  EndPrimitive();
-}

src/Dodge/Data/Input.hs

@@ -37,6 +37,7 @@ data Input = Input
     , _rSelect :: Point2
     , _clickMousePos :: Point2
     , _textInput :: T.Text
+    , _scrollTestValue :: Float
     }
 
 data WorldHammer

src/Dodge/Default/World.hs

@@ -27,6 +27,7 @@ defaultInput =
         , _rLine = (0, 0)
         , _lSelect = 0
         , _rSelect = 0
+        , _scrollTestValue = 1
         }
 
 defaultWorld :: World

src/Dodge/Render/ShapePicture.hs

@@ -2,10 +2,12 @@ module Dodge.Render.ShapePicture (
     worldSPic,
 ) where
 
+import Picture.Test
 import Dodge.Viewpoints
 import Dodge.Render.Label
 import Dodge.WorldEvent.ThingsHit
 import Control.Lens
+--import Control.Monad (guard)
 import Data.Foldable
 import qualified Data.Graph.Inductive as FGL
 import qualified Data.Map.Strict as M
@@ -53,12 +55,46 @@ worldSPic cfig w =
         <> foldup floorItemSPic (filtOn _flItPos _floorItems)
         <> foldup btSPic (filtOn _btPos _buttons)
         <> foldup mcSPic (filtOn _mcPos _machines)
+        <> aimDelaySweep cfig w
         <> anyTargeting cfig w
   where
     foldup = foldMap'
     filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
     pointIsClose = cullPoint cfig w
 
+aimDelaySweep :: Configuration -> World -> SPic
+aimDelaySweep cfig w = fromMaybe mempty $ do
+    cr <- w ^? cWorld . lWorld . creatures . ix 0
+--    aimstatus <- cr ^? crStance . posture
+--    guard (aimstatus == Aiming)
+    return $ noShape $ drawSweep cr cfig w
+
+drawSweep :: Creature -> Configuration -> World -> Picture
+drawSweep cr cfig w = fromMaybe mempty $ do
+    --a <- safeArgV (mwp -.- p)
+    return $ winScale cfig
+        $ setLayer FixedCoordLayer
+        $ uncurryV translate (worldPosToScreen campos p) 
+        -- $ thickArcFull (rot + a) 1 white (rot + _crDir cr) 1 white (dist mwp p * campos ^. camZoom)
+--        $ arc (rot + a) (rot + _crDir cr) (dist mwp p * campos ^. camZoom)
+        $ color white (circle 100)
+           -- <> arcTest (3*pi/4) 100 green 0 1 red 100
+            <> arcTest 0 5 green (3*pi/4) 50 red 100 white
+            -- <> f green 0 (pi/2) 100
+--            <> f red 2 3 100
+            <> f blue 4 4.5 100 white
+          --  <> f 0 2 120 <> f 0 3 140 <> f 0 4 160 <> f 1 0 180 <> f 2 0 200 
+          --  <> f 3 0 220 <> f 4 0 240
+          --  <> f (-0.5) 0.5 260 <> f 0.5 (-0.5) 280
+  where
+    f col a b c = arcTest a 25 col b 1 red c
+    --f a b c = thickArc a b c 5
+    --rot = campos ^. camRot
+    p = _crPos cr
+    campos = w ^. cWorld . camPos
+    --theinput = w ^. input
+    --mwp = mouseWorldPos theinput campos
+
 anyTargeting :: Configuration -> World -> SPic
 anyTargeting cfig w = fromMaybe mempty $ do
     tt <- cr ^? crTargeting . ctType . _Just

src/Dodge/ScrollValue.hs

@@ -0,0 +1,9 @@
+module Dodge.ScrollValue where
+
+import Dodge.Data.Input
+import LensHelp
+
+updateScrollTestValue :: Input -> Input
+updateScrollTestValue theinput = theinput & scrollTestValue +~ theamount
+  where
+    theamount = fromIntegral (theinput ^. scrollAmount) / 100

src/Dodge/TestString.hs

@@ -1,6 +1,5 @@
 module Dodge.TestString where
 
-import Dodge.Base.You
 import Control.Lens
 import Dodge.Data.Universe
 --import Data.Maybe
@@ -9,10 +8,8 @@ import Dodge.Data.Universe
 --import qualified IntMapHelp as IM
 testStringInit :: Universe -> [String]
 testStringInit u = 
-    [ show $ ycr ^?! crInvSel . iselAction
+    [ show $ u ^. uvWorld . input . scrollTestValue
     ]
-  where
-    ycr = you (u ^. uvWorld)
 
 showTimeFlow :: TimeFlowStatus -> String
 showTimeFlow tfs = case tfs of

src/Dodge/Update.hs

@@ -6,6 +6,7 @@ Description : Simulation update
 -}
 module Dodge.Update (updateUniverse) where
 
+import Dodge.ScrollValue
 import Color
 import Control.Applicative
 import Data.List
@@ -74,6 +75,7 @@ updateUniverse u =
         . updateUniverseMid
         . updateUseInput
         . over uvWorld (updateCamera cfig)
+        . over (uvWorld . input) updateScrollTestValue
         . over (uvWorld . cWorld . cClock) (+ 1)
         $ u
   where

src/Geometry.hs

@@ -110,6 +110,7 @@ cylinderOnSeg :: Point3 -> Point3 -> Point3 -> Float -> Bool
 cylinderOnSeg = undefined
 -- | Find the difference between two Nums.
 difference :: (Ord a, Num a) => a -> a -> a
+{-# INLINE difference #-}
 difference x y 
     | x > y     = x - y
     | otherwise = y - x

src/Picture/Base.hs

@@ -15,6 +15,7 @@ module Picture.Base (
     arc,
     arcSolid,
     thickArc,
+    thickArcFull,
     thickCircle,
     thickLine,
     lineThick,
@@ -153,7 +154,7 @@ extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) =
 
 color :: RGBA -> Picture -> Picture
 {-# INLINE color #-}
-color c = picMap $ overCol (const c)
+color = picMap . overCol . const
 
 translateH :: Float -> Float -> Point3 -> Point3
 {-# INLINE translateH #-}
@@ -326,6 +327,27 @@ arc ::
 arc startA endA rad = thickArc startA endA rad 1
 {-# INLINE arc #-}
 
+thickArcFull :: Float -> Float -> Color -> Float -> Float -> Color -> Float -> Picture
+{-# INLINE thickArcFull #-}
+thickArcFull sa sw sc ea ew ec rad 
+    | difference sa ea > pi / 2 = thickArcFull sa sw sc ma mw mc rad <> thickArcFull ma mw mc ea ew ec rad
+    | otherwise = map f
+            [ (V3 0 0 0, mc, V3 0 0 mw)
+            , (V3 xa ya 0, sc, V3 1 0 sw)
+            , (V3 xb yb 0, mc, V3 1 1 mw)
+            , (V3 0 0 0, sc, V3 0 0 sw)
+            , (V3 xb yb 0, mc, V3 1 1 mw)
+            , (V3 xc yc 0, ec, V3 0 1 ew)
+            ]
+  where
+    (V2 xa ya) = rotateV sa (V2 rad 0)
+    (V2 xb yb) = rotateV (0.5 * (sa + ea)) (V2 (rad * sqrt 2) 0)
+    (V2 xc yc) = rotateV ea (V2 rad 0)
+    f (pos, col, V3 a b c) = Verx pos col [a, b, c] BottomLayer arcNum
+    ma = 0.5 * (sa + ea)
+    mw = 0.5 * (sw + ew)
+    mc = mixColors 0.5 0.5 sc ec
+
 thickArc :: Float -> Float -> Float -> Float -> Picture
 {-# INLINE thickArc #-}
 thickArc startA endA rad wdth
@@ -355,7 +377,6 @@ thickArcHelp startA endA rad wdth =
   where
     (V2 xa ya) = rotateV startA (V2 rad 0)
     (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0)
-    --(V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * 2) 0)
     (V2 xc yc) = rotateV endA (V2 rad 0)
     f (pos, col, V3 a b c) = Verx pos col [a, b, c] BottomLayer arcNum
 

src/Picture/Test.hs

@@ -0,0 +1,41 @@
+module Picture.Test where
+
+import Picture.Data
+import Geometry
+import Color
+
+arcTest :: Float -> Float -> Color -> Float -> Float -> Color -> Float -> Color -> Picture
+arcTest startA sw sc endA ew ec r centercol
+    | abs (difference startA endA) > pi / 2 = arcTest startA sw sc midA mw mc r centercol
+        <> arcTest midA mw mc endA ew ec r centercol
+    | otherwise = arcTest' startA sw sc endA ew ec r centercol
+  where
+    midA = 0.5 * (startA + endA)
+    mw = 0.5 * (sw + ew)
+    mc = mixColors 0.5 0.5 sc ec
+
+arcTest' :: Float -> Float -> Color -> Float -> Float -> Color -> Float -> Color -> Picture
+arcTest' startA sw sc endA ew ec r centercol =
+        map
+            f
+            [ (V3 0 0 0, centercol, V3 0 0 mwdth)
+            , (V3 xa ya 0, sc, V3 ad op wdth)
+            , (V3 xb yb 0, mc, V3 1 1 mwdth)
+            , (V3 0 0 0, centercol, V3 0 0 mwdth)
+            , (V3 xb yb 0, mc, V3 1 1 mwdth)
+            , (V3 xc yc 0, ec, V3 ad op ewdth)
+            ]
+  where
+    mc = mixColors 0.5 0.5 sc ec
+    ang = endA - startA
+    op = sin ((pi/2 - ang)/2)
+    ad = cos ((pi/2 - ang)/2)
+    wdth = (wdth' + (wdth' - 1) * mwdth)/wdth'
+    wdth' = 1 - sw / r
+    mwdth = 1 - (0.5 * (sw + ew)) / r
+    ewdth' = 1 - ew / r
+    ewdth = (ewdth' + (ewdth' - 1) * mwdth)/ewdth'
+    (V2 xa ya) = rotateV startA (V2 r 0)
+    (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (r * sqrt 2) 0)
+    (V2 xc yc) = rotateV endA (V2 r 0)
+    f (pos, col, V3 a b c) = Verx pos col [a, b, c] BottomLayer arcNum