fjvallarino/monomer
1
1
Fork 0
mirror of https://github.com/fjvallarino/monomer.git synced 2024-09-20 08:17:37 +03:00
Code Issues Projects Releases Wiki Activity

Fix negative value issue on subtractBorderFromRadius

Browse Source
This commit is contained in:
Francisco Vallarino 2021-07-12 02:01:49 -03:00
parent f7e3fad9c8
commit 245e1c53bb
3 changed files with 9 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
app/Main.hs
View File

@ -151,7 +151,7 @@ buildUI wenv model = traceShow "Creating UI" widgetImgTest where
hgrid [spacer `style` [bgColor darkBlue], label "Test" `style` [textUnderline, border 1 salmon, radius 50]]
]
--widgetImgTest = vstack [hstack [widgetImgTest2]] `style` [border 40 (green & L.a .~ 0.5), borderL 50 (orange & L.a .~ 0.5), borderT 20 (orange & L.a .~ 0.5), borderB 20 (green & L.a .~ 0.5), radius 30, radiusTL 0, radiusBL 40, radiusBR 50]
widgetImgTest = vstack [hstack [widgetImgTest2]] `style` [border 40 (green & L.a .~ 0.5), borderL 100 (orange & L.a .~ 0.5), borderT 20 (blue & L.a .~ 0.5), borderB 20 (violet & L.a .~ 0.5), radius 100]
widgetImgTest = vstack [hstack [widgetImgTest2]] `style` [border 40 (green & L.a .~ 0.5), borderL 100 (orange & L.a .~ 0.5), borderT 20 (blue & L.a .~ 0.5), borderB 20 (violet & L.a .~ 0.5)]
widgetImgTest2 = image_ "assets/images/pecans.jpg" [fitWidth, imageRepeatX, imageRepeatY, onLoadError ImageMsg]
`style` [bgColor orange, border 10 red, borderL 40 green, radius 60]
--(pink & L.a .~ 0.5)
@ -514,7 +514,7 @@ buildUI wenv model = traceShow "Creating UI" widgetImgTest where
scroll_ [] (image_ "assets/images/pecans.jpg" [fitFill] `style` [radius 20]),
scroll_ [] $ image_ "assets/images/pecans.jpg" [fitFill],
scroll_ [] $ image_ "assets/images/pecans.jpg" [fitFill],
image_ "https://picsum.photos/1600/400" [fitFill, onLoadError ImageMsg] `style` [cursorIcon CursorInvalid, border 10 (orange & L.a .~ 0.5), radius 100, radiusBL 0, radiusBR 0]
image_ "https://picsum.photos/1600/400" [fitFill, onLoadError ImageMsg] `style` [cursorIcon CursorInvalid, border 40 (orange & L.a .~ 0.5), radius 100, radiusBL 0, radiusBR 0]
],
textDropdown_ dropdown1 items id [onChange DropdownVal, onChangeIdx DropdownIdx],
button_ "Click\nme!" (PrintMessage "Button clicked") [] --multiLine, ellipsis

19
src/Monomer/Core/StyleUtil.hs
View File

@ -35,11 +35,10 @@ module Monomer.Core.StyleUtil (
addPadding,
subtractBorder,
subtractPadding,
scaleBorder,
subtractBorderFromRadius
) where
import Control.Lens ((&), (^.), (^?), (.~), (+~), (-~), (*~), (?~), _Just, non)
import Control.Lens ((&), (^.), (^?), (.~), (+~), (%~), (?~), _Just, non)
import Data.Default
import Data.Maybe
import Data.Text (Text)
@ -228,14 +227,6 @@ subtractPadding rect Nothing = Just rect
subtractPadding rect (Just (Padding l r t b)) = nRect where
nRect = subtractFromRect rect (justDef l) (justDef r) (justDef t) (justDef b)
-- | Applies the given scale to each side of the border
scaleBorder :: Border -> Double -> Border
scaleBorder (Border l r t b) scale = Border nl nr nt nb where
nl = l & _Just . L.width *~ scale
nr = r & _Just . L.width *~ scale
nt = t & _Just . L.width *~ scale
nb = b & _Just . L.width *~ scale
{-|
Subtracts border width from radius. This is useful when rendering nested shapes
with rounded corners, which would otherwise have gaps in the corners.
@ -243,10 +234,10 @@ with rounded corners, which would otherwise have gaps in the corners.
subtractBorderFromRadius :: Maybe Border -> Radius -> Radius
subtractBorderFromRadius border (Radius rtl rtr rbl rbr) = newRadius where
(bl, br, bt, bb) = borderWidths border
ntl = rtl & _Just . L.width -~ max bl bt
ntr = rtr & _Just . L.width -~ max br bt
nbl = rbl & _Just . L.width -~ max bl bb
nbr = rbr & _Just . L.width -~ max br bb
ntl = rtl & _Just . L.width %~ \w -> max 0 (w - max bl bt)
ntr = rtr & _Just . L.width %~ \w -> max 0 (w - max br bt)
nbl = rbl & _Just . L.width %~ \w -> max 0 (w - max bl bb)
nbr = rbr & _Just . L.width %~ \w -> max 0 (w - max br bb)
newRadius = Radius ntl ntr nbl nbr
-- Internal

5
src/Monomer/Widgets/Util/Drawing.hs
View File

@ -450,7 +450,6 @@ drawRectRoundedBorder renderer rect border radius =
yl2 = yb - validBL
xb1 = xl + validBL
in do
-- Restrict radius width to min (w/2) (h/2). fixRadius already does that?
(lt1, lt2, tl1, tl2) <- drawRoundedCorner renderer CornerTL rtl (p2 xt1 yl1) radTL borL borT
(tr1, tr2, rt1, rt2) <- drawRoundedCorner renderer CornerTR rtr (p2 xt2 yr1) radTR borT borR
(rb1, rb2, br1, br2) <- drawRoundedCorner renderer CornerBR rbr (p2 xb2 yr2) radBR borR borB
@ -485,7 +484,7 @@ drawRoundedCorner renderer cor bounds ocenter mrcor ms1 ms2 = do
renderLineTo renderer o1
if round irad > 0
if round orad > 0 && round irad > 0
then do
renderLineTo renderer i1
renderArc renderer icenter irad (deg - 90) deg CW
@ -589,6 +588,6 @@ radW r = _rcrWidth (fromMaybe def r)
fixRadius :: Rect -> Radius -> Radius
fixRadius (Rect _ _ w h) (Radius tl tr bl br) = newRadius where
fixC (RadiusCorner cwidth)
| cwidth * 2 < min w h = RadiusCorner cwidth
| cwidth < min w h / 2= RadiusCorner cwidth
| otherwise = RadiusCorner (min w h / 2)
newRadius = Radius (fixC <$> tl) (fixC <$> tr) (fixC <$> bl) (fixC <$> br)