geomancy-layout 0.1 → 0.1.1

raw patch · 9 files changed

+1136/−15 lines, 9 filesdep +geomancy-layoutdep +lucid-svgdep +showerPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: geomancy-layout, lucid-svg, shower, tasty, tasty-hunit

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• README.md +1/−0
• geomancy-layout.cabal +35/−3
• src/Geomancy/Layout.hs +2/−2
• src/Geomancy/Layout/Alignment.hs +12/−10
• src/Geomancy/Layout/Box.hs +8/−0
• src/Geomancy/Layout/View.hs +635/−0
• test/Examples.hs +419/−0
• test/Spec.hs +20/−0

@@ -1,3 +1,7 @@+## 0.1.1++- Added `Geomancy.Layout.View` - an experimental SwiftUI-like propose-report-place protocol.+ ## 0.1  Initial import.

@@ -5,5 +5,6 @@ * `Geomancy.Layout` - box cutting and stacking. * `Geomancy.Layout.Box` - size/position and top/right/bottom/left boxes and manipulation. * `Geomancy.Layout.Alignment` - distribute size leftovers proportionally.+* `Geomancy.Layout.View` - SwiftUI-like containers.  [geomancy]: https://hackage.haskell.org/package/geomancy

@@ -1,17 +1,17 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           geomancy-layout-version:        0.1+version:        0.1.1 synopsis:       Geometry and matrix manipulation description:    Layout primitives and algorithms for geomancy data. category:       Graphics author:         IC Rainbow maintainer:     aenor.realm@gmail.com-copyright:      2023 IC Rainbow+copyright:      2025 IC Rainbow license:        BSD3 license-file:   LICENSE build-type:     Simple@@ -28,6 +28,7 @@       Geomancy.Layout       Geomancy.Layout.Alignment       Geomancy.Layout.Box+      Geomancy.Layout.View   other-modules:       Paths_geomancy_layout   hs-source-dirs:@@ -42,9 +43,40 @@       OverloadedRecordDot       PatternSynonyms       RecordWildCards+      TypeFamilies   ghc-options: -Wall   build-depends:       base >=4.7 && <5     , geomancy >=0.2.6 && <1     , gl-block >=1.0 && <2+  default-language: GHC2021++test-suite geomancy-layout-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Examples+      Paths_geomancy_layout+  hs-source-dirs:+      test+  default-extensions:+      BlockArguments+      DeriveAnyClass+      DerivingStrategies+      DerivingVia+      ImportQualifiedPost+      LambdaCase+      OverloadedRecordDot+      PatternSynonyms+      RecordWildCards+      TypeFamilies+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-qn1 -with-rtsopts=-A128m+  build-depends:+      base >=4.7 && <5+    , geomancy >=0.2.6 && <1+    , geomancy-layout+    , lucid-svg+    , shower+    , tasty+    , tasty-hunit   default-language: GHC2021

