80 lines
2 KiB
Plaintext
80 lines
2 KiB
Plaintext
module LayoutLens.Data.Geometry where
|
|
|
|
import LayoutLens.Prelude
|
|
|
|
import Data.Array as Array
|
|
import LayoutLens.Data.Vec2
|
|
( AABB(..)
|
|
, Polygon(..)
|
|
, ScalePreservingTransform
|
|
, Vec2(..)
|
|
, aabbToPolygon
|
|
, applyScalePreservingTransform
|
|
, mapPoints
|
|
, vinv
|
|
, vscale
|
|
)
|
|
|
|
data Attribute = Fill Color | Stroke Color
|
|
type Attributes = Array Attribute
|
|
type GenericAttributes = Array (String /\ String)
|
|
|
|
type Arc =
|
|
{ radius :: Number
|
|
, to :: Vec2
|
|
}
|
|
|
|
data PathStep
|
|
= MoveTo Vec2
|
|
| LineTo Vec2
|
|
| Arc Arc
|
|
| Close
|
|
|
|
data Geometry
|
|
= Transform ScalePreservingTransform Geometry
|
|
| Many (Array Geometry)
|
|
| Text GenericAttributes Attributes String
|
|
| Rect AABB Attributes
|
|
| Path (Array PathStep) Attributes
|
|
|
|
-- Approximate the size of some geometry by fitting a polygon around it
|
|
boundingPolygon :: Geometry -> Polygon
|
|
boundingPolygon = case _ of
|
|
Rect aabb _ -> aabbToPolygon aabb
|
|
Text _ _ _ -> mempty
|
|
Many array -> foldMap boundingPolygon array
|
|
Transform t g -> mapPoints (applyScalePreservingTransform t) $ boundingPolygon g
|
|
Path steps _ -> foldMap snd $ Array.scanl (points <<< fst) mempty steps
|
|
where
|
|
points :: Vec2 -> PathStep -> Vec2 /\ Polygon
|
|
points prev = case _ of
|
|
Close -> prev /\ Polygon []
|
|
MoveTo a -> a /\ Polygon [ a ]
|
|
LineTo a -> a /\ Polygon [ a ]
|
|
-- This is just an approximation where we fit an AABB around the circle.
|
|
Arc arc -> arc.to /\ aabbToPolygon aabb
|
|
where
|
|
aabb = AABB
|
|
{ position: center <> vinv diagonal
|
|
, size: vscale 2.0 diagonal
|
|
}
|
|
|
|
diagonal = Vec2 arc.radius arc.radius
|
|
center = vscale 0.5 $ arc.to <> prev
|
|
|
|
derive instance Eq Attribute
|
|
derive instance Eq PathStep
|
|
derive instance Eq Geometry
|
|
derive instance Generic Attribute _
|
|
derive instance Generic PathStep _
|
|
derive instance Generic Geometry _
|
|
|
|
instance Debug Attribute where
|
|
debug = genericDebug
|
|
|
|
instance Debug PathStep where
|
|
debug = genericDebug
|
|
|
|
instance Debug Geometry where
|
|
debug a = genericDebug a
|