{-# 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 "💅"
]
]