Improve cursor rendering

src/Dodge/Rendering.hs

@@ -207,8 +207,7 @@ hudDrawings w = setLayer 1 $ (onLayer InvLayer)
                           [ displayInv 0 w
                           , dShadCol white $ displayHP 0 w
                           , --color (itCol (yourItem w)) 
-                            color white
-                                $ drawCursor w
+                                drawCursor (itCol (yourItem w)) w
                           , translate (-390) 20 
                                 $ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
                           ]
@@ -224,12 +223,16 @@ btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c)
 clDraw :: Cloud -> Drawing
 clDraw c = uncurry translate (_clPos c) $ (_clPict c c)
 
-drawCursor :: World -> Picture
-drawCursor w = setLayer 1
+drawCursor :: Color -> World -> Picture
+drawCursor c w = setLayer 1
                 $ translate (105-halfWidth w) 
-                         (halfHeight w - (25* (fromIntegral iPos)) - 20
+                         (halfHeight w - (20* (fromIntegral iPos)) - 20
                          )
-                 $ line [(100,12.5),(-100,12.5),(-100,-12.5),(100,-12.5)]
+                 $ lineCol [(( 100,12.5) ,withAlpha 0 c)
+                           ,((-100,12.5) ,c)
+                           ,((-100,-7.5) ,c)
+                           ,(( 100,-7.5) ,withAlpha 0 c)
+                           ]
     where iPos = _crInvSel $ _creatures w IM.! _yourID w
 
 
@@ -433,7 +436,7 @@ linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n
 
 displayInv :: Int -> World -> Picture
 displayInv n w = pictures $ zipWith (translate (15-halfWidth w)) 
-                         (map (\x-> halfHeight w-(25*(fromIntegral x+1))) ns) $ map dItem' is
+                         (map (\x-> halfHeight w-(20*(fromIntegral x+1))) ns) $ map dItem' is
      where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n
 
 dItem' NoItem = scale 0.1 0.1 $ dShadCol (greyN 0.5) $ text "----"

src/Picture.hs

@@ -11,6 +11,7 @@ module Picture
     , circleSolid
     , circle
     , line
+    , lineCol
     , text
     , pictures
     , translate
@@ -58,16 +59,6 @@ import Control.Lens
 black :: RGBA
 black = (0,0,0,1)
 
---polygonD :: Float -> [Point2] -> Picture
---{-# INLINE polygonD #-}
---polygonD d (a:b:c:ps) = blank
---    { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
---    , _scColTri = mapVC (const black) tris
---    }
---    where twoPs = zip (b:c:ps) (c:ps)
---          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
---polygonD _ _ = blank
-
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
 polygon = Polygon 0
@@ -76,16 +67,6 @@ polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
 polygonCol = PolygonCol 0
 
---polygon :: [Point2] -> Picture
---{-# INLINE polygon #-}
---polygon (a:b:c:ps) = NLeaf $ emptyScene
---    { _scPosTri = fmap zeroZ tris
---    , _scColTri = fmap (const black) tris
---    }
---    where twoPs = zip (b:c:ps) (c:ps)
---          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
---polygon _ = blank
-
 color :: RGBA -> Picture -> Picture
 {-# INLINE color #-}
 color c pic = OverPic id id 0 (const c) pic
@@ -154,6 +135,10 @@ line :: [Point2] -> Picture
 {-# INLINE line #-}
 line = Line 0
 
+lineCol :: [(Point2,RGBA)] -> Picture
+{-# INLINE lineCol #-}
+lineCol = LineCol 0
+
 thickLine :: [Point2] -> Float -> Picture
 {-# INLINE thickLine #-}
 thickLine ps t = pictures $ f ps

src/Picture/Data.hs

@@ -70,6 +70,7 @@ data Picture
     | Circle Int Float
     | ThickArc Int Float Float Float Float
     | Line Int [Point2]
+    | LineCol Int [(Point2,RGBA)]
     | Pictures [Picture]
     | OverPic (Point3 -> Point3) (Point2 -> Point2) Float (Point4 -> Point4) Picture
     | OnLayer Int Picture

src/Picture/Render.hs

@@ -141,31 +141,6 @@ picToAlt x (Text i s)
 picToAlt j Blank = Ap.empty
 picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics
 
-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 (Pictures pics) = concatMap (picToList 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
@@ -191,6 +166,11 @@ picToLTree mx (ThickArc i startA endA rad wdth)
 picToLTree mx (Line i ps) 
     | Just i == mx || Nothing == mx = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
     | otherwise = LBranches []
+picToLTree mx (LineCol i vs) 
+    | Just i == mx || Nothing == mx = 
+        let (ps,cs) = unzip vs
+        in  LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
+    | otherwise = LBranches []
 picToLTree mx (Text i s) 
     | Just i == mx || Nothing == mx = LLeaf $ RenderText $ stringToList s
     | otherwise = LBranches []
@@ -204,7 +184,8 @@ picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
                                     | otherwise = LBranches []
 picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing pic
 
-doubleLine :: [Point2] -> [Point2]
+doubleLine :: [a] -> [a]
+{-# INLINE doubleLine #-}
 doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
 doubleLine _ = []