Get text centering working

Required significant architectural changes

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 =
+getTextDimensions :: HTMLDoc.HTMLDocument -> TextStyle -> String -> Effect Dimension
-  { widthPx :: Number
+getTextDimensions htmlDoc style text = do
-  , heightPx :: Number
+  let doc = HTMLDoc.toDocument htmlDoc
-  }
-
-type TextStyle =
-  {  typeface :: String
-  ,  sizePx :: Number
-  }
-
-getTextDimensions :: Document -> TextStyle -> String -> Effect Dimension
-getTextDimensions doc style text = do
   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 graphDef = { axis1Label: "axis 1"
-  --let allTicks = Foldable.foldr (\a b -> a <> ", " <> b) "" tickText
+  , axis2Label: "axis 2"
-  --log allTicks
+  , axis3Label: "axis 3"
-
+  , axis1Start: 0
-  let tickStyle = { 
+  , axis2Start: 1
-    typeface: "Liberation Mono",
+  , axis3Start: 20
-    sizePx: 12.0
+  , numTicks: ticks
-  }
+  , tickTextStyle: { sizePx: 12.0
-  let axisTitleTextStyle = {
+    , typeface: "Liberation Sans"
-     typeface: "Liberation Sans",
+    }
-     sizePx: 16.0
+  , axisTitleTextStyle: { sizePx: 16.0
+    , typeface: "Liberation Mono"
+    }
   }
 
-  let tickTextStyles = Foldable.foldr (\text textStyleArray -> Array.cons (Tup.Tuple text tickStyle) textStyleArray) [] tickText 
+  let tickText = tickLabelStrings graphDef
-  let textStyles = tickTextStyles <> [ 
+
-    (Tup.Tuple "axis 1" axisTitleTextStyle),
+  let tickTextStyles = Foldable.foldr (\text textStyleArray -> Array.cons (Tup.Tuple text graphDef.tickTextStyle) textStyleArray) [] tickText 
-    (Tup.Tuple "axis 2" axisTitleTextStyle),
+  let textStyles = tickTextStyles <> [ (Tup.Tuple graphDef.axis1Label graphDef.axisTitleTextStyle)
-    (Tup.Tuple "axis 3" 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

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 -> Point -> Number -> TextStyle -> Dimension -> XMLFragment
-svgText :: String -> Number -> Point -> Number -> XMLFragment
+svgText text { x: x, y: y } angle style dimension =
-svgText text fontSize { x: x, y: y } angle =
+  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\" "
-  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 centerX) <> ", " <> (toString centerY) <> ") rotate(" <> (toString angle) <> ")\">" <> text <> "</text>"
-  <> "transform=\"translate(" <> (toString x) <> ", " <> (toString y) <> ") 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 :: GraphDefinition -> Set.Set String
-tickLabelStrings numTicks axis1Start axis2Start axis3Start =
+tickLabelStrings def =
   Set.map (\x -> "E" <> (toString (Int.toNumber x))) axisTicks
   where
-    axis1Ticks = Set.fromFoldable (range axis1Start (axis1Start + numTicks - 1))
+    axis1Ticks = Set.fromFoldable (Array.range def.axis1Start (def.axis1Start + def.numTicks))
-    axis2Ticks = Set.fromFoldable (range axis2Start (axis2Start + numTicks - 1))
+    axis2Ticks = Set.fromFoldable (Array.range def.axis2Start (def.axis2Start + def.numTicks))
-    axis3Ticks = Set.fromFoldable (range axis3Start (axis3Start + numTicks - 1))
+    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 :: Number -> Number -> Number -> GraphDefinition -> Map.Map (Tup.Tuple String TextStyle) Dimension -> Either.Either String String
-ternaryGraph scale xOffset yOffset numTicks = ternaryGraphSvg fragments
+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,
+      case axis1TitleDim of
-      svgText "axis 2" 12.0 (transform scale xOffset yOffset {x: -(sin (2.0 * pi / 3.0)), y: -0.7}) (-60.0),
+        Maybe.Nothing -> Either.Left ("Failed to find '" <> definition.axis1Label <> "' in dimensions map") 
-      svgText "axis 3" 12.0 (transform scale xOffset yOffset {x: (sin (2.8 * pi / 3.0)), y: -0.7}) 60.0
+        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
+    -- svgText :: String -> Point -> Number -> TextStyle -> Dimension -> XMLFragment
-    -- TODO: axis tick label rotation
+    -- svgText text { x: x, y: y } angle style dimension =
-    -- TODO: axis tick start number
-    axisTickLabels = \rotation -> mapWithIndex (\i point -> svgText ("E" <> (toString (Int.toNumber i))) 10.0 point 0.0) 
     
-    axis1TickLabels = axisTickLabels 0 $ axisTickStarts axis1TickLines
+    axisTickLabels = \rotation startI -> Array.mapWithIndex (\i point -> 
-    axis2TickLabels = axisTickLabels 0 $ axisTickStarts axis2TickLines
+      let text = ("E" <> (toString (Int.toNumber (i + startI))))
-    axis3TickLabels = axisTickLabels 0 $ axisTickStarts axis3TickLines
+          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 :: Array (Either.Either String XMLFragment)
-      axis1TickLabels,
+    axis1TickLabels = axisTickLabels 0.0 definition.axis1Start $ axisTickStarts axis1TickLines
-      axis2TickLabels,
+    axis2TickLabels = axisTickLabels 0.0 definition.axis2Start $ axisTickStarts axis2TickLines
-      axis3TickLabels
+    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