Fix split issues when sizeReq change dinamically

2024-11-14 08:17:22 +03:00 · 2021-01-16 10:57:13 -03:00 · 2021-01-16 10:57:13 -03:00 · 18946ef8e3
commit 18946ef8e3
parent a5475f0e2e
9 changed files with 117 additions and 63 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -118,7 +118,23 @@ handleAppEvent wenv model evt = case evt of

 buildUI :: WidgetEnv App AppEvent -> App -> WidgetNode App AppEvent
 buildUI wenv model = trace "Creating UI" widgetHSplit where
-  widgetHSplit = hsplit_ (image "assets/images/pecans.jpg" `style` [rangeWidth 200 500], widgetTree `style` [rangeWidth 200 500]) [splitHandleSize 10]
+  widgetSplitAlt = hsplit (
+    hstack [
+      scroll_ (
+        image_ "assets/images/pecans.jpg" [fitFill]
+      ) [] `style` [minWidth 200]
+      ,
+      scroll_ (
+        image_ "assets/images/pecans.jpg" [fitFill]
+      ) [] `style` [minWidth 200]
+      ,
+      scroll_ (
+        image_ "assets/images/pecans.jpg" [fitFill]
+      ) [] `style` [minWidth 200]
+    ],
+    image_ "https://picsum.photos/800/600" [fitFill, onLoadError ImageMsg])
+
+  widgetHSplit = hsplit (image "assets/images/pecans.jpg" `style` [rangeWidth 200 500], widgetTree)
  widgetVSplit = vsplit (image "assets/images/pecans.jpg" `style` [rangeHeight 200 500], widgetTree `style` [rangeHeight 200 500])
  mkImg i = vstack [
      label ("Image: " <> showt i),
@ -327,22 +343,21 @@ buildUI wenv model = trace "Creating UI" widgetHSplit where
        label_ "This is a really long label used to check what I did works fine" [textMultiLine, textEllipsis],
        label "Jj label" `hover` [textSize 40]
      ] `hover` [bgColor red],
-      hstack [
-        scroll_ (
-          image_ "assets/images/pecans.jpg" [fitFill] `style` [minWidth 200]
-        ) []
-        ,
-        scroll_ (
-          image_ "assets/images/pecans.jpg" [fitFill] `style` [minWidth 200]
-        ) []
-        ,
-        scroll_ (
-          image_ "assets/images/pecans.jpg" [fitFill] `style` [minWidth 200]
-        ) []
-        ,
-        spacer_ [resizeFactor 1],
-        image_ "https://picsum.photos/600/400" [fitFill, onLoadError ImageMsg]
-      ],
+      hsplit (
+        hstack [
+          scroll_ (
+            image_ "assets/images/pecans.jpg" [fitFill]
+          ) []
+          ,
+          scroll_ (
+            image_ "assets/images/pecans.jpg" [fitFill]
+          ) []
+          ,
+          scroll_ (
+            image_ "assets/images/pecans.jpg" [fitFill]
+          ) []
+        ],
+        image_ "https://picsum.photos/800/600" [fitFill, onLoadError ImageMsg]),
      textDropdown_ dropdown1 items id [onChange DropdownVal, onChangeIdx DropdownIdx],
      button_ "Click\nme!" (PrintMessage "Button clicked") [textMultiLine]
    ] `key` "main vstack" `style` [borderT 20 red, borderL 10 blue, borderR 10 green, borderB 10 gray, iradius 50] --, padding 20
--- a/src/Monomer/Core/BasicTypes.hs
+++ b/src/Monomer/Core/BasicTypes.hs
@ -92,6 +92,9 @@ subtractFromSize (Size w h) w2 h2 = newSize where
 moveRect :: Point -> Rect -> Rect
 moveRect (Point x y) (Rect rx ry rw rh) = Rect (rx + x) (ry + y) rw rh

+rectCenter :: Rect -> Point
+rectCenter (Rect rx ry rw rh) = Point (rx + rw / 2) (ry + rh / 2)
+
 rectInRect :: Rect -> Rect -> Bool
 rectInRect inner outer = rectInRectH inner outer && rectInRectV inner outer

