Reimplement getAllTextDimensions

Create SVG text elements so that the dimensions are representative

src/Main.purs

@@ -15,7 +15,7 @@ import Effect (Effect)
 import Effect.Console (log)
 import Effect.Class (liftEffect)
 import Effect.Exception (throw)
-import TernaryGraph (Dimension, ternaryGraph, TextStyle, tickLabelStrings)
+import TernaryGraph (Dimension, svgTextID, ternaryGraph, ternaryGraphSvg, TextStyle, tickLabelStrings)
 import Web.DOM.Document (contentType
   , createElement
   , Document
@@ -54,47 +54,55 @@ getNodeById doc id = do
     Nothing -> throw $ "Unable to find element with ID '" <> id <> "'"
     Just e -> pure $ Element.toNode e
 
-getTextDimensions :: HTMLDoc.HTMLDocument -> TextStyle -> String -> Effect Dimension
-getTextDimensions htmlDoc style text = do
-  let doc = HTMLDoc.toDocument htmlDoc
-  el :: Element.Element <- createElement "span" doc
+getAllTextDimensions :: forall f. Foldable.Foldable f => Document -> Node -> f (Tup.Tuple String TextStyle) -> Effect (Map.Map (Tup.Tuple String TextStyle) Dimension)
+getAllTextDimensions document svgContainer strings = do
+  myDomParser <- makeDOMParser
 
-  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)
+  -- Create svg fragments
+  let textID = \i -> "text-" <> (show i)
+  let (Tup.Tuple idMap _) = Foldable.foldr (\strTup (Tup.Tuple map i) -> Tup.Tuple (Map.insert (textID i) strTup map) (i + 1)) (Tup.Tuple Map.empty 0) strings
+  let frag = \str style i -> svgTextID (Just (textID i)) str { x: 0.0, y: 0.0 } 0.0 style { widthPx: 0.0, heightPx: 0.0 }
+  let fragments = Foldable.foldr (\(Tup.Tuple str style) arr -> Array.cons (frag str style (Array.length arr)) arr) [] strings
 
-  appendChild (Element.toNode el) bodyNode
+  -- create svg string
+  let svg = ternaryGraphSvg fragments
 
-  let styleText = ( 
-  "font" <> style.typeface
-  <> ";font-family: " <> style.typeface
-  <> ";font-size: " <> (toString style.sizePx) <> "px"
-  <> ";height: " <> "auto"
-  <> ";width: " <> "auto"
-  <> ";position: " <> "absolute"
-  <> ";white-space: " <> "nowrap"
-  )
+  -- add to container
+  svgDocMay <- parseSVGFromString svg myDomParser
+  svgDoc <- case svgDocMay of
+    Left error -> throw error
+    Right doc -> pure doc
 
-  Element.setAttribute "style" styleText el
-  setTextContent text (Element.toNode el)
-  width <- Element.clientWidth el
-  height <- Element.clientHeight el
+  elMay <- firstElementChild $ toParentNode svgDoc
+  svgNode <- case elMay of
+    Nothing -> throw "no child in svg doc"
+    Just el -> pure $ Element.toNode el
 
-  removeChild (Element.toNode el) bodyNode
+  newNode <- importNode svgNode true document
+  appendChild newNode svgContainer
 
-  pure { widthPx: width, heightPx: height }
+  -- get dimensions for all text elements
+  myMap <- Foldable.foldM (\map i -> do
+    let id = textID i
+    textElement <- myGetElementById document id
+    boundingRect <- Element.getBoundingClientRect textElement
+    
+    let textNFontMay = Map.lookup id idMap
+    textNFont <- case textNFontMay of
+      Nothing -> throw $ "Missing '" <> id <> "' from map"
+      Just x -> pure x
+    
+    log $ id <> ": " <> (toString boundingRect.width) <> ", " <> (toString boundingRect.height)
+    
+    pure $ Map.insert textNFont { widthPx: boundingRect.width, heightPx: boundingRect.height } map
+  ) Map.empty (Array.range 0 ((Array.length fragments) - 1))
 
