Get text centering working

Required significant architectural changes
2025-08-13 22:51:47 -07:00
parent 9cd101ee4f
commit 77942030ef
2 changed files with 179 additions and 75 deletions
--- a/src/Main.purs
+++ b/src/Main.purs
@@ -9,12 +9,13 @@ import Data.Foldable as Foldable
 import Data.Map as Map
 import Data.Maybe (Maybe(..))
 import Data.Number.Format (toString)
+import Data.Set as Set
 import Data.Tuple as Tup
 import Effect (Effect)
 import Effect.Console (log)
 import Effect.Class (liftEffect)
 import Effect.Exception (throw)
-import TernaryGraph (ternaryGraph, tickLabelStrings)
+import TernaryGraph (Dimension, ternaryGraph, TextStyle, tickLabelStrings)
 import Web.DOM.Document (contentType
  , createElement
  , Document
@@ -27,14 +28,16 @@ import Web.DOM.Document (contentType
  )
 import Web.DOM.DOMParser (makeDOMParser, parseSVGFromString)
 import Web.DOM.Element as Element -- (Element, setAttribute, toEventTarget, toNode) as Element
-import Web.DOM.Node (appendChild, Node, nodeName, setTextContent)
+import Web.DOM.Node (appendChild, childNodes, Node, nodeName, removeChild, setTextContent)
+import Web.DOM.NodeList as NodeList
 import Web.DOM.NonElementParentNode (getElementById)
 import Web.DOM.ParentNode (firstElementChild)
 import Web.Event.Event (Event, EventType(..))
 import Web.Event.EventTarget (addEventListener, eventListener)
 import Web.HTML (window)
+import Web.HTML.HTMLElement as HTMLElement
 import Web.HTML.HTMLInputElement as HTMLInput
-import Web.HTML.HTMLDocument (toDocument)
+import Web.HTML.HTMLDocument as HTMLDoc
 import Web.HTML.Window (document)

 myGetElementById :: Document -> String -> Effect Element.Element
@@ -51,19 +54,18 @@ getNodeById doc id = do
    Nothing -> throw $ "Unable to find element with ID '" <> id <> "'"
    Just e -> pure $ Element.toNode e

-type Dimension =
-  { widthPx :: Number
-  , heightPx :: Number
-  }
-
-type TextStyle =
-  {  typeface :: String
-  ,  sizePx :: Number
-  }
-
-getTextDimensions :: Document -> TextStyle -> String -> Effect Dimension
-getTextDimensions doc style text = do
+getTextDimensions :: HTMLDoc.HTMLDocument -> TextStyle -> String -> Effect Dimension
+getTextDimensions htmlDoc style text = do
+  let doc = HTMLDoc.toDocument htmlDoc
  el :: Element.Element <- createElement "span" doc
+
+  bodyMay <- HTMLDoc.body htmlDoc
+  bodyNode <- case bodyMay of 
+    Nothing -> throw "Could not find body of HTML document"
+    Just e -> pure $ Element.toNode (HTMLElement.toElement e)
+
+  appendChild (Element.toNode el) bodyNode
+
  let styleText = ( 
  "font" <> style.typeface
  <> ";font: " <> style.typeface
@@ -78,16 +80,19 @@ getTextDimensions doc style text = do
  setTextContent text (Element.toNode el)
  width <- Element.clientWidth el
  height <- Element.clientHeight el
+
+  removeChild (Element.toNode el) bodyNode
+
  pure { widthPx: width, heightPx: height }

-converter :: Document -> (Map.Map (Tup.Tuple String TextStyle) Dimension) -> (Tup.Tuple String TextStyle) -> Effect (Map.Map (Tup.Tuple String TextStyle) Dimension)
+converter :: HTMLDoc.HTMLDocument -> (Map.Map (Tup.Tuple String TextStyle) Dimension) -> (Tup.Tuple String TextStyle) -> Effect (Map.Map (Tup.Tuple String TextStyle) Dimension)
 converter doc map textTuple = do
  let text = Tup.fst textTuple
  let style = Tup.snd textTuple
  dimension <- getTextDimensions doc style text
  pure $ Map.insert textTuple dimension map

-getAllTextDimensions :: forall f. Foldable.Foldable f => Document -> f (Tup.Tuple String TextStyle) -> Effect (Map.Map (Tup.Tuple String TextStyle) Dimension)
+getAllTextDimensions :: forall f. Foldable.Foldable f => HTMLDoc.HTMLDocument -> f (Tup.Tuple String TextStyle) -> Effect (Map.Map (Tup.Tuple String TextStyle) Dimension)
 getAllTextDimensions doc strings = 
  Foldable.foldM (converter doc) Map.empty strings

@@ -95,7 +100,7 @@ update :: Event -> Effect Unit
 update e = do
  w <- window
  d <- document w
-  let document = toDocument d
+  let document = HTMLDoc.toDocument d
  domParser <- makeDOMParser

  log "update"
@@ -107,28 +112,34 @@ update e = do

  svgContainer <- getNodeById document "svg-container"

-  let tickText = tickLabelStrings ticks 0 0 10
-  --let allTicks = Foldable.foldr (\a b -> a <> ", " <> b) "" tickText
-  --log allTicks
-
-  let tickStyle = { 
-    typeface: "Liberation Mono",
-    sizePx: 12.0
+  let graphDef = { axis1Label: "axis 1"
+  , axis2Label: "axis 2"
+  , axis3Label: "axis 3"
+  , axis1Start: 0
+  , axis2Start: 1
+  , axis3Start: 20
+  , numTicks: ticks
+  , tickTextStyle: { sizePx: 12.0
+    , typeface: "Liberation Sans"
+    }
+  , axisTitleTextStyle: { sizePx: 16.0
+    , typeface: "Liberation Mono"
    }
-  let axisTitleTextStyle = {
-     typeface: "Liberation Sans",
-     sizePx: 16.0
  }

-  let tickTextStyles = Foldable.foldr (\text textStyleArray -> Array.cons (Tup.Tuple text tickStyle) textStyleArray) [] tickText 
-  let textStyles = tickTextStyles <> [ 
-    (Tup.Tuple "axis 1" axisTitleTextStyle),
-    (Tup.Tuple "axis 2" axisTitleTextStyle),
-    (Tup.Tuple "axis 3" axisTitleTextStyle)
+  let tickText = tickLabelStrings graphDef
+
+  let tickTextStyles = Foldable.foldr (\text textStyleArray -> Array.cons (Tup.Tuple text graphDef.tickTextStyle) textStyleArray) [] tickText 
+  let textStyles = tickTextStyles <> [ (Tup.Tuple graphDef.axis1Label graphDef.axisTitleTextStyle)
+    , (Tup.Tuple graphDef.axis2Label graphDef.axisTitleTextStyle)
+    , (Tup.Tuple graphDef.axis3Label graphDef.axisTitleTextStyle)
  ]
-  textDimensions <- getAllTextDimensions document textStyles
+  textDimensions <- getAllTextDimensions d textStyles

-  let mySVG = ternaryGraph 100.0 50.0 50.0 ticks textDimensions
+  let mySVGErr = ternaryGraph 100.0 50.0 50.0 graphDef textDimensions
+  mySVG <- case mySVGErr of
+    Left error -> throw error
+    Right svg -> pure svg
  
  svgDocMay <- parseSVGFromString mySVG domParser
  svgDoc <- case svgDocMay of
@@ -140,7 +151,9 @@ update e = do
    Nothing -> throw "no child in svg doc"
    Just el -> pure $ Element.toNode el

-  -- TODO: remove existing node?
+  containerKids <- (childNodes svgContainer) >>= NodeList.toArray
+  Foldable.for_ containerKids \kid -> do
+    removeChild kid svgContainer

  newNode <- importNode svgNode true document
  appendChild newNode svgContainer
@@ -149,12 +162,46 @@ main :: Effect Unit
 main = do
  w <- window
  d <- document w
-  let dd = toDocument d
+  let dd = HTMLDoc.toDocument d
  domParser <- makeDOMParser

  svgContainer <- getNodeById dd "svg-container"

-  let mySVG = ternaryGraph 100.0 50.0 50.0 10
+  let graphDef = { axis1Label: "axis 1"
+  , axis2Label: "axis 2"
+  , axis3Label: "axis 3"
+  , axis1Start: 0
+  , axis2Start: 1
+  , axis3Start: 20
+  , numTicks: 10
+  , tickTextStyle: { sizePx: 12.0
+    , typeface: "Liberation Sans"
+    }
+  , axisTitleTextStyle: { sizePx: 16.0
+    , typeface: "Liberation Mono"
+    }
+  }
+
+  let tickText = tickLabelStrings graphDef
+
+  log $ Array.intercalate ",\n" (Set.toUnfoldable tickText)
+
+  let tickTextStyles = Foldable.foldr (\text textStyleArray -> Array.cons (Tup.Tuple text graphDef.tickTextStyle) textStyleArray) [] tickText 
+  let textStyles = tickTextStyles <> [ (Tup.Tuple graphDef.axis1Label graphDef.axisTitleTextStyle)
+    , (Tup.Tuple graphDef.axis2Label graphDef.axisTitleTextStyle)
+    , (Tup.Tuple graphDef.axis3Label graphDef.axisTitleTextStyle)
+  ]
+  textDimensions <- getAllTextDimensions d textStyles
+
+  log $ Foldable.foldr (\dim str -> str <> "\n" <> (toString dim.widthPx) <> ", " <> (toString dim.heightPx)) "" $ Map.values textDimensions
+
+  let textDimensions2 = Map.mapMaybe (\dim -> Just {widthPx: 0.0, heightPx: 0.0}) textDimensions
+
+  let mySVGErr = ternaryGraph 100.0 50.0 50.0 graphDef textDimensions2
+  mySVG <- case mySVGErr of
+    Left error -> throw error
+    Right svg -> pure svg
+  
  svgDocMay <- parseSVGFromString mySVG domParser
  svgDoc <- case svgDocMay of
    Left error -> throw error
--- a/src/TernaryGraph.purs
+++ b/src/TernaryGraph.purs
@@ -1,24 +1,50 @@
 module TernaryGraph where

-import Prelude (discard, class Monoid, class Semigroup, Unit, ($), (<=), (<<<), (<>), (*), (+), (-), (/))
+import Prelude (discard, class Monoid, class Semigroup, Unit, ($), (<=), (<<<), (<>), (*), (+), (-), (/), (&&))

-import Data.Array ((!!), concat, cons, mapWithIndex, range)
+--import Data.Array ((!!), concat, cons, mapWithIndex, range)
+import Data.Array as Array
+import Data.Either as Either
 import Data.Functor (map)
 import Data.Int as Int
 import Data.List (fold)
-import Data.Maybe
+import Data.Map as Map
+import Data.Maybe as Maybe
 import Data.Number (cos, pi, sin)
 import Data.Number.Format (toString)
 import Data.Ord ((<))
 import Data.Ring (negate)
 import Data.Set as Set
+import Data.Tuple as Tup
 import Data.Tuple.Nested (Tuple3, tuple3, get1, get2, get3)

+type Dimension =
+  { widthPx :: Number
+  , heightPx :: Number
+  }
+
+type TextStyle =
+  {  typeface :: String
+  ,  sizePx :: Number
+  }
+
 type Point =
  { x :: Number
  , y :: Number
  }

+type GraphDefinition =
+  { axis1Label :: String
+  , axis2Label :: String
+  , axis3Label :: String
+  , axis1Start :: Int
+  , axis2Start :: Int
+  , axis3Start :: Int
+  , numTicks :: Int
+  , tickTextStyle :: TextStyle
+  , axisTitleTextStyle :: TextStyle
+  }
+
 type Line =
  { start :: Point
  , end :: Point
@@ -60,11 +86,14 @@ svgLine { start: {x: x1, y: y1}, end: {x: x2, y: y2} } =
  XMLFragment $ """<path style="fill:none;stroke:#000000;stroke-width:0.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1"
  """ <> "d=\"M " <> (toString x1) <> "," <> (toString y1) <> " " <> (toString x2) <> "," <> (toString y2) <> "\"/>"

-- TODO: position at center of text
-svgText :: String -> Number -> Point -> Number -> XMLFragment
-svgText text fontSize { x: x, y: y } angle =
-  XMLFragment $ "<text xml:space=\"preserve\" style=\"font-size:" <> (toString fontSize) <> "px;line-height:131%;font-family:'Liberation sans';font-variant-position:super;fill:#000000;stroke:#000000;stroke-width:0.0999998;stroke-linecap:round;stop-color:#000000;fill-opacity:1\" "
-  <> "transform=\"translate(" <> (toString x) <> ", " <> (toString y) <> ") rotate(" <> (toString angle) <> ")\">" <> text <> "</text>"
+svgText :: String -> Point -> Number -> TextStyle -> Dimension -> XMLFragment
+svgText text { x: x, y: y } angle style dimension =
+  XMLFragment $ "<text xml:space=\"preserve\" style=\"font-size:" <> (toString style.sizePx) <> "px;line-height:131%;font-family:'" <> style.typeface <> "';font-variant-position:super;fill:#000000;stroke:#000000;stroke-width:0.0999998;stroke-linecap:round;stop-color:#000000;fill-opacity:1\" "
+  <> "transform=\"translate(" <> (toString centerX) <> ", " <> (toString centerY) <> ") rotate(" <> (toString angle) <> ")\">" <> text <> "</text>"
+  where
+    -- TODO: why /4? this also was needed in python implementation
+    centerX = x - dimension.widthPx / 4.0
+    centerY = y - dimension.heightPx / 4.0

 -- TODO: Make axis tick size a parameter
 getTick :: Number -> Int -> Int -> Line
@@ -80,7 +109,7 @@ getTicks :: Number -> Number -> Int -> Tuple3 (Array Line) (Array Line) (Array L
 getTicks scale angle numTicks =
  tuple3 axis1Lines axis2Lines axis3Lines
  where
-    foo = map (getTick scale numTicks) (range 0 numTicks)
+    foo = map (getTick scale numTicks) (Array.range 0 numTicks)
    axis1Lines = map (rotateLine angle) foo
    axis2Lines = map (rotateLine (2.0 * pi / 3.0)) axis1Lines
    axis3Lines = map (rotateLine (2.0 * pi / 3.0)) axis2Lines
@@ -105,30 +134,30 @@ ternaryGraphSvg fragments = """<?xml version="1.0" encoding="UTF-8"?>
 axesPoints :: Number -> Tuple3 Point Point Point
 axesPoints angle = tuple3 
  (rotate angle { x: 0.0, y: 1.0 })
-  (rotate angle { x: -(sin (2.0 * pi / 3.0)), y : -0.5})
+  (rotate angle { x: -(sin (2.0 * pi / 3.0)), y : -0.5 })
  (rotate angle { x: (sin (2.0 * pi / 3.0)), y: -0.5 })

 axesPath :: Point -> Point -> Point -> XMLFragment
 axesPath p1 p2 p3 = XMLFragment $ """<path style="fill:none;stroke:#000000;stroke-width:1;stroke-linecap:bevel;stroke-linejoin:bevel;stroke-dasharray:none;stroke-opacity:1"
 """ <> "d=\"M " <> (toString p1.x) <> "," <> (toString p1.y) <> " " <> (toString p2.x) <> "," <> (toString p2.y) <> " " <> (toString p3.x) <> "," <> (toString p3.y) <> " Z\"/>"

-tickLabelStrings :: Int -> Int -> Int -> Int -> Set.Set String
-tickLabelStrings numTicks axis1Start axis2Start axis3Start =
+tickLabelStrings :: GraphDefinition -> Set.Set String
+tickLabelStrings def =
  Set.map (\x -> "E" <> (toString (Int.toNumber x))) axisTicks
  where
-    axis1Ticks = Set.fromFoldable (range axis1Start (axis1Start + numTicks - 1))
-    axis2Ticks = Set.fromFoldable (range axis2Start (axis2Start + numTicks - 1))
-    axis3Ticks = Set.fromFoldable (range axis3Start (axis3Start + numTicks - 1))
+    axis1Ticks = Set.fromFoldable (Array.range def.axis1Start (def.axis1Start + def.numTicks))
+    axis2Ticks = Set.fromFoldable (Array.range def.axis2Start (def.axis2Start + def.numTicks))
+    axis3Ticks = Set.fromFoldable (Array.range def.axis3Start (def.axis3Start + def.numTicks))
    axisTicks = Set.union (Set.union axis1Ticks axis2Ticks) axis3Ticks

-ternaryGraph :: Number -> Number -> Number -> Int -> String
-ternaryGraph scale xOffset yOffset numTicks = ternaryGraphSvg fragments
+ternaryGraph :: Number -> Number -> Number -> GraphDefinition -> Map.Map (Tup.Tuple String TextStyle) Dimension -> Either.Either String String
+ternaryGraph scale xOffset yOffset definition textDimensions = result
  where
-    axisTickLines = getTicks scale pi numTicks
+    axisTickLines = getTicks scale pi definition.numTicks
    axis1TickLines = map (transformLine scale xOffset yOffset) (get1 axisTickLines)
    axis2TickLines = map (transformLine scale xOffset yOffset) (get2 axisTickLines)
    axis3TickLines = map (transformLine scale xOffset yOffset) (get3 axisTickLines)
-    tickLines = concat [axis1TickLines, axis2TickLines, axis3TickLines]
+    tickLines = Array.concat [axis1TickLines, axis2TickLines, axis3TickLines]
    tickLinesSvg = fold $ map svgLine tickLines

    axesPointsPi = axesPoints pi
@@ -137,27 +166,55 @@ ternaryGraph scale xOffset yOffset numTicks = ternaryGraphSvg fragments
    axisPoint3 = transform scale xOffset yOffset (get3 axesPointsPi)
    axesPathSvg = axesPath axisPoint1 axisPoint2 axisPoint3

-    -- TODO: axis text size
+    axis1TitleDim = Map.lookup (Tup.Tuple definition.axis1Label definition.axisTitleTextStyle) textDimensions
+    axis2TitleDim = Map.lookup (Tup.Tuple definition.axis2Label definition.axisTitleTextStyle) textDimensions
+    axis3TitleDim = Map.lookup (Tup.Tuple definition.axis3Label definition.axisTitleTextStyle) textDimensions
+
+    axisTitleSize = definition.axisTitleTextStyle.sizePx
+    axisTitlesSvg :: Array (Either.Either String XMLFragment)
    axisTitlesSvg = [
-      svgText "axis 1" 12.0 (transform scale xOffset yOffset {x: 0.0, y: 0.9}) 0.0,
-      svgText "axis 2" 12.0 (transform scale xOffset yOffset {x: -(sin (2.0 * pi / 3.0)), y: -0.7}) (-60.0),
-      svgText "axis 3" 12.0 (transform scale xOffset yOffset {x: (sin (2.8 * pi / 3.0)), y: -0.7}) 60.0
+      case axis1TitleDim of
+        Maybe.Nothing -> Either.Left ("Failed to find '" <> definition.axis1Label <> "' in dimensions map") 
+        Maybe.Just dim -> Either.Right $ svgText definition.axis1Label (transform scale xOffset yOffset {x: 0.0, y: 0.9}) 0.0 definition.axisTitleTextStyle dim,
+      case axis2TitleDim of
+        Maybe.Nothing -> Either.Left ("Failed to find '" <> definition.axis2Label <> "' in dimensions map") 
+        Maybe.Just dim -> Either.Right $ svgText definition.axis2Label (transform scale xOffset yOffset {x: -(sin (2.0 * pi / 3.0)), y: -0.7}) (-60.0) definition.axisTitleTextStyle dim,
+      case axis3TitleDim of
+        Maybe.Nothing -> Either.Left ("Failed to find '" <> definition.axis3Label <> "' in dimensions map") 
+        Maybe.Just dim -> Either.Right $ svgText definition.axis3Label (transform scale xOffset yOffset {x: (sin (2.8 * pi / 3.0)), y: -0.7}) 60.0 definition.axisTitleTextStyle dim
    ]
 
    axisTickStarts = map (\line -> line.start)
-    -- TODO: tick label size
-    -- TODO: axis tick label rotation
-    -- TODO: axis tick start number
-    axisTickLabels = \rotation -> mapWithIndex (\i point -> svgText ("E" <> (toString (Int.toNumber i))) 10.0 point 0.0) 
+    -- svgText :: String -> Point -> Number -> TextStyle -> Dimension -> XMLFragment
+    -- svgText text { x: x, y: y } angle style dimension =
    
-    axis1TickLabels = axisTickLabels 0 $ axisTickStarts axis1TickLines
-    axis2TickLabels = axisTickLabels 0 $ axisTickStarts axis2TickLines
-    axis3TickLabels = axisTickLabels 0 $ axisTickStarts axis3TickLines
+    axisTickLabels = \rotation startI -> Array.mapWithIndex (\i point -> 
+      let text = ("E" <> (toString (Int.toNumber (i + startI))))
+          angle = 0.0
+          labelText = case Map.lookup (Tup.Tuple text definition.tickTextStyle) textDimensions of
+            Maybe.Nothing -> Either.Left ("Failed to find '" <> text <> "' in dimensions map") 
+            Maybe.Just dimension -> Either.Right $ svgText text point angle definition.tickTextStyle dimension
+      in labelText
+    )

-    tickLabelsSvg = concat [
-      axis1TickLabels,
-      axis2TickLabels,
-      axis3TickLabels
-    ]
+    axis1TickLabels :: Array (Either.Either String XMLFragment)
+    axis1TickLabels = axisTickLabels 0.0 definition.axis1Start $ axisTickStarts axis1TickLines
+    axis2TickLabels = axisTickLabels 0.0 definition.axis2Start $ axisTickStarts axis2TickLines
+    axis3TickLabels = axisTickLabels 0.0 definition.axis3Start $ axisTickStarts axis3TickLines

-    fragments = concat [[tickLinesSvg, axesPathSvg], axisTitlesSvg, tickLabelsSvg]
+    labelFragmentsErr = Array.concat [axisTitlesSvg, axis1TickLabels, axis2TickLabels, axis3TickLabels]
+
+    labelFragments = Array.foldr (\labelFragmentErr soFar -> case labelFragmentErr of
+      Either.Left _ -> soFar
+      Either.Right labelFragment -> Array.cons labelFragment soFar) [] labelFragmentsErr
+
+    errors = Array.foldr (\labelFragmentErr soFar -> case labelFragmentErr of
+      Either.Left labelFragment -> Array.cons labelFragment soFar
+      Either.Right _ -> soFar) [] labelFragmentsErr
+
+    fragments = Array.concat [[tickLinesSvg, axesPathSvg], labelFragments]
+    result = if Array.all (\x -> Either.isRight x) labelFragmentsErr then
+      Either.Right $ ternaryGraphSvg fragments
+      else
+      -- TODO: Include specific labels
+      Either.Left $ Array.intercalate "\n" errors