--- a/src/Monomer/Widgets/Split.hs
+++ b/src/Monomer/Widgets/Split.hs
@ -48,10 +48,11 @@ splitHandleSize w = def {
 }

 data SplitState = SplitState {
+  _spsPrevReqs :: (SizeReq, SizeReq),
+  _spsMaxSize :: Double,
  _spsHandleDragged :: Bool,
  _spsHandlePos :: Double,
-  _spsHandleRect :: Rect,
-  _spsMaxDim :: Double
+  _spsHandleRect :: Rect
 } deriving (Eq, Show, Generic, Serialise)

 hsplit :: (WidgetNode s e, WidgetNode s e) -> WidgetNode s e
@ -70,7 +71,7 @@ split_
  :: Bool -> (WidgetNode s e, WidgetNode s e) -> [SplitCfg] -> WidgetNode s e
 split_ isHorizontal (node1, node2) configs = newNode where
  config = mconcat configs
-  state = SplitState False 0 def 0
+  state = SplitState def 0 False 0 def
  widget = makeSplit isHorizontal config state
  widgetName = if isHorizontal then "hsplit" else "vsplit"
  newNode = defaultWidgetNode widgetName widget
@ -92,14 +93,14 @@ makeSplit isHorizontal config state = widget where
      & L.widget .~ makeSplit isHorizontal config oldState

  handleEvent wenv target evt node = case evt of
-    Move p
+    Move point
      | isTarget && isDragging -> Just resultDrag
-      | isTarget && isHandle p -> Just resultHover
+      | isTarget && isInHandle point -> Just resultHover
      where
-        Point px py = validHandlePos maxDim ra p (node ^. L.children)
+        Point px py = getValidHandlePos maxSize ra point children
        newHandlePos
