Add UIComponent class with toSVG method (#305)

statebox · Feb 5, 2020 · 2a41551 · 2a41551
1 parent 7572230
commit 2a41551
Show file tree

Hide file tree

Showing 5 changed files with 101 additions and 88 deletions.
diff --git a/halogen-grid-kit/src/GridKit/Example/Example.purs b/halogen-grid-kit/src/GridKit/Example/Example.purs
@@ -3,8 +3,8 @@ module GridKit.Example.Example where
 import Prelude hiding (div)
 
 import Data.Array ((..))
-import Data.Int (toNumber, floor)
-import Data.Lens (Lens, (+~), (-~), (%~))
+import Data.Int (toNumber, floor, even)
+import Data.Lens (Lens', (+~), (-~), (%~))
 import Data.Lens.Record (prop)
 import Data.Maybe
 import Data.Number (fromString)
@@ -22,9 +22,12 @@ import Svg.Elements as S
 import Svg.Attributes as S
 
 import GridKit.KeyHandler
+import GridKit.UIComponent
 import View.ReactiveInput as ReactiveInput
-import View.GridKit.Grid as Grid
-import View.GridKit.Point as Point
+import View.GridKit.Grid (Grid(..))
+import View.GridKit.Point (Point(..))
+import View.GridKit.Rect (Rect(..))
+
 
 type Input = {}
 
@@ -40,44 +43,54 @@ type State =
   , keyHelpVisible :: Boolean
   }
 
-_logScale :: ∀ a b r. Lens { logScale :: a | r } { logScale :: b | r } a b
+_logScale :: Lens' State Number
 _logScale = prop (SProxy :: SProxy "logScale")
 
-_keyHelpVisible :: ∀ a b r. Lens { keyHelpVisible :: a | r } { keyHelpVisible :: b | r } a b
+_keyHelpVisible :: Lens' State Boolean
 _keyHelpVisible = prop (SProxy :: SProxy "keyHelpVisible")
 
-type ChildSlots =
-  ( grid :: Grid.Slot Unit
-  , point :: Point.Slot Int
-  )
+initialState :: State
+initialState =
+  { logSpacing: 1.0
+  , logScale: 0.0
+  , posX: 0.0
+  , posY: 0.0
+  , radius: 0.5
+  , count: 10.0
+  , keyHelpVisible: false
+  }
+
 
-ui :: ∀ q m. MonadEffect m => H.Component HTML q Input Void m
+data Thing = PointThing Point | RectThing Rect
+
+instance uiComponentThing :: UIComponent Thing where
+  toSVG transform (PointThing p) = toSVG transform p
+  toSVG transform (RectThing  r) = toSVG transform r
+
+newtype Model = Model
+  { grid   :: Grid
+  , things :: Array Thing
+  }
 
+instance uiComponentModel :: UIComponent Model where
+  toSVG transform (Model { grid, things }) = toSVG transform grid <> toSVG transform things
+
+
+ui :: ∀ q m. MonadEffect m => H.Component HTML q Input Void m
 ui = ReactiveInput.mkComponent
-  { initialState:
-    { logSpacing: 1.0
-    , logScale: 0.0
-    , posX: 0.0
-    , posY: 0.0
-    , radius: 0.5
-    , count: 10.0
-    , keyHelpVisible: false
-    }
+  { initialState
   , render
   , handleAction
   , handleInput: \_ -> pure unit
   }
 
-handleAction :: ∀ m. MonadEffect m => Input -> Action -> H.HalogenM State Action ChildSlots Void m Unit
+handleAction :: ∀ m. MonadEffect m => Input -> Action -> H.HalogenM State Action () Void m Unit
 handleAction _ (ChangeState f) = H.modify_ f
 
-render :: ∀ m. MonadEffect m => Input -> State -> H.ComponentHTML Action ChildSlots m
+render :: ∀ m. MonadEffect m => Input -> State -> H.ComponentHTML Action () m
 render _ { logSpacing, logScale, posX, posY, radius, count, keyHelpVisible } = div
   [ tabIndex 0, keys.onKeyDown ]
-  [ S.svg [ S.width (_x size), S.height (_y size) ] $
-          [ grid gridInput ] <>
-          ((1 .. floor count) <#> \n ->
-            point n { position: rotate (toNumber n * 2.0 * pi / count) `transform` point2 radius 0.0, model2svg })
+  [ S.svg [ S.width (_x size), S.height (_y size) ] $ toSVG model2svg model <#> fromPlainHTML
   , p_ [ input [ type_ InputRange, H.min 0.0, H.max 2.0, step Any, value (show logSpacing)
                , onValueInput $ \s -> s # fromString <#> \v -> ChangeState (_ { logSpacing = v })
                ]
@@ -124,10 +137,17 @@ render _ { logSpacing, logScale, posX, posY, radius, count, keyHelpVisible } = d
 
     model2svg = range `containedIn` size
 
-    range = Box { topLeft:     (vec2 (-0.5) (-0.5) - pos) * pure scaling
-                , bottomRight: (vec2   0.5    0.5  - pos) * pure scaling
+    range = Box { topLeft:     pure (-0.5 * scaling) - pos
+                , bottomRight: pure ( 0.5 * scaling) - pos
                 }
 
+    model = Model { grid:   Grid { gridSpacing: pow 10.0 logSpacing, size }
+                  , things: (1 .. floor count) <#> \n ->
+                      let center = rotate (toNumber n * 2.0 * pi / count) `transform` point2 radius 0.0 in
+                      if even n then RectThing $ Rect { topLeft: center - vec2 0.05 0.05, size: vec2 0.1 0.1 }
+                                else PointThing $ Point center
+                  }
+
     zoomInKey = keyHandler
       [ Shortcut metaKey "Equal", Shortcut ctrlKey "Equal"]
       (Just $ text "Zoom in")
@@ -142,12 +162,6 @@ render _ { logSpacing, logScale, posX, posY, radius, count, keyHelpVisible } = d
       , popupAction: ChangeState $ _keyHelpVisible %~ not
       }
 
-grid :: ∀ m. MonadEffect m => Grid.Input -> H.ComponentHTML Action ChildSlots m
-grid input = slot (SProxy :: SProxy "grid") unit Grid.ui input (const Nothing)
-
-point :: ∀ m. MonadEffect m => Int -> Point.Input -> H.ComponentHTML Action ChildSlots m
-point id input = slot (SProxy :: SProxy "point") id Point.ui input (const Nothing)
-
 
 containedIn :: Box Number -> Vec2 Number -> AffineTransform Number
 containedIn range size = translate svgCenter * scale scaleMin * translate (-rangeCenter)

diff --git a/halogen-grid-kit/src/GridKit/UIComponent.purs b/halogen-grid-kit/src/GridKit/UIComponent.purs
@@ -0,0 +1,11 @@
+module GridKit.UIComponent where
+
+import Data.Vec3.AffineTransform
+import Data.Foldable (foldMap)
+import Halogen.HTML (PlainHTML)
+
+class UIComponent a where
+  toSVG :: AffineTransform Number -> a -> Array PlainHTML
+
+instance uiComponentArray :: UIComponent a => UIComponent (Array a) where
+  toSVG transform = foldMap (toSVG transform)
diff --git a/halogen-grid-kit/src/View/GridKit/Grid.purs b/halogen-grid-kit/src/View/GridKit/Grid.purs
@@ -6,43 +6,30 @@ import Data.Array ((..), filter)
 import Data.Int (floor, ceil, toNumber)
 import Data.Vec3 (Vec2, vec2, _x, _y, origin2, point2)
 import Data.Vec3.AffineTransform
-import Effect.Class (class MonadEffect)
-import Halogen as H
 import Halogen.HTML hiding (code, head, prop, map, div)
 import Math (log, pow, ln10, round, sqrt)
 import Svg.Elements as S
 import Svg.Attributes as S
 
-import View.ReactiveInput as ReactiveInput
+import GridKit.UIComponent
 
-
-type Input =
+newtype Grid = Grid
   { gridSpacing :: Number
-  , model2svg :: AffineTransform Number
   , size :: Vec2 Number
   }
 
-data VoidF a
-type Slot = H.Slot VoidF Void
-
-ui :: ∀ q m. MonadEffect m => H.Component HTML q Input Void m
-ui = ReactiveInput.mkComponent
-  { initialState: {}
-  , render
-  , handleAction: \_ _ -> pure unit
-  , handleInput: \_ -> pure unit
-  }
-
-render :: ∀ m. Input -> {} -> H.ComponentHTML Void () m
-render { gridSpacing, model2svg, size } _ =
-  S.g []
-      [ S.g [ S.class_ "grid grid-v" ] $
-          gridLines spacing (_x topLeft) (_x bottomRight)
-            # map \{ width, pos } -> let x = m2s_x pos in S.line [ S.strokeWidth width, S.x1 x, S.y1 0.0, S.x2 x, S.y2 (_y size) ]
-      , S.g [ S.class_ "grid grid-h" ] $
-          gridLines spacing (_y topLeft) (_y bottomRight)
-            # map \{ width, pos } -> let y = m2s_y pos in S.line [ S.strokeWidth width, S.x1 0.0, S.y1 y, S.x2 (_x size), S.y2 y ]
-      ]
+instance uiComponentGrid :: UIComponent Grid where
+  toSVG = render
+
+render :: AffineTransform Number -> Grid -> Array PlainHTML
+render model2svg (Grid { gridSpacing, size }) =
+  [ S.g [ S.class_ "grid grid-v" ] $
+      gridLines spacing (_x topLeft) (_x bottomRight)
+        # map \{ width, pos } -> let x = m2s_x pos in S.line [ S.strokeWidth width, S.x1 x, S.y1 0.0, S.x2 x, S.y2 (_y size) ]
+  , S.g [ S.class_ "grid grid-h" ] $
+      gridLines spacing (_y topLeft) (_y bottomRight)
+        # map \{ width, pos } -> let y = m2s_y pos in S.line [ S.strokeWidth width, S.x1 0.0, S.y1 y, S.x2 (_x size), S.y2 y ]
+  ]
   where
     svg2model = inverse model2svg
     spacing = _x (svg2model `transform` vec2 gridSpacing gridSpacing)

diff --git a/halogen-grid-kit/src/View/GridKit/Point.purs b/halogen-grid-kit/src/View/GridKit/Point.purs
@@ -1,35 +1,16 @@
 module View.GridKit.Point where
 
-import Prelude
-
 import Data.Vec3 (Point2, _x, _y)
 import Data.Vec3.AffineTransform
-import Effect.Class (class MonadEffect)
-import Halogen as H
-import Halogen.HTML
 import Svg.Elements as S
-import Svg.Attributes hiding (path) as S
-
-import View.ReactiveInput as ReactiveInput
-
-type Input =
-  { position :: Point2 Number
-  , model2svg :: AffineTransform Number
-  }
+import Svg.Attributes as S
 
-data VoidF a
-type Slot = H.Slot VoidF Void
+import GridKit.UIComponent
 
-ui :: ∀ q m. MonadEffect m => H.Component HTML q Input Void m
-ui = ReactiveInput.mkComponent
-  { initialState: {}
-  , render
-  , handleAction: \_ _ -> pure unit
-  , handleInput: \_ -> pure unit
-  }
+newtype Point = Point (Point2 Number)
 
-render :: ∀ m. Input -> {} -> H.ComponentHTML Void () m
-render { position, model2svg } _ =
-  S.circle [ S.class_ "point", S.cx (_x center), S.cy (_y center), S.r 5.0 ]
-  where
-    center = model2svg `transform` position
+instance uiComponentPoint :: UIComponent Point where
+  toSVG model2svg (Point position) =
+    [ S.circle [ S.class_ "point", S.cx (_x center), S.cy (_y center), S.r 3.0 ] ]
+    where
+      center = model2svg `transform` position
diff --git a/halogen-grid-kit/src/View/GridKit/Rect.purs b/halogen-grid-kit/src/View/GridKit/Rect.purs
@@ -0,0 +1,20 @@
+module View.GridKit.Rect where
+
+import Data.Vec3 (Point2, Vec2, _x, _y)
+import Data.Vec3.AffineTransform
+import Svg.Elements as S
+import Svg.Attributes as S
+
+import GridKit.UIComponent
+
+newtype Rect = Rect
+  { topLeft :: Point2 Number
+  , size    :: Vec2 Number
+  }
+
+instance uiComponentRect :: UIComponent Rect where
+  toSVG model2svg (Rect { topLeft, size }) =
+    [ S.rect [ S.class_ "rect", S.x (_x xy), S.y (_y xy), S.width (_x wh), S.height (_y wh) ] ]
+    where
+      xy = model2svg `transform` topLeft
+      wh = model2svg `transform` size