-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
+  -- remove the svg
+  containerKids <- (childNodes svgContainer) >>= NodeList.toArray
+  Foldable.for_ containerKids \kid -> do
+    removeChild kid svgContainer
 
-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
+  pure myMap
 
 update :: Event -> Effect Unit
 update e = do
@@ -134,7 +142,11 @@ update e = do
     , (Tup.Tuple graphDef.axis2Label graphDef.axisTitleTextStyle)
     , (Tup.Tuple graphDef.axis3Label graphDef.axisTitleTextStyle)
   ]
-  textDimensions <- getAllTextDimensions d textStyles
+  textDimensions <- getAllTextDimensions document svgContainer textStyles
+
+  log $ case Map.lookup (Tup.Tuple "axis 1" graphDef.axisTitleTextStyle) textDimensions of
+    Nothing -> "Not found"
+    Just { widthPx: width, heightPx: height} -> (toString width) <> ", " <> (toString height)
 
   let mySVGErr = ternaryGraph 100.0 50.0 50.0 graphDef textDimensions
   mySVG <- case mySVGErr of
@@ -191,7 +203,7 @@ main = do
     , (Tup.Tuple graphDef.axis2Label graphDef.axisTitleTextStyle)
     , (Tup.Tuple graphDef.axis3Label graphDef.axisTitleTextStyle)
   ]
-  textDimensions <- getAllTextDimensions d textStyles
+  textDimensions <- getAllTextDimensions dd svgContainer textStyles
 
   log $ Foldable.foldr (\dim str -> str <> "\n" <> (toString dim.widthPx) <> ", " <> (toString dim.heightPx)) "" $ Map.values textDimensions
 

src/TernaryGraph.purs

@@ -87,13 +87,19 @@ svgLine { start: {x: x1, y: y1}, end: {x: x2, y: y2} } =
   """ <> "d=\"M " <> (toString x1) <> "," <> (toString y1) <> " " <> (toString x2) <> "," <> (toString y2) <> "\"/>"
 
 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 <> "';fill:#000000;stroke:#000000;stroke-width:0.0999998;stroke-linecap:round;stop-color:#000000;fill-opacity:1\" "
+svgText = svgTextID Maybe.Nothing
+
+svgTextID :: Maybe.Maybe String -> String -> Point -> Number -> TextStyle -> Dimension -> XMLFragment
+svgTextID idMaybe text { x: x, y: y } angle style dimension =
+  XMLFragment $ "<text " <> idText <> " xml:space=\"preserve\" style=\"font-size:" <> (toString style.sizePx) <> "px;line-height:131%;font-family:'" <> style.typeface <> "';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 * 180.0 / pi)) <> ")\">" <> text <> "</text>"
   where
     offset = rotate angle {x: dimension.widthPx, y: dimension.heightPx}
-    centerX = x - offset.x / 2.0
-    centerY = y - offset.y / 2.0
+    centerX = x - offset.x / 4.0
+    centerY = y - offset.y / 4.0
+    idText = case idMaybe of
+      Maybe.Nothing -> ""
+      Maybe.Just id -> "id=\"" <> id <> "\""
 
 -- TODO: Make axis tick size a parameter
 getTick :: Number -> Int -> Int -> Line
@@ -173,6 +179,7 @@ ternaryGraph scale xOffset yOffset definition textDimensions = result
     axis1TitlePos = {x: 0.0, y: 0.9}
     axis2TitlePos = rotate (2.0 * pi / 3.0) axis1TitlePos
     axis3TitlePos = rotate (-2.0 * pi / 3.0) axis1TitlePos
+
     axisTitleSize = definition.axisTitleTextStyle.sizePx
     axisTitlesSvg :: Array (Either.Either String XMLFragment)
     axisTitlesSvg = [