-          | isHorizontal = (px - ra ^. L.x) / maxDim
-          | otherwise = (py - ra ^. L.y) / maxDim
+          | isHorizontal = (px - ra ^. L.x) / maxSize
+          | otherwise = (py - ra ^. L.y) / maxSize
        newState = state {
          _spsHandleDragged = True,
          _spsHandlePos = newHandlePos
@ -111,12 +112,14 @@ makeSplit isHorizontal config state = widget where
        resultHover = resultReqs node [cursorIconReq]
    _ -> Nothing
    where
-      SplitState _ _ handleRect maxDim = state
+      maxSize = _spsMaxSize state
+      handleRect = _spsHandleRect state
      vp = node ^. L.info . L.viewport
      ra = node ^. L.info . L.renderArea
+      children = node ^. L.children
      isTarget = target == node ^. L.info . L.path
      isDragging = isNodePressed wenv node
-      isHandle p = pointInRect p handleRect
+      isInHandle p = pointInRect p handleRect
      cursorIconReq
        | isHorizontal = SetCursorIcon CursorSizeH
        | otherwise = SetCursorIcon CursorSizeV
@ -139,16 +142,23 @@ makeSplit isHorizontal config state = widget where
    style = activeStyle wenv node
    contentArea = fromMaybe def (removeOuterBounds style renderArea)
    Rect rx ry rw rh = contentArea
-    (areas, newDim) = assignStackAreas isHorizontal contentArea children
+    (areas, newSize) = assignStackAreas isHorizontal contentArea children
+    oldHandlePos = _spsHandlePos state
+    sizeReq1 = sizeReq $ Seq.index children 0
+    sizeReq2 = sizeReq $ Seq.index children 1
+    valid1 = sizeReqValid sizeReq1 0 (newSize * oldHandlePos)
+    valid2 = sizeReqValid sizeReq2 0 (newSize * (1 - oldHandlePos))
+    keepHandlePos = _spsHandleDragged state || valid1 && valid2
+    sizeReqChanged = (sizeReq1, sizeReq2) /= _spsPrevReqs state
    handlePos
-      | _spsHandleDragged state = _spsHandlePos state
-      | otherwise = calcHandlePos areas newDim
+      | keepHandlePos && not sizeReqChanged = oldHandlePos
+      | otherwise = calcHandlePos areas newSize
    (w1, h1)
-      | isHorizontal = ((newDim - handleW) * handlePos, rh)
-      | otherwise = (rw, (newDim - handleW) * handlePos)
+      | isHorizontal = ((newSize - handleW) * handlePos, rh)
+      | otherwise = (rw, (newSize - handleW) * handlePos)
    (w2, h2)
-      | isHorizontal = (newDim - w1 - handleW, rh)
-      | otherwise = (rw, newDim - h1 - handleW)
+      | isHorizontal = (newSize - w1 - handleW, rh)
+      | otherwise = (rw, newSize - h1 - handleW)
    rect1 = Rect rx ry w1 h1
    rect2
      | isHorizontal = Rect (rx + w1 + handleW) ry w2 h2
@ -157,9 +167,11 @@ makeSplit isHorizontal config state = widget where
      | isHorizontal = Rect (rx + w1) ry handleW h1
      | otherwise = Rect rx (ry + h1) w1 handleW
    newState = state {
+      _spsHandleDragged = False,
      _spsHandlePos = handlePos,
      _spsHandleRect = newHandleRect,
-      _spsMaxDim = newDim
+      _spsMaxSize = newSize,
+      _spsPrevReqs = (sizeReq1, sizeReq2)
    }
    newNode = node
      & L.widget .~ makeSplit isHorizontal config newState
@ -167,33 +179,35 @@ makeSplit isHorizontal config state = widget where
    assignedArea = Seq.zip newRas newRas
    resized = (newNode, assignedArea)

-  calcHandlePos areas newDim = newPos where
-    selector
-      | isHorizontal = _rW
-      | otherwise = _rH
-    childSize = selector $ Seq.index areas 0
-    newPos = childSize / newDim
-
-  validHandlePos maxDim rect point children = addPoint origin newPoint where
+  getValidHandlePos maxDim rect point children = addPoint origin newPoint where
    Rect rx ry rw rh = rect
    Point vx vy = rectBoundedPoint rect point
    origin = Point rx ry
    isVertical = not isHorizontal
    child1 = Seq.index children 0
    child2 = Seq.index children 1
-    sizeReq
-      | isHorizontal = (^. L.info . L.sizeReqW)
-      | otherwise = (^. L.info . L.sizeReqH)
    minSize1 = sizeReqMin (sizeReq child1)
    maxSize1 = sizeReqMax (sizeReq child1)
    minSize2 = sizeReqMin (sizeReq child2)
    maxSize2 = sizeReqMax (sizeReq child2)
-    Point tx ty
-      | isHorizontal = Point (max minSize1 (min maxSize1 $ vx - rx)) 0
-      | otherwise = Point 0 (max minSize1 (min maxSize1 $ vy - ry))
+    (tw, th)
+      | isHorizontal = (max minSize1 (min maxSize1 $ vx - rx), 0)
+      | otherwise = (0, max minSize1 (min maxSize1 $ vy - ry))
    newPoint
-      | isHorizontal && tx + minSize2 > maxDim = Point (maxDim - minSize2) ty
-      | isHorizontal && maxDim - tx > maxSize2 = Point (maxDim - maxSize2) ty
-      | isVertical && ty + minSize2 > maxDim = Point tx (maxDim - minSize2)
-      | isVertical && maxDim - ty > maxSize2 = Point tx (maxDim - maxSize2)
-      | otherwise = Point tx ty
+      | isHorizontal && tw + minSize2 > maxDim = Point (maxDim - minSize2) th
+      | isHorizontal && maxDim - tw > maxSize2 = Point (maxDim - maxSize2) th
+      | isVertical && th + minSize2 > maxDim = Point tw (maxDim - minSize2)
+      | isVertical && maxDim - th > maxSize2 = Point tw (maxDim - maxSize2)
+      | otherwise = Point tw th
+
+  calcHandlePos areas newDim = newPos where
+    childSize = selector $ Seq.index areas 0
+    newPos = childSize / newDim
+
+  selector
+    | isHorizontal = _rW
+    | otherwise = _rH
+
+  sizeReq
+    | isHorizontal = (^. L.info . L.sizeReqW)
+    | otherwise = (^. L.info . L.sizeReqH)
--- a/src/Monomer/Widgets/Stack.hs
+++ b/src/Monomer/Widgets/Stack.hs
@ -136,7 +136,8 @@ assignStackAreas isHorizontal contentArea children = result where
    newSize = resizeChild isHorizontal contentArea flexCoeff extraCoeff offset child
    newAccum = accum |> newSize
    newOffset = offset + rectSelector newSize
-  result = foldl' foldHelper (Seq.empty, mainStart) children
+  (areas, usedDim) = foldl' foldHelper (Seq.empty, mainStart) children
+  result = (areas, usedDim - mainStart)

 resizeChild :: Bool -> Rect -> Factor -> Factor -> Double -> WidgetNode s e -> Rect
 resizeChild horizontal contentArea flexCoeff extraCoeff offset child = result where
--- a/src/Monomer/Widgets/Util/Hover.hs
+++ b/src/Monomer/Widgets/Util/Hover.hs
@ -1,5 +1,6 @@
 module Monomer.Widgets.Util.Hover (
  isPointInNodeVp,
+  isNodeActive,
  isNodePressed,
  isNodeHovered,
  isNodeHoveredEllipse_,
@ -23,6 +24,13 @@ import qualified Monomer.Lens as L
 isPointInNodeVp :: Point -> WidgetNode s e -> Bool
 isPointInNodeVp p node = pointInRect p (node ^. L.info . L.viewport)

+isNodeActive :: WidgetEnv s e -> WidgetNode s e -> Bool
+isNodeActive wenv node = validPos && pressed where
+  viewport = node ^. L.info . L.viewport
+  mousePos = wenv ^. L.inputStatus . L.mousePos
+  validPos = pointInRect mousePos viewport
+  pressed = isNodePressed wenv node
+
 isNodePressed :: WidgetEnv s e -> WidgetNode s e -> Bool
 isNodePressed wenv node = Just path == pressed where
  path = node ^. L.info . L.path
--- a/src/Monomer/Widgets/Util/SizeReq.hs
+++ b/src/Monomer/Widgets/Util/SizeReq.hs
@ -1,5 +1,6 @@
 module Monomer.Widgets.Util.SizeReq (
  sizeReqBound,
+  sizeReqValid,
  sizeReqAddStyle,
  sizeReqMin,
  sizeReqMax,
@ -26,6 +27,11 @@ sizeReqBound sizeReq offset value = max minSize . min maxSize $ value where
  minSize = offset + sizeReqMin sizeReq
  maxSize = offset + sizeReqMax sizeReq

+sizeReqValid :: SizeReq -> Double -> Double -> Bool
+sizeReqValid sizeReq offset value = minSize <= value && value <= maxSize where
+  minSize = offset + sizeReqMin sizeReq
+  maxSize = offset + sizeReqMax sizeReq
+
 sizeReqAddStyle :: StyleState -> (SizeReq, SizeReq) -> (SizeReq, SizeReq)
 sizeReqAddStyle style (reqW, reqH) = (newReqW, newReqH) where
  Size w h = fromMaybe def (addOuterSize style def)
--- a/src/Monomer/Widgets/Util/Style.hs
+++ b/src/Monomer/Widgets/Util/Style.hs
@ -15,7 +15,7 @@ module Monomer.Widgets.Util.Style (
 ) where

 import Control.Applicative ((<|>))
-import Control.Lens ((&), (^.), (^?), (.~), (<>~), _Just)
+import Control.Lens ((&), (^.), (^?), (.~), (<>~), _Just, _1)
 import Data.Bits (xor)
 import Data.Default
 import Data.Maybe
@ -44,10 +44,10 @@ activeStyle_ isHoveredFn wenv node = fromMaybe def styleState where
  isEnabled = node ^. L.info . L.enabled
  isHover = isHoveredFn wenv node
  isFocus = isNodeFocused wenv node
-  isPress = isNodePressed wenv node
+  isActive = isNodeActive wenv node
  styleState
    | not isEnabled = _styleDisabled
-    | isHover && isPress = _styleActive
+    | isActive = _styleActive
    | isHover && isFocus = _styleFocusHover
    | isHover = _styleHover
    | isFocus = _styleFocus
@ -74,10 +74,10 @@ activeTheme_ isHoveredFn wenv node = themeState where
  isEnabled = node ^. L.info . L.enabled
  isHover = isHoveredFn wenv node
  isFocus = isNodeFocused wenv node
-  isPress = isNodePressed wenv node
+  isActive = isNodeActive wenv node
  themeState
    | not isEnabled = _themeDisabled theme
-    | isHover && isPress = _themeActive theme
+    | isActive = _themeActive theme
    | isHover = _themeHover theme
    | isFocus = _themeFocus theme
    | otherwise = _themeBasic theme
@ -130,9 +130,15 @@ handleSizeChange wenv target evt cfg oldNode newNode = reqs where
  newSizeReqW = newNode ^. L.info . L.sizeReqW
  newSizeReqH = newNode ^. L.info . L.sizeReqH
  sizeReqChanged = oldSizeReqW /= newSizeReqW || oldSizeReqH /= newSizeReqH
+  -- Hover drag changed (if dragging, Enter/Leave is not sent)
+  prevInVp = isPointInNodeVp (wenv ^. L.inputStatus . L.mousePosPrev) newNode
+  currInVp = isPointInNodeVp (wenv ^. L.inputStatus . L.mousePos) newNode
+  path = newNode ^. L.info . L.path
+  pressedPath = wenv ^. L.mainBtnPress ^? _Just . _1
+  hoverDragChanged = Just path == pressedPath && prevInVp /= currInVp
  -- Result
  resizeReq = [ ResizeWidgets | sizeReqChanged ]
-  enterReq = [ RenderOnce | isOnEnter evt || isOnLeave evt ]
+  enterReq = [ RenderOnce | isOnEnter evt || isOnLeave evt || hoverDragChanged ]
  reqs = resizeReq ++ enterReq

 styleStateChanged :: WidgetEnv s e -> WidgetNode s e -> SystemEvent -> Bool
--- a/tasks.md
+++ b/tasks.md
@ -416,6 +416,7 @@
      - Maybe have two versions of add? Two versions of render?
    - When adding image, on failure remove the least used image and retry
      - https://hackage.haskell.org/package/lrucache
+  - Active state not working correctly (click button and drag outside)

 - Pending
  - Add header in all files, indicating license and documenting what the module does
@ -432,13 +433,13 @@ Maybe postponed after release?
    - Use space proportional to what widgets request
  - Does widgetResize need to return WidgetResult?
    - User may want to listen for resize events
+  - Create Dial
  - Create Slider
  - Create Keystroke component (shortcuts and general key handling like Esc for dialog)
  - Create Tooltip component. It just wraps a given component and draws the tooltip with renderOverlay
  - Create Theme widget to override global theme
  - Create Focus Memorizer (?)
    - It should handle the situation of closing a dialog and returning to the previous focused widget
-  - Create Dial
  - Create Layout with width/heights specified in percents
  - Create File Selector
  - Create Color Selector
--- a/test/unit/Monomer/Widgets/Util/StyleSpec.hs
+++ b/test/unit/Monomer/Widgets/Util/StyleSpec.hs
@ -59,7 +59,7 @@ testActiveStyle = describe "activeStyle" $ do
      & L.focusedPath .~ Seq.fromList [0]
    wenvActive = mockWenv ()
      & L.inputStatus . L.mousePos .~ Point 200 200
-      & L.inputStatus . L.buttons . at LeftBtn ?~ PressedBtn
+      & L.mainBtnPress ?~ (Seq.fromList [0], Point 200 200)
    nodeNormal = createNode True
    nodeDisabled = createNode False