From 79b6a4fc328f2a14b049d2c64aa4787b572514f9 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 8 Mar 2021 00:25:57 +0100 Subject: [PATCH] Improve cursor rendering --- src/Dodge/Rendering.hs | 17 ++++++++++------- src/Picture.hs | 25 +++++-------------------- src/Picture/Data.hs | 1 + src/Picture/Render.hs | 33 +++++++-------------------------- 4 files changed, 23 insertions(+), 53 deletions(-) diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index 765084698..0114a055a 100644 --- a/src/Dodge/Rendering.hs +++ b/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 "----" diff --git a/src/Picture.hs b/src/Picture.hs index 2c1e4f2aa..ea31e11f4 100644 --- a/src/Picture.hs +++ b/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 diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index bb115e66e..b1ebad6f0 100644 --- a/src/Picture/Data.hs +++ b/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 diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index d68d4f1d5..5a3dd40a6 100644 --- a/src/Picture/Render.hs +++ b/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 _ = []