@@ -2,7 +2,7 @@  import Geomancy -import Geomancy.Layout.Alignment (Alignment, Origin)+import Geomancy.Layout.Alignment (Alignment(..), Origin) import Geomancy.Layout.Alignment qualified as Alignment import Geomancy.Layout.Box (Box(..), TRBL(..)) import Geomancy.Layout.Box qualified as Box@@ -194,7 +194,7 @@  {-# INLINEABLE placeSize #-} placeSize :: Alignment -> Vec2 -> Box -> Box-placeSize align size parent =+placeSize (Alignment align) size parent =   withVec2 align \ah av ->     withVec2 size \w h ->       withVec2 parent.size \pw ph ->

@@ -3,34 +3,36 @@ import Geomancy  -- | @left/center/right@ & @top/middle/bottom@-type Alignment = Vec2+newtype Alignment = Alignment Vec2+  deriving (Eq, Ord, Show)+  deriving newtype (Num)  leftTop :: Alignment-leftTop = vec2 Begin Begin+leftTop = Alignment $ vec2 Begin Begin  leftMiddle :: Alignment-leftMiddle = vec2 Begin Middle+leftMiddle = Alignment $ vec2 Begin Middle  leftBottom :: Alignment-leftBottom = vec2 Begin End+leftBottom = Alignment $ vec2 Begin End  centerTop :: Alignment-centerTop = vec2 Middle Begin+centerTop = Alignment $ vec2 Middle Begin  center :: Alignment-center = vec2 Middle Middle+center = Alignment $ vec2 Middle Middle  centerBottom :: Alignment-centerBottom = vec2 Middle End+centerBottom = Alignment $ vec2 Middle End  rightTop :: Alignment-rightTop = vec2 End Begin+rightTop = Alignment $ vec2 End Begin  rightMiddle :: Alignment-rightMiddle = vec2 End Middle+rightMiddle = Alignment $ vec2 End Middle  rightBottom :: Alignment-rightBottom = vec2 End End+rightBottom = Alignment $ vec2 End End  type Origin = Float 

@@ -29,6 +29,12 @@   deriving anyclass Block.Block   deriving Foreign.Storable via (Block.Packed Box) +width :: Box -> Float+width Box{size} = withVec2 size \w _ -> w++height :: Box -> Float+height Box{size} = withVec2 size \_ h -> h+ -- | Place a 'Box' with given dimensions at @(0,0)@. {-# INLINE box_ #-} box_ :: Vec2 -> Box@@ -37,6 +43,8 @@ instance Semigroup Box where   {-# INLINE (<>) #-}   (<>) = union++-- XXX: Box is not a Monoid because mempty = box_ 0 would add (0,0) to every box.  -- | Check if one of the dimensions is negative. {-# INLINE degenerate #-}

@@ -0,0 +1,635 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}++{- | SwiftUI-like view tree++The layout keeps the propose-report-place protocol, but chops some parts away.++* Views are abstracted and the 'View' constructor punches a hole in a tree (a hollow?) for a UI toolkit to fill in later.+* There's no "tree builder", so containers and modifiers are constructed directly. Although it is easy to recover modifier with the "Data.Function.(&)" operator.+* There's no "ideal size", "fixed size" etc. and the views are fully flexible. The UI tookit wrappers can instead self-wrap their Views in a 'Frame'/'FlexibleFrame' as needed.+-}++module Geomancy.Layout.View where++import Data.Bifunctor (Bifunctor(..))+import Data.Foldable (toList)+import Data.Foldable1 (foldMap1')+import Data.Functor.Identity (Identity)+import Data.List (mapAccumL, foldl', sortOn)+import Data.List.NonEmpty (nonEmpty)+import Geomancy ((^*))+import Geomancy.Gl.Funs (glClamp)+import Geomancy.Layout qualified as Layout+import Geomancy.Layout.Alignment (Alignment)+import Geomancy.Layout.Alignment qualified as Alignment+import Geomancy.Layout.Box (Box(..))+import Geomancy.Layout.Box qualified as Box+import Geomancy.Vec2 (Vec2, vec2, withVec2, pattern WithVec2)+import Geomancy.Vec4 (Vec4, withVec4)+import GHC.Arr (array)++-- | Run all the layout steps to annotate the nodes with their final placement boxes.+layout :: LayoutView stuff => Box -> View () stuff -> View Box (Placed stuff)+layout initialBox = place initialBox . measure++-- | Do all of the layout steps and fold placed views+--+-- Mostly an example. The better way is to cache intermediate steps.+--+-- (Actually a pun on "fold views".)+foldWith :: (LayoutView stuff, Monoid a) => (Placed stuff -> a) -> Box -> View () stuff -> a+foldWith f initialBox = foldMap f . place initialBox . measure++{- | An interface to plug UI toolkits into the layout.++Alternatively, convert them to `ViewFun`, which has the instance.++The "minimal: none" is a lie. Most likely you will need to adjust either 'ReportedCache ' or 'Placed' types and implement the other function accordingly.++The most gnarly code would be for "rendered text" widgets since they would be dynamically sized and have to be processed/cached on each step.+-}+class LayoutView stuff where+  -- | Measurement pre-pass+  viewFlexibility :: stuff -> ViewSize++  -- XXX: argument order is optimized for \case++  -- | Propose step: return the actual size and store intermediate data.+  proposeView :: Vec2 -> stuff -> (Vec2, ReportedCache stuff)+  type ReportedCache stuff+  type ReportedCache stuff = stuff++  -- | Placement step: get the reported size augmented with a final position, produce the result.+  placeView :: Box -> ReportedCache stuff -> Placed stuff+  type Placed stuff+  type Placed stuff = stuff++  -- | Default implementation is "the view *will* adapt to any size"+  default viewFlexibility :: stuff -> ViewSize+  viewFlexibility = const infinite_++  -- | Default implementation for "accept everything" reporting+  default proposeView :: (ReportedCache stuff ~ stuff) => Vec2 -> stuff -> (Vec2, ReportedCache stuff)+  proposeView = (,)++  -- | Default implementation for "box function" placement+  default placeView :: (ReportedCache stuff ~ (Box -> Placed stuff)) => Box -> ReportedCache stuff -> Placed stuff+  placeView placed f = f placed++-- | "Variant-lite" instance to mix widgets of different type+--+-- XXX: the foldable/traversable would skip the Lefts.+-- Use something like `foldWith` to pre-process and normalize to a common "backend" type+instance (LayoutView l, LayoutView r) => LayoutView (Either l r) where+  type ReportedCache (Either l r) = Either (ReportedCache l) (ReportedCache r)+  type Placed (Either l r) = Either (Placed l) (Placed r)+  viewFlexibility = either viewFlexibility viewFlexibility+  proposeView proposed = either (fmap Left <$> proposeView proposed) (fmap Right <$> proposeView proposed)+  placeView placed = \case+    Left x -> Left $ placeView @l placed x+    Right x -> Right $ placeView @r placed x++{- | Do-nothing pass-through instance++You'll have to peek at the @View{ann}@ of the placement tree.+-}+instance LayoutView (Identity stuff) where+  viewFlexibility = const infinite_+  proposeView = (,)+  placeView _placed = id++{- | A model type for the protocol++The fields correspond to the 3 steps:++* Measurement into ViewSize - static.+* Proposing and reporting - depends on parent size / caches size-related data.+* Placement - depends on placement ('Box' = reported size + position), can use cached data.+-}+data ViewFun stuff = ViewFun ViewSize (Vec2 -> (Vec2, Box -> stuff))+  deriving (Functor)++-- | A wrapper to construct 'ViewFun'-based views+viewFun :: ViewSize -> (Vec2 -> (Vec2, Box -> stuff)) -> View () (ViewFun stuff)+viewFun flex steps = View{ann=(), stuff=ViewFun flex steps}++-- | A wrapper to construct 'ViewFun'-based views by assuming infinite flex and no intrinsic size+boxFun :: (Box -> stuff) -> View () (ViewFun stuff)+boxFun f = viewFun infinite_ (,f)++instance LayoutView (ViewFun stuff) where+  type ReportedCache (ViewFun stuff) = Box -> stuff -- ^ Propose to resolve the outer+  type Placed (ViewFun stuff) = stuff+  viewFlexibility (ViewFun vs _) = vs+  proposeView size (ViewFun _ f) = f size+  placeView placed f = f placed++-- * View tree++{- | Layout skeleton++It is Functor-Foldable-Traversable on 'View' so you can use things like 'Control.Monad.void' to suppress payload and 'show' the intermediate structure.+-}+data View ann stuff+  = View+      { ann :: ann+      , stuff :: stuff+      } -- ^ UI-specific payload+  | Spacer+      { ann :: ann+      }++  -- "containers"+  | HStack+      { ann :: ann+        -- TODO: placement direction+        -- TODO: spacing to inject+      , children :: [View ann stuff]+      } -- ^ Place children side-by-side (LTR)+  | VStack+      { ann :: ann+        -- TODO: placement direction+        -- TODO: spacing to inject+      , children :: [View ann stuff]+      } -- ^ Place children top-to-bottom+  | ZStack+      { ann :: ann+      , children :: [View ann stuff]+      } -- ^ Place children atop of each other+  | Overlay+      { ann :: ann+      , secondary :: View ann stuff+      , primary :: View ann stuff+      } -- ^ Propose the size of the primary view to the secondary view++  -- "modifiers"+  | Frame+      { ann :: ann+      , size :: Vec2+      , align :: Alignment+      , inner :: View ann stuff+      } -- ^ Propose/report size unconditionally+  | FlexibleFrame+      { ann :: ann+      , flex :: ViewSize -- ^ Acceptable size ranges+      , align :: Alignment+      , inner :: View ann stuff+      } -- ^ Adjust measurement flex and clamp proposed/reported size+  | AspectRatio+      { ann :: ann+      , aspect :: Vec2 -- ^ Like 'Ratio Float', for example @vec2 16 9@ or @1@ (= @vec2 1 1@, i.e. square)+      , align :: Alignment+      -- TODO: fit/crop+      , inner :: View ann stuff+      } -- ^ Frame-like wrapper that fits+  | Padding+      { ann :: ann+      , trbl :: Box.TRBL+      , inner :: View ann stuff+      } -- ^ Subtracts a CSS-tyle padding (top/right/bottom/left) from parent+  | Offset+      { ann :: ann+      , xy :: Vec2+      , inner :: View ann stuff+      } -- ^ Adds offset when placing a view+  deriving (Eq, Show, Functor, Foldable, Traversable)++instance Bifunctor View where+  first f = \case+    View{..} -> View{ann = f ann, stuff}+    Spacer{..} -> Spacer{ann = f ann}+    HStack{ann, children} -> HStack{ann = f ann, children = map (first f) children}+    VStack{ann, children} -> VStack{ann = f ann, children = map (first f) children}+    ZStack{ann, children} -> ZStack{ann = f ann, children = map (first f) children}+    Overlay{ann, primary, secondary} -> Overlay{ann = f ann, primary = first f primary, secondary = first f secondary}+    Frame{..} -> Frame{ann = f ann, inner = first f inner, ..}+    FlexibleFrame{..} -> FlexibleFrame{ann = f ann, inner = first f inner, ..}+    Padding{..} -> Padding{ann = f ann, inner = first f inner, ..}+    Offset{..} -> Offset{ann = f ann, inner = first f inner, ..}+    AspectRatio{..} -> AspectRatio{ann = f ann, inner = first f inner, ..}+  second = fmap++-- ** Some shortcuts++view_ :: stuff -> View () stuff+view_ stuff = View{ann=(), ..}++spacer_ :: View () stuff+spacer_ = Spacer{ann=()}++-- *** Containers++hstack_ :: [View () stuff] -> View () stuff+hstack_ children = HStack{ann=(), ..}++vstack_ :: [View () stuff] -> View () stuff+vstack_ children = VStack{ann=(), ..}++zstack_ :: [View () stuff] -> View () stuff+zstack_ children = ZStack{ann=(), ..}++overlay_ :: View () stuff -> View () stuff -> View () stuff+overlay_ secondary primary = Overlay{ann=(), ..}++-- *** Modifiers++frame_ :: Vec2 -> View () stuff -> View () stuff+frame_ size inner = Frame{ann=(), align = Alignment.center, ..}++flexible_ :: ViewSize -> Alignment -> View () stuff -> View () stuff+flexible_ flex align inner = FlexibleFrame{ann=(), ..}++aspect_ :: Vec2 -> View () stuff -> View () stuff+aspect_ ratio inner = AspectRatio{ann=(), aspect=ratio, align=Alignment.center, ..}++padding_ :: Vec4 -> View () stuff -> View () stuff+padding_ trbl inner = Padding{ann=(), trbl=Box.TRBL trbl, ..}++offset_ :: Vec2 -> View () stuff -> View () stuff+offset_ xy inner = Offset{ann=(), ..}++-- * Flexibility helper++-- | Represents size constraints and flexibility for a layout node.+data ViewSize = ViewSize+  { minWidth, maxWidth+  , minHeight, maxHeight :: Maybe Float+  -- XXX: put ideal size here?+  } deriving (Eq, Show)++-- | Creates a ViewSize for a fixed-size view.+fixed_ :: Vec2 -> ViewSize+fixed_ size =+  withVec2 size \w h ->+    ViewSize+      { minWidth = Just w+      , maxWidth = Just w+      , minHeight = Just h+      , maxHeight = Just h+      }++-- | Creates a ViewSize for a fully flexible view.+infinite_ :: ViewSize+infinite_ = ViewSize+  { minWidth = Just 0+  , maxWidth = Just inf+  , minHeight = Just 0+  , maxHeight = Just inf+  }++range_ :: Vec2 -> Vec2 -> ViewSize+range_ a b =+  withVec2 a \aw ah ->+    withVec2 b \bw bh ->+      ViewSize+        { minWidth = Just $ min aw bw+        , maxWidth = Just $ max aw bw+        , minHeight = Just $ min ah bh+        , maxHeight = Just $ max ah bh+        }++-- | Creates a ViewSize that reports parent size+parent_ :: ViewSize+parent_ = ViewSize+  { minWidth = Nothing+  , maxWidth = Nothing+  , minHeight = Nothing+  , maxHeight = Nothing+  }++parentWidth :: ViewSize -> ViewSize+parentWidth a = a {minWidth = Nothing, maxWidth = Nothing}++parentHeight :: ViewSize -> ViewSize+parentHeight a = a {minHeight = Nothing, maxHeight = Nothing}++-- * Layout steps++-- | Measurement pre-pass+measure :: LayoutView stuff => View () stuff -> View ViewSize stuff+measure = \case+  View {stuff} -> View{ann=viewFlexibility stuff, stuff}+  Spacer{} -> Spacer{ann=infinite_}+  Frame{..} -> Frame{ann=fixed_ size, inner=measure inner, ..}+  FlexibleFrame{..} -> FlexibleFrame{ann=flex', inner=inner', ..}+    where+      inner' = measure inner+      innerFlex = inner'.ann+      flex' = ViewSize -- intersection of flexibility ranges+        { minWidth = max <$> flex.minWidth <*> innerFlex.minWidth+        , maxWidth = min <$> flex.maxWidth <*> innerFlex.maxWidth+        , minHeight = max <$> flex.minHeight <*> innerFlex.minHeight+        , maxHeight = min <$> flex.maxHeight <*> innerFlex.maxHeight+        }+  Padding{..} -> Padding{ann=expanded, inner=inner', ..}+    where+      inner' = measure inner+      innerFlex = inner'.ann+      expanded = withVec4 trbl4 \t r b l -> innerFlex+        { minWidth = (+ (l + r)) <$> innerFlex.minWidth+        , minHeight = (+ (t + b)) <$> innerFlex.minHeight+        }+      Box.TRBL trbl4 = trbl+  Offset{..} -> Offset{ann=inner'.ann, inner=inner', ..}+    where+      inner' = measure inner+  AspectRatio{..} -> AspectRatio{ann=ann', inner=inner', ..}+    where+      ann' = inner'.ann -- XXX: pass-through?+      inner' = measure inner+  HStack{children} -> HStack{ann=stackViewSize, children=measured}+    where+      measured = map measure children+      stackViewSize = foldl' (\vs -> stackViewSize' vs . ann) (fixed_ 0) measured+      stackViewSize' a b = ViewSize+        { minWidth = (+) <$> a.minWidth <*> b.minWidth -- combined horizontal flex+        , maxWidth = (+) <$> a.maxWidth <*> b.maxWidth+        , minHeight = max <$> a.minHeight <*> b.minHeight -- intersection of vertical flex+        , maxHeight = min <$> a.maxHeight <*> b.maxHeight+        }+  VStack{children} -> VStack{ann=stackViewSize, children=measured}+    where+      measured = map measure children+      stackViewSize = foldl' (\vs -> stackViewSize' vs . ann) (fixed_ 0) measured+      stackViewSize' a b = ViewSize+        { minWidth = max <$> a.minWidth <*> b.minWidth -- intersection of horizontal flex+        , maxWidth = min <$> a.maxWidth <*> b.maxWidth+        , minHeight = (+) <$> a.minHeight <*> b.minHeight --  combined vertical flex+        , maxHeight = (+) <$> a.maxHeight <*> b.maxHeight+        }+  ZStack{children} -> ZStack{ann=stackViewSize, children=measured}+    where+      measured = map measure children+      stackViewSize = foldl' (\vs -> stackViewSize' vs . ann) (fixed_ 0) measured+      stackViewSize' a b = ViewSize+        { minWidth = max <$> a.minWidth <*> b.minWidth -- intersection of horizontal flex+        , maxWidth = min <$> a.maxWidth <*> b.maxWidth+        , minHeight = max <$> a.minHeight <*> b.minHeight --  intersection of vertical flex+        , maxHeight = min <$> a.maxHeight <*> b.maxHeight+        }+  Overlay{primary, secondary} -> Overlay{ann=primary'.ann, primary=primary', secondary=secondary'}+    where+      primary' = measure primary -- pass-through wrt primary measurements+      secondary' = measure secondary -- ignore secondary flex++-- | Run the propose-report-place protocol on a flex-measured view tree+place :: LayoutView stuff => Box -> View ViewSize stuff -> View Box (Placed stuff)+place parent element = snd (suspend parent.size element) parent++-- | Propose-Report-Place protocol using continuations+--+-- Inner children can't be placed until the whole propose-report dance finishes.+suspend+  :: forall stuff+  .  LayoutView stuff+  => Vec2+  -> View ViewSize stuff+  -> (Vec2, Box -> View Box (Placed stuff))+suspend proposed = \case+  Spacer{} ->+    ( proposed -- report the proposed+    , \placed -> Spacer{ann=placed} -- keep the placed+    )+  View{stuff} ->+    ( reported -- report dynamic size+    , \placed ->+        View+          { ann = placed+          , stuff = placeView @stuff placed cache -- instantiate the placed view+          }+    )+    where+      (reported, cache) = proposeView proposed stuff+  Frame{..} ->+    ( size -- frame reports its size right away+    , \placedFrame ->+        Frame+          { ann = placedFrame -- keep the placed for itself+          , inner =+              let+                -- now that the frame has its own box, it can properly place its contents+                innerBox = Layout.placeSize align reported placedFrame+              in+                -- and resolve the continuation+                suspended innerBox+          , ..+          }+    )+    where+      (reported, suspended) = suspend size inner -- frame proposes its size+  FlexibleFrame{..} ->+    ( vsClamp proposed flex reported -- reports clamped to self, while defaulting to parent+    , \placed ->+        let+          innerBox = Layout.placeSize align reported placed+        in+          FlexibleFrame+            { ann = placed+            , inner = suspended innerBox+            , ..+            }+    )+    where+      -- proposes clamped parent+      (reported, suspended) = suspend (vsClamp proposed flex proposed) inner+  Padding{..} ->+    ( reported + pads+    , \placed ->+        let+          innerBox = Box.addPadding trbl placed+        in+        Padding+          { ann = placed+          , inner = suspended innerBox+          , ..+          }+    )+    where+      (reported, suspended) = suspend (proposed - pads) inner+      pads = withVec4 trbl4 \t r b l -> vec2 (l + r) (t + b)+      Box.TRBL trbl4 = trbl+  Offset{..} ->+    ( reported+    , \placed -> Offset+        { ann = placed+        , inner = suspended $ Box.move xy placed+        , ..+        }+    )+    where+      (reported, suspended) = suspend proposed inner+  AspectRatio{..} ->+    ( reported+    , \placed ->+        let+          innerBox = Layout.placeSize align reported placed+        in+        AspectRatio+          { ann = placed+          , inner = suspended innerBox+          , ..+          }+    )+    where+      -- 1. query direct size, ignore suspended+      probed = fst $ suspend (aspect ^* scale proposed) inner+      -- 2. re-query with the fit size+      (reported, suspended) = suspend (aspect ^* scale probed) inner+      scale p =+        withVec2 aspect \aw ah ->+          withVec2 p \pw ph ->+            if pw / ph > aw / ah then+              ph / ah+            else+              pw / aw+  HStack{children} ->+    -- Like the Frame, but operating on multiple elements+    ( foldl' combineH 0 $ map fst children' -- stack reports the combined size of its children reports+    , \placedStack ->+        let+          placedChildren :: [View Box (Placed stuff)]+          placedChildren = snd $ mapAccumL placeLeftToRight placedStack children'+            where+              placeLeftToRight :: Box -> (Vec2, Box -> View Box (Placed stuff)) -> (Box, View Box (Placed stuff))+              placeLeftToRight remaining (reportedSize, suspended) =+                ( remaining'+                , suspended placed+                )+                where+                  (slot, remaining') = withVec2 reportedSize \w _h -> Layout.cutLeft w remaining+                  placed = Layout.placeSize Alignment.center reportedSize slot+        in+          HStack+            { ann = maybe placedStack (foldMap1' ann) $ nonEmpty placedChildren+            , children = placedChildren+            }+    )+    where+      -- | Record index, sort by flexibility, process, restore order+      children' =+        toList . array (0, numChildren - 1) $+          snd $ mapAccumL f (fromIntegral numChildren, proposed) $+            sortOn (widthFlexibility . ann . snd) $ zip [0 :: Int ..] children+      numChildren = length children++      f (childrenRemaining, WithVec2 remW remH) (ix, child) =+        ( (childrenRemaining - 1.0, vec2 (remW - reportedWidth) remH)+        , ( ix+          , child'+          ) -- XXX: can use combineH here+        )+        where+          WithVec2 reportedWidth _ = fst child'+          child' = suspend (vec2 proposeWidth remH) child+          proposeWidth = remW / childrenRemaining+  VStack{children} ->+    -- Like the HStack, but advancing vertically+    ( foldl' combineV 0 $ map fst children'+    , \placedStack ->+        let+          placedChildren :: [View Box (Placed stuff)]+          placedChildren = snd $ mapAccumL placeTopToBottom placedStack children'+            where+              placeTopToBottom :: Box -> (Vec2, Box -> View Box (Placed stuff)) -> (Box, View Box (Placed stuff))+              placeTopToBottom remaining (reportedSize, suspended) =+                ( remaining'+                , suspended placed+                )+                where+                  (slot, remaining') = withVec2 reportedSize \_w h -> Layout.cutTop h remaining+                  placed = Layout.placeSize Alignment.center reportedSize slot+        in+          VStack+            { ann = maybe placedStack (foldMap1' ann) $ nonEmpty placedChildren+            , children = placedChildren+            }+    )+    where+      -- | Record index, sort by flexibility, process, restore order+      children' =+        toList . array (0, numChildren - 1) $+          snd $ mapAccumL f (fromIntegral numChildren, proposed) $+            sortOn (heightFlexibility . ann . snd) $ zip [0 :: Int ..] children+      numChildren = length children++      f (childrenRemaining, WithVec2 remW remH) (ix, child) =+        ( (childrenRemaining - 1.0, vec2 remW (remH - reportedHeight))+        , ( ix+          , child'+          ) -- XXX: can use combineH here+        )+        where+          WithVec2 _ reportedHeight = fst child'+          child' = suspend (vec2 remW proposeHeight) child+          proposeHeight = remH / childrenRemaining+  ZStack{children} ->+    ( foldl' max2 0 reporteds+    , \placedStack ->+        let+          placedChildren = map ($ placedStack) suspendeds+        in+          ZStack+            { ann = maybe placedStack (foldMap1' ann) $ nonEmpty placedChildren+            , children = placedChildren+            }+    )+    where+      (reporteds, suspendeds) = unzip $ map (suspend proposed) children+  Overlay{primary, secondary} ->+    ( reportedPri+    , \placed ->+        let+          placedPrimary = suspendedPri placed+        in+          Overlay+            { ann = placed+            , primary = placedPrimary+            , secondary = suspendedSec placedPrimary.ann -- inspect primary box+            }+    )+    where+      (reportedPri, suspendedPri) = suspend proposed primary+      (_reportedSec, suspendedSec) = suspend reportedPri secondary -- inspect primary size++-- * Internals++inf :: Float+inf = 1 / 0++widthFlexibility :: ViewSize -> Float+widthFlexibility ViewSize{..} = maybeBoth (-1) (-) maxWidth minWidth++heightFlexibility :: ViewSize -> Float+heightFlexibility ViewSize{..} = maybeBoth (-1) (-) maxHeight minHeight++vsClamp :: Vec2 -> ViewSize -> Vec2 -> Vec2+vsClamp parent ViewSize{..} v =+  withVec2 parent \pw ph ->+    withVec2 v \w h ->+      vec2+        (maybeBoth pw (glClamp w) minWidth maxWidth)+        (maybeBoth ph (glClamp h) minHeight maxHeight)++{-# INLINE maybeBoth #-}+maybeBoth :: t1 -> (t2 -> t3 -> t1) -> Maybe t2 -> Maybe t3 -> t1+maybeBoth _ j (Just a) (Just b) = j a b+maybeBoth n _ _ _ = n++combineH :: Vec2 -> Vec2 -> Vec2+combineH a b =+  withVec2 a \aw ah ->+    withVec2 b \bw bh ->+      vec2 (aw + bw) (max ah bh)++combineV :: Vec2 -> Vec2 -> Vec2+combineV a b =+  withVec2 a \aw ah ->+    withVec2 b \bw bh ->+      vec2 (max aw bw) (ah + bh)++max2 :: Vec2 -> Vec2 -> Vec2+max2 a b =+  withVec2 a \aw ah ->+    withVec2 b \bw bh ->+      vec2 (max aw bw) (max ah bh)

@@ -0,0 +1,419 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}++module Examples where++import Lucid.Svg++import Control.Monad (unless)+import Data.Foldable (for_)+import Data.Function ((&))+import Data.String (IsString(..))+import Geomancy.Layout.Alignment qualified as Alignment+import Geomancy.Layout.Box (Box(..))+import Geomancy.Layout.Box qualified as Box+import Geomancy.Layout.View (LayoutView(..), View(..), ViewSize(..), layout)+import Geomancy.Layout.View qualified as ViewSize+import Geomancy.Vec2 (Vec2, vec2, pattern WithVec2)+import Lucid.Svg qualified as SVG++toSVGfile :: forall stuff . (LayoutView stuff, Show (Placed stuff), SVGStuff (Placed stuff)) => FilePath -> View () stuff -> IO ()+toSVGfile path =+  SVG.renderToFile path . toSVG @stuff . layout exampleScreenBox++class SVGStuff stuff where+  svgStuff :: stuff -> String++instance SVGStuff String where+  svgStuff = id++instance SVGStuff Dynamic where+  svgStuff = \case+    Label s -> s+    Icon s -> s++toSVG :: (LayoutView stuff, SVGStuff (Placed stuff)) => View Box (Placed stuff) -> Svg ()+toSVG = svg . go+  where+    go = \case+      View{ann, stuff} -> g_ [class_ "view"] $ contents ann "red" (svgStuff  stuff)+      Spacer{ann} -> g_ [class_ "spacer"] $ contents ann "#acf" ""+      HStack{ann, children} -> g_ [class_ "hstack"] $ contents ann "#afa" "" <> for_ children go+      VStack{ann, children} -> g_ [class_ "vstack"] $ contents ann "#aaf" "" <> for_ children go+      ZStack{ann, children} -> g_ [class_ "zstack"] $ contents ann "#faa" "" <> for_ children go+      Overlay{primary, secondary} -> g_ [class_ "overlay"] $ go primary <> go secondary+      Frame{ann, inner} -> g_ [class_ "frame"] $ contents ann "#faf" "" <> go inner+      FlexibleFrame{ann, inner} -> g_ [class_ "flex"] $ contents ann "#ffa" "" <> go inner+      Padding{inner} -> g_ [class_ "padding"] $ go inner -- dashed rect?+      Offset{inner} -> g_ [class_ "offset"] $ go inner -- dashed rect?+      AspectRatio{ann, inner} -> g_ [class_ "aspect"] $ contents ann "#aff" "" <> go inner++    svg :: Svg () -> Svg ()+    svg content = do+      doctype_+      with+        (svg11_ $ rect_ [width_ "100%", height_ "100%", fill_ "#ddd"] <> content+        )+        [ version_ "1.1"+        , width_ "800"+        , height_ "600"+        ]++    -- contents :: SVG.Svg ()++    contents box color ss = do+      let (WithVec2 x y, _br) = Box.toCorners box+      -- let WithVec2 x y = position - size * 0.5+      let WithVec2 w h = box.size+      rect_+        [ x_ (fromString $ show x)+        , y_ (fromString $ show y)+        , width_ (fromString $ show w)+        , height_ (fromString $ show h)+        , fill_ color+        , fill_opacity_ "0.5"+        , stroke_ "black"+        , stroke_width_ "1"+        , rx_ "12"+        ]+      unless (null ss) $ text_+        [ x_ (fromString $ show $ x + w / 2)+        , y_ (fromString $ show $ y + (h + 10) / 2)+        , font_size_ "16"+        , text_anchor_ "middle"+        , text_ "middle"+        , fill_ "black"+        ]+        (fromString ss)+        -- (fromString . show $ (position, size))++newtype Static = Static String+  deriving newtype (Eq, Ord, Show, IsString)++instance LayoutView Static where+  type ReportedCache Static = String+  type Placed Static = String+  viewFlexibility _ = ViewSize.infinite_{minWidth=Just 20, minHeight=Just 20}+  proposeView proposed (Static s) = (proposed, s)+  placeView _box = id++data Dynamic+  = Label String -- ^ Trims content to fit+  | Icon String -- ^ Fixed size/content+  deriving (Eq, Ord, Show)++instance LayoutView Dynamic where+  type ReportedCache Dynamic = (Int, Dynamic)+  viewFlexibility = \case+    Label s ->+      -- The way SwiftUI does it (allegedly)+      ViewSize.range_+        (fst . proposeView 0 $ Label s)+        (fst . proposeView (1/0) $ Label s)+    Icon{} -> ViewSize.fixed_ 32+  proposeView (WithVec2 w _h) e = case e of+    Label s -> (vec2 maxWidth 32, (len, e'))+      where+        charWidth = 10+        maxChars = floor (w / charWidth)+        trimmed =+          if maxChars > 0 && maxChars < length s then+            take maxChars s+          else+            s+        len = length trimmed+        maxWidth = fromIntegral len * charWidth+        e' = Label trimmed+    Icon _ -> (32, (2, e))+  placeView _parent (_len, e) = e++-- | Set up screen box with the top-left corner at 0,0 and origin at 400,300+exampleScreenBox :: Box+exampleScreenBox = Box+  { position = exampleScreenSize / 2 -- use 0,0 origin to match SVG+  , size = exampleScreenSize+  }++exampleScreenSize :: Vec2+exampleScreenSize = vec2 800 600++{- | 2 flexible views split parent in equal halves++@+HStack+  {ann =+     Box+       {position = Vec2 400.0 300.0,+        size = Vec2 800.0 600.0},+   children =+     [View+        {ann =+           Box+             {position = Vec2 200.0 300.0,+              size = Vec2 400.0 600.0},+         stuff = "400x600"},+      View+        {ann =+           Box+             {position = Vec2 600.0 300.0,+              size = Vec2 400.0 600.0},+         stuff = "400x600"}]}+@+-}+exampleHalves :: View () Static+exampleHalves =+  HStack ()+    [ View () "400x600"+    , View () "400x600"+    ]++{- | Mixing fixed and flexible views++@+HStack+  {ann =+     Box+       {position = Vec2 400.0 300.0,+        size = Vec2 800.0 600.0},+   children =+     [Frame+        {ann =+           Box+             {position = Vec2 50.0 300.0, size = Vec2 100.0 50.0},+         size = Vec2 100.0 50.0,+         align = Alignment (Vec2 0.5 0.5),+         inner =+           View+             {ann =+                Box+                  {position = Vec2 50.0 300.0, size = Vec2 100.0 50.0},+              stuff = "Fixed 100x50"}},+      Spacer+        {ann =+           Box+             {position = Vec2 255.0 300.0,+              size = Vec2 310.0 600.0}},+      View+        {ann =+           Box+             {position = Vec2 565.0 300.0,+              size = Vec2 310.0 600.0},+         stuff = "Flexible 310x600"},+      Frame+        {ann =+           Box+             {position = Vec2 760.0 40.0, size = Vec2 80.0 80.0},+         size = Vec2 80.0 80.0,+         align = Alignment (Vec2 0.0 0.0),+         inner =+           View+             {ann =+                Box+                  {position = Vec2 760.0 40.0, size = Vec2 80.0 80.0},+              stuff = "Fixed 80x80"}}]}+@+-}+exampleTree :: View () Static+exampleTree =+  HStack ()+    [ Frame () (vec2 100 50) Alignment.centerBottom $ -- Fixed size+        View () "Fixed 100x50" -- Inherited+    , Spacer () -- Flexible (Infinite)+    , View () "Flexible 310x600" -- Flexible (Infinite)+    , Frame () (vec2 80 80) Alignment.leftTop $ -- Fixed size+        View () "Fixed 80x80" -- Inherited+    ]++{- | Smoke test for frames asserting the view sizes++@+Frame+  {ann =+     Box+       {position = Vec2 400.0 300.0,+        size = Vec2 800.0 600.0},+   size = Vec2 800.0 600.0,+   align = Alignment (Vec2 0.5 0.5),+   inner =+     HStack+       {ann =+          Box+            {position = Vec2 400.0 300.0,+             size = Vec2 800.0 600.0},+        children =+          [Frame+             {ann =+                Box+                  {position = Vec2 200.0 300.0,+                   size = Vec2 400.0 600.0},+              size = Vec2 400.0 600.0,+              align = Alignment (Vec2 0.5 0.5),+              inner =+                View+                  {ann =+                     Box+                       {position = Vec2 200.0 300.0,+                        size = Vec2 400.0 600.0},+                   stuff = "400x600"}},+           Frame+             {ann =+                Box+                  {position = Vec2 600.0 300.0,+                   size = Vec2 400.0 600.0},+              size = Vec2 400.0 600.0,+              align = Alignment (Vec2 0.5 0.5),+              inner =+                View+                  {ann =+                     Box+                       {position = Vec2 600.0 300.0,+                        size = Vec2 400.0 600.0},+                   stuff = "400x600"}}]}}+@+-}+exampleFramed :: View () Static+exampleFramed =+  Frame () exampleScreenBox.size Alignment.center $ -- XXX: no-op+    HStack ()+      [ Frame () (vec2 400 600) Alignment.center $ View () "400x600"+      , Frame () (vec2 400 600) Alignment.center $ View () "400x600"+      ]++{- | Smoke test for nesting HStacks++@+HStack+  {ann =+     Box+       {position = Vec2 400.0 300.0,+        size = Vec2 800.0 600.0},+   children =+     [HStack+        {ann =+           Box+             {position = Vec2 400.0 300.0,+              size = Vec2 800.0 600.0},+         children =+           [HStack+              {ann =+                 Box+                   {position = Vec2 200.0 300.0,+                    size = Vec2 400.0 600.0},+               children =+                 [View+                    {ann =+                       Box+                         {position = Vec2 200.0 300.0,+                          size = Vec2 400.0 600.0},+                     stuff = "400x600"}]},+            HStack+              {ann =+                 Box+                   {position = Vec2 600.0 300.0,+                    size = Vec2 400.0 600.0},+               children =+                 [View+                    {ann =+                       Box+                         {position = Vec2 600.0 300.0,+                          size = Vec2 400.0 600.0},+                     stuff = "400x600"}]}]}]}+@+-}+exampleNested :: View () Static+exampleNested =+  HStack () . pure $ -- XXX: no-op+    HStack ()+      [ HStack () [View () "400x600"] -- XXX: no-op wrapped halves+      , HStack () [View () "400x600"]+      ]++{- | The stack conents is larger than the screen size.++@+HStack+  {ann =+     Box+       {position = Vec2 550.0 300.0,+        size = Vec2 1100.0 600.0},+   children =+     [Frame+        {ann =+           Box+             {position = Vec2 250.0 300.0,+              size = Vec2 500.0 600.0},+         size = Vec2 500.0 600.0,+         align = Alignment (Vec2 0.5 0.5),+         inner =+           View+             {ann =+                Box+                  {position = Vec2 250.0 300.0,+                   size = Vec2 500.0 600.0},+              stuff = "500x600"}},+      Frame+        {ann =+           Box+             {position = Vec2 800.0 300.0,+              size = Vec2 600.0 600.0},+         size = Vec2 600.0 600.0,+         align = Alignment (Vec2 0.5 0.5),+         inner =+           View+             {ann =+                Box+                  {position = Vec2 800.0 300.0,+                   size = Vec2 600.0 600.0},+              stuff = "600x600"}}]}+@+-}+exampleOverflow :: View () Static+exampleOverflow =+  HStack ()+    [ Frame () (vec2 500 600) Alignment.center $ View () "500x600"+    , Frame () (vec2 600 600) Alignment.center $ View () "600x600"+    ]++{- | The views report their flex and real size.++Icons should be flush with their labels.+The pair-hstack should hug its elements.+The spacer between them should push the pairs away from the center.+-}+exampleDynamic :: View () Dynamic+exampleDynamic =+  Padding () (Box.TRBL 32) $+  Offset () (vec2 0 32) $+  AspectRatio () 1 Alignment.center $+  HStack ()+    [ HStack ()+        [ View () $ Label "very large"+        , View () $ Icon "💅"+        ]+    , Spacer ()+    , FlexibleFrame () (ViewSize.range_ 60 100 & ViewSize.parentHeight) Alignment.centerTop $+        HStack ()+          [ View () $ Label "very large"+          , View () $ Icon "💅"+          ]+    ]++exampleDynamicVert :: View () Dynamic+exampleDynamicVert =+  Padding () (Box.TRBL 32) $+  ZStack () . (FlexibleFrame () ViewSize.parent_ Alignment.rightBottom (View () $ Icon "✋") :) . pure $ -- this is getting out of hand...+  Offset () (vec2 0 32) $+  AspectRatio () 1 Alignment.center $+  VStack ()+    [ HStack ()+        [ View () $ Label "very large"+        , View () $ Icon "💅"+        ]+    , Spacer ()+        & Overlay () (Frame () 128 Alignment.rightTop . Offset () (vec2 16 (-16)) $ View () $ Icon "🌈")+    , FlexibleFrame () (ViewSize.range_ 60 100 & ViewSize.parentWidth) Alignment.leftMiddle $+        HStack ()+          [ View () $ Label "very large"+          , View () $ Icon "💅"+          ]+    ]

@@ -0,0 +1,20 @@+import Prelude++import Test.Tasty+import Test.Tasty.HUnit++import Examples++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Examples"+  [ testCase "Tree" $ toSVGfile "examples/Tree.svg" exampleTree+  , testCase "Halves" $ toSVGfile "examples/Halves.svg" exampleHalves+  , testCase "Overflow" $ toSVGfile "examples/Overflow.svg" exampleOverflow+  , testCase "Framed" $ toSVGfile "examples/Framed.svg" exampleFramed+  , testCase "Nested" $ toSVGfile "examples/Nested.svg" exampleNested+  , testCase "Dynamic" $ toSVGfile "examples/Dynamic.svg" exampleDynamic+  , testCase "DynamicVert" $ toSVGfile "examples/DynamicVert.svg" exampleDynamicVert+  ]