Win a fight with svg transforms

layout-lens/spago.lock

@@ -562,7 +562,7 @@ workspace:
   extra_packages:
     debugged:
       git: https://github.com/mateiadrielrafael/purescript-debugged.git
-      ref: 0d5a4149279129f10c8fe2a3ef280b9fde4d5116
+      ref: 70d4b2e19c8831753a62a4527b0c8c40a25b2a4e
 packages:
   aff:
     type: registry
@@ -694,7 +694,7 @@ packages:
   debugged:
     type: git
     url: https://github.com/mateiadrielrafael/purescript-debugged.git
-    rev: 0d5a4149279129f10c8fe2a3ef280b9fde4d5116
+    rev: 70d4b2e19c8831753a62a4527b0c8c40a25b2a4e
     dependencies:
       - arrays
       - bifunctors

layout-lens/spago.yaml

@@ -23,4 +23,5 @@ workspace:
   extra_packages:
     debugged:
       git: https://github.com/mateiadrielrafael/purescript-debugged.git
-      ref: 0d5a4149279129f10c8fe2a3ef280b9fde4d5116
+      ref: 70d4b2e19c8831753a62a4527b0c8c40a25b2a4e
+

layout-lens/src/Data/Config.purs

@@ -36,7 +36,7 @@ type PhysicalExecutionStep = { block :: Array PhysicalKey, keys :: Array Physica
 transformKey :: ScalePreservingTransform -> PhysicalKey -> PhysicalKey
 transformKey transform (PhysicalKey key) = PhysicalKey
   { size: key.size
-  , transform: composeScalePreservingTransforms key.transform transform
+  , transform: composeScalePreservingTransforms transform key.transform
   }
 
 buildPhysical :: RawPhysical -> PhysicalLayout

layout-lens/src/Data/Geometry.purs

@@ -3,19 +3,21 @@ module LayoutLens.Data.Geometry where
 import LayoutLens.Prelude
 
 import Data.Array as Array
+import LayoutLens.Data.Vec2 as V
 import LayoutLens.Data.Vec2
   ( AABB(..)
   , Polygon(..)
-  , ScalePreservingTransform
   , Vec2(..)
   , aabbToPolygon
-  , applyScalePreservingTransform
+  , applyTransform
+  , boundingBox
   , mapPoints
+  , tTranslate
   , vinv
   , vscale
   )
 
-data Attribute = Fill Color | Stroke Color
+data Attribute = Fill Color | Stroke Color | StrokeWidth Number
 type Attributes = Array Attribute
 type GenericAttributes = Array (String /\ String)
 
@@ -31,28 +33,30 @@ data PathStep
   | Close
 
 data Geometry
-  = Transform ScalePreservingTransform Geometry
+  = Transform V.Transform Geometry
   | Many (Array Geometry)
   | Text GenericAttributes Attributes String
   | Rect AABB Attributes
   | Path (Array PathStep) Attributes
+  | Invisible Geometry
 
 -- Approximate the size of some geometry by fitting a polygon around it
-boundingPolygon :: Geometry -> Polygon
+boundingPolygon :: Geometry -> Maybe Polygon
 boundingPolygon = case _ of
-  Rect aabb _ -> aabbToPolygon aabb
-  Text _ _ _ -> mempty
+  Rect aabb _ -> pure $ aabbToPolygon aabb
+  Text _ _ _ -> Nothing
   Many array -> foldMap boundingPolygon array
-  Transform t g -> mapPoints (applyScalePreservingTransform t) $ boundingPolygon g
+  Invisible g -> boundingPolygon g
+  Transform t g -> mapPoints (applyTransform t) <$> boundingPolygon g
   Path steps _ -> foldMap snd $ Array.scanl (points <<< fst) mempty steps
     where
-    points :: Vec2 -> PathStep -> Vec2 /\ Polygon
+    points :: Vec2 -> PathStep -> Vec2 /\ Maybe Polygon
     points prev = case _ of
-      Close -> prev /\ Polygon []
-      MoveTo a -> a /\ Polygon [ a ]
-      LineTo a -> a /\ Polygon [ a ]
+      Close -> prev /\ Nothing
+      MoveTo a -> a /\ (pure $ Polygon $ pure a)
+      LineTo a -> a /\ (pure $ Polygon $ pure a)
       -- This is just an approximation where we fit an AABB around the circle.
-      Arc arc -> arc.to /\ aabbToPolygon aabb
+      Arc arc -> arc.to /\ pure (aabbToPolygon aabb)
         where
         aabb = AABB
           { position: center <> vinv diagonal
@@ -62,6 +66,21 @@ boundingPolygon = case _ of
         diagonal = Vec2 arc.radius arc.radius
         center = vscale 0.5 $ arc.to <> prev
 
+-- | Add padding around some geometry
+pad :: Vec2 -> Geometry -> Geometry
+pad padding geometry = case boundingBox <$> boundingPolygon geometry of
+  Just (AABB box) -> Many
+    [ Transform (tTranslate padding) geometry
+    , Invisible $ Rect
+        ( AABB
+            { position: box.position
+            , size: box.size <> vscale 2.0 padding
+            }
+        )
+        []
+    ]
+  Nothing -> geometry
+
 derive instance Eq Attribute
 derive instance Eq PathStep
 derive instance Eq Geometry

layout-lens/src/Data/Svg.purs

@@ -4,20 +4,24 @@ import LayoutLens.Prelude
 
 import Data.Array as Array
 import Data.String (Pattern(..))
-import LayoutLens.Data.Geometry (Geometry(..), Attribute(..), Attributes, GenericAttributes, PathStep(..))
-import LayoutLens.Data.Vec2 (AABB(..), ScalePreservingTransform(..), Vec2(..), radiansToDegrees, x, y)
+import LayoutLens.Data.Geometry (Attribute(..), Attributes, GenericAttributes, Geometry(..), PathStep(..), boundingPolygon)
+import LayoutLens.Data.Vec2 (AABB(..), Vec2(..), boundingBox, x, y)
+import LayoutLens.Data.Vec2 as V
 
 indent :: String -> String
 indent = split (Pattern "\n") >>> map ("  " <> _) >>> unlines
 
+printAttributes :: GenericAttributes -> String
+printAttributes attributes = joinWith " "
+  $ uncurry (\key value -> fold [ key, "=\"", value, "\"" ])
+  <$> attributes
+
 tag :: String -> GenericAttributes -> String -> String
 tag name attributes child = fold
   [ "<"
   , name
   , " "
-  , joinWith " "
-      $ uncurry (\key value -> fold [ key, "=\"", value, "\"" ])
-      <$> attributes
+  , printAttributes attributes
   , ">"
   , indent child
   , "</"
@@ -26,12 +30,19 @@ tag name attributes child = fold
   ]
 
 leaf :: String -> GenericAttributes -> String
-leaf name attributes = tag name attributes mempty
+leaf name attributes = fold
+  [ "<"
+  , name
+  , " "
+  , printAttributes attributes
+  , "/>"
+  ]
 
 printGeometryAttributes :: Attributes -> GenericAttributes
 printGeometryAttributes = map case _ of
   Fill color -> "fill" /\ toHexString color
   Stroke color -> "stroke" /\ toHexString color
+  StrokeWidth number -> "stroke-width" /\ show number
 
 px :: Number -> String
 px n = show n <> "px"
@@ -39,6 +50,7 @@ px n = show n <> "px"
 -- Render a geometry to svg
 renderGeometry :: Geometry -> String
 renderGeometry = case _ of
+  Invisible _ -> ""
   Many array -> unlines $ renderGeometry <$> array
 
   Rect (AABB aabb) proper ->
@@ -47,8 +59,8 @@ renderGeometry = case _ of
       <>
         [ "x" /\ show (x aabb.position)
         , "y" /\ show (y aabb.position)
-        , "width" /\ px (x aabb.size)
-        , "height" /\ px (y aabb.size)
+        , "width" /\ show (x aabb.size)
+        , "height" /\ show (y aabb.size)
         ]
 
   Path steps proper ->
@@ -78,12 +90,37 @@ renderGeometry = case _ of
       (generic <> printGeometryAttributes proper)
       string
 
-  Transform (ScalePreservingTransform transform) g ->
+  Transform (V.Transform transform) g ->
     tag "g"
-      [ "transform" /\ fold
-          [ "rotate("
-          , show $ radiansToDegrees transform.rotation
+      [ "transform" /\ joinWith " "
+          [ "matrix("
+          , show $ transform.scale * cos (unwrap transform.rotation)
+          , show $ transform.scale * sin (unwrap transform.rotation)
+          , show $ transform.scale * -sin (unwrap transform.rotation)
+          , show $ transform.scale * cos (unwrap transform.rotation)
+          , show $ x transform.position
+          , show $ y transform.position
           , ")"
           ]
       ]
       $ renderGeometry g
+
+-- | Adds the necessary boilerplate to store svg inside a file
+makeSvgDocument :: Geometry -> String
+makeSvgDocument geometry = tag "svg" attributes $ renderGeometry geometry
+  where
+  attributes =
+    [ "xmlns" /\ "http://www.w3.org/2000/svg"
+    , "xmlns:xlink" /\ "http://www.w3.org/1999/xlink"
+    ]
+      <>
+        case boundingBox <$> boundingPolygon geometry of
+          Nothing -> []
+          Just (AABB box) -> pure
+            $ "viewBox"
+            /\ joinWith " "
+              [ show $ x box.position
+              , show $ y box.position
+              , show $ x box.size
+              , show $ y box.size
+              ]

layout-lens/src/Data/Vec2.purs

@@ -2,10 +2,16 @@ module LayoutLens.Data.Vec2 where
 
 import LayoutLens.Prelude
 
+import Data.Array.NonEmpty as NEA
+import Partial.Unsafe (unsafePartial)
+
 newtype Radians = Radians Number
 data Vec2 = Vec2 Number Number
 
 -- {{{ Base helpers
+-- | Multiply by the matrix
+-- |   cos Θ  -sin Θ
+-- |   sin Θ   cos Θ
 rotateBy :: Radians -> Vec2 -> Vec2
 rotateBy (Radians angle) (Vec2 x y) = Vec2 (x * c - y * s) (x * s + y * c)
   where
@@ -30,25 +36,46 @@ x (Vec2 x _) = x
 y :: Vec2 -> Number
 y (Vec2 _ y) = y
 
+origin :: Vec2
+origin = Vec2 0.0 0.0
+
 -- }}}
 -- {{{ Shapes
 newtype AABB = AABB { position :: Vec2, size :: Vec2 }
-newtype Polygon = Polygon (Array Vec2)
+newtype Polygon = Polygon (NonEmptyArray Vec2)
 
 aabbToPolygon :: AABB -> Polygon
 aabbToPolygon (AABB aabb@{ size: Vec2 sx sy }) = Polygon
+  $ unsafePartial -- Safe because the array always has four elements
+  $ fromJust
+  $ NEA.fromArray
       [ aabb.position
       , aabb.position <> Vec2 0.0 sy
       , aabb.position <> aabb.size
       , aabb.position <> Vec2 sx 0.0
       ]
 
+-- | The left-inverse of `aabbToPolygon`
+boundingBox :: Polygon -> AABB
+boundingBox (Polygon points) = AABB
+  { position: Vec2 minX minY
+  , size: Vec2 (maxX - minX) (maxY - minY)
+  }
+  where
+  minX = NEA.foldl1 min $ x <$> points
+  minY = NEA.foldl1 min $ y <$> points
+  maxX = NEA.foldl1 max $ x <$> points
+  maxY = NEA.foldl1 max $ y <$> points
+
 mapPoints :: (Vec2 -> Vec2) -> (Polygon -> Polygon)
 mapPoints f (Polygon points) = Polygon $ f <$> points
 
 aabbCenter :: AABB -> Vec2
 aabbCenter (AABB aabb) = aabb.position <> vscale 0.5 aabb.size
 
+originAabb :: Vec2 -> AABB
+originAabb size = AABB { position: origin, size }
+
 -- }}}
 -- {{{ Transforms
 newtype RawScalePreservingTransform = RawScalePreservingTransform
@@ -62,24 +89,72 @@ newtype ScalePreservingTransform = ScalePreservingTransform
   , rotation :: Radians
   }
 
-normalizeScalePreservingTransform
-  :: RawScalePreservingTransform -> ScalePreservingTransform
-normalizeScalePreservingTransform (RawScalePreservingTransform t) = ScalePreservingTransform
-  { rotation: t.rotateBy
-  , position: t.rotateAround <> rotateBy t.rotateBy (vsub t.position t.rotateAround)
+newtype Transform = Transform
+  { scale :: Number
+  , position :: Vec2
+  , rotation :: Radians
   }
 
+-- | Intuitivey, the raw transformation has form
+-- |   v ↦ r_Θ(v + a) - a + p,
+-- | but rotations are linear, so the above can be rewritten as
+-- |   v ↦ r_Θ(v) + (r_Θ(a) - a + p),
+-- | which is what this function does.
+-- |
+-- | The other case works similarly
+normalizeScalePreservingTransform
+  :: RawScalePreservingTransform -> ScalePreservingTransform
+normalizeScalePreservingTransform (RawScalePreservingTransform t) =
+  ScalePreservingTransform
+    { rotation: t.rotateBy
+    , position: t.rotateAround
+        <> rotateBy t.rotateBy (t.position <> vinv t.rotateAround)
+    }
+
+-- | We want to compose
+-- |   f(v) = r_Θ(v) + p_f
+-- |   s(v) = r_ϕ(v) + p_s,
+-- | which yields
+-- |   (s ∘ f)(v) = r_ϕ(r_Θ(v) + p_f) + p_s
+-- |              = r_ϕ(r_Θ(v)) + r_ϕ(p_f) + p_s
+-- |              = r_(ϕ+Θ)(v) + (r_ϕ(p_f) + p_s)
 composeScalePreservingTransforms
   :: ScalePreservingTransform -> ScalePreservingTransform -> ScalePreservingTransform
-composeScalePreservingTransforms (ScalePreservingTransform first) (ScalePreservingTransform second) =
+composeScalePreservingTransforms (ScalePreservingTransform second) (ScalePreservingTransform first) =
   ScalePreservingTransform
     { rotation: first.rotation <> second.rotation
     , position: second.position <> rotateBy second.rotation first.position
     }
 
+forgetScalePreservingStructure :: ScalePreservingTransform -> Transform
+forgetScalePreservingStructure (ScalePreservingTransform transform) =
+  Transform
+    { position: transform.position
+    , rotation: transform.rotation
+    , scale: 1.0
+    }
+
 applyScalePreservingTransform :: ScalePreservingTransform -> Vec2 -> Vec2
-applyScalePreservingTransform (ScalePreservingTransform transform) v =
-  rotateBy transform.rotation v <> transform.position
+applyScalePreservingTransform = forgetScalePreservingStructure >>> applyTransform
+
+applyTransform :: Transform -> Vec2 -> Vec2
+applyTransform (Transform transform) v =
+  -- Rotations are linear, thus they commute with scaling.
+  vscale transform.scale (rotateBy transform.rotation v) <> transform.position
+
+tScale :: Number -> Transform
+tScale factor = Transform
+  { scale: factor
+  , position: origin
+  , rotation: mempty
+  }
+
+tTranslate :: Vec2 -> Transform
+tTranslate position = Transform
+  { scale: 1.0
+  , rotation: mempty
+  , position
+  }
 
 -- }}}
 
@@ -89,12 +164,14 @@ derive instance Eq AABB
 derive instance Eq Polygon
 derive instance Eq RawScalePreservingTransform
 derive instance Eq ScalePreservingTransform
+derive instance Eq Transform
 derive instance Generic Vec2 _
 derive instance Generic Radians _
 derive instance Generic AABB _
 derive instance Generic Polygon _
 derive instance Generic RawScalePreservingTransform _
 derive instance Generic ScalePreservingTransform _
+derive instance Generic Transform _
 
 instance Debug Vec2 where
   debug = genericDebug
@@ -114,6 +191,9 @@ instance Debug RawScalePreservingTransform where
 instance Debug ScalePreservingTransform where
   debug = genericDebug
 
+instance Debug Transform where
+  debug = genericDebug
+
 instance Semigroup Vec2 where
   append (Vec2 a b) (Vec2 c d) = Vec2 (a + c) (b + d)
 
@@ -128,4 +208,4 @@ instance Monoid Vec2 where
 instance Monoid Radians where
   mempty = Radians 0.0
 
-derive newtype instance Monoid Polygon
+derive instance Newtype Radians _

layout-lens/src/Generate/Svg.purs

@@ -0,0 +1,29 @@
+module LayoutLens.Generate.Svg where
+
+import LayoutLens.Prelude
+
+import LayoutLens.Data.Config as C
+import LayoutLens.Data.Geometry (Attribute(..))
+import LayoutLens.Data.Geometry as G
+import LayoutLens.Data.Svg as S
+import LayoutLens.Data.Vec2 (forgetScalePreservingStructure, originAabb, tScale, vscale)
+
+type SvgString = String
+
+renderPhysicalKey :: C.PhysicalKey -> G.Attributes -> G.Geometry
+renderPhysicalKey (C.PhysicalKey key) attributes = do
+  G.Transform (forgetScalePreservingStructure key.transform)
+    $ G.Rect (originAabb key.size) attributes
+
+renderPhysicalLayout :: C.PhysicalLayout -> G.Geometry
+renderPhysicalLayout (C.PhysicalLayout layout) =
+  G.Transform (tScale 100.0)
+    $ G.Many
+    $ flip renderPhysicalKey attributes
+    <$> layout
+  where
+  attributes =
+    [ Fill $ rgb 200 200 50
+    , Stroke black
+    , StrokeWidth 0.1
+    ]

layout-lens/src/Main.purs

@@ -2,16 +2,28 @@ module Main where
 
 import LayoutLens.Prelude
 
-import LayoutLens.Data.Config (PhysicalLayout(..), buildConfig, buildPhysical)
-import LayoutLens.Data.RawConfig (RawConfig(..))
+import LayoutLens.Data.Config (LensConfig(..), buildConfig)
+import LayoutLens.Data.Geometry (pad)
+import LayoutLens.Data.Svg (makeSvgDocument)
+import LayoutLens.Data.Vec2 (Vec2(..))
+import LayoutLens.Generate.Svg (renderPhysicalLayout)
 import LayoutLens.Parser (parseConfig)
 import Node.Encoding (Encoding(..))
-import Node.FS.Aff (readTextFile)
+import Node.FS.Aff (readTextFile, writeTextFile)
 
 main :: Effect Unit
 main = launchAff_ do
   file <- readTextFile UTF8 "../keyboards/qmk/ferris-sweep/config.lens"
+  -- file <- readTextFile UTF8 "./input.lens"
   case parseConfig file of
     Left err -> log err
     Right result -> do
-      logPretty $ buildConfig result
+      let (LensConfig config) = buildConfig result
+      logPretty config
+      -- logPretty $ boundingPolygon $ renderPhysicalLayout config.physical
+      writeTextFile UTF8 "./output.svg"
+        $ makeSvgDocument
+        $ pad (Vec2 30.0 30.0)
+        $ renderPhysicalLayout
+        $ config.physical
+

layout-lens/src/Parser.purs

@@ -90,6 +90,7 @@ name = ows *> P.try do
     , "section"
     , "layer"
     , "block"
+    , "pre"
     , "end"
     , "point"
     , "place"
@@ -151,7 +152,12 @@ physical = do
       angle <- radians
       around <- P.option position vec2
       pure $ angle /\ around
-    pure $ Place $ RawScalePreservingTransform { position, rotateBy, rotateAround }
+    pure $ Place $
+      RawScalePreservingTransform
+        { position
+        , rotateBy
+        , rotateAround
+        }
 
   point :: Parser RawPhysicalActionStep
   point = do
@@ -163,7 +169,11 @@ physical = do
     let rotateAround = position
     let
       point a b c d = Point
-        { transform: RawScalePreservingTransform { position: a, rotateBy: b, rotateAround: c }
+        { transform: RawScalePreservingTransform
+            { position: a
+            , rotateBy: b
+            , rotateAround: c
+            }
         , size: d
         }
     case arguments of

layout-lens/src/Prelude.purs

@@ -26,6 +26,7 @@ module LayoutLens.Prelude
   , module Data.Monoid.Generic
   , module Data.String
   , module Data.List
+  , module Data.Array.NonEmpty
   , wrapInto
   , unimplemented
   , logPretty
@@ -62,6 +63,7 @@ import Effect.Class.Console (clear, group, groupCollapsed, groupEnd, grouped, in
 import Effect.Exception.Unsafe (unsafeThrow)
 import Prim.TypeError (class Warn, Text)
 import Safe.Coerce (class Coercible, coerce)
+import Data.Array.NonEmpty (NonEmptyArray)
 
 unimplemented :: forall a. Warn (Text "unimplemenet") => a
 unimplemented = unsafeThrow "unimplemented"

layout-lens/vim/ftdetect/lens.vim

@@ -0,0 +1 @@
+au BufNewFile,BufRead *.lens set filetype=lens

layout-lens/vim/syntax/lens.vim

@@ -1,12 +1,12 @@
-" if exists("b:current_syntax")
-"     finish
-" endif
+if exists("b:current_syntax")
+    finish
+endif
 
 set iskeyword+=-
 
 syntax keyword lensKeyword physical section layergroup layer chordgroup block end
 syntax keyword lensAction sticky-switch switch
-syntax keyword lensFunction columns place action key
+syntax keyword lensFunction columns place action key after before
 syntax keyword lensLayerName center topleft topright bottomleft bottomright
 
 syntax match lensComment "\v--.*$"