From 77942030efbc23c49edaa9cf74484ec0c68f8f64 Mon Sep 17 00:00:00 2001 From: Nathan McRae Date: Wed, 13 Aug 2025 22:51:47 -0700 Subject: [PATCH] Get text centering working Required significant architectural changes --- src/Main.purs | 125 +++++++++++++++++++++++++++------------- src/TernaryGraph.purs | 129 ++++++++++++++++++++++++++++++------------ 2 files changed, 179 insertions(+), 75 deletions(-) diff --git a/src/Main.purs b/src/Main.purs index 1fad793..43278d9 100644 --- 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 axisTitleTextStyle = { - typeface: "Liberation Sans", - sizePx: 16.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 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 diff --git a/src/TernaryGraph.purs b/src/TernaryGraph.purs index 009ba5c..43cc1ef 100644 --- 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 $ """ "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 $ " (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 <> "" +svgText :: String -> Point -> Number -> TextStyle -> Dimension -> XMLFragment +svgText text { x: x, y: y } angle style dimension = + XMLFragment $ " (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 <> "" + 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 = """ 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 $ """ "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 = + + 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 + ) - axis1TickLabels = axisTickLabels 0 $ axisTickStarts axis1TickLines - axis2TickLabels = axisTickLabels 0 $ axisTickStarts axis2TickLines - axis3TickLabels = axisTickLabels 0 $ axisTickStarts axis3TickLines + 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 - tickLabelsSvg = concat [ - axis1TickLabels, - axis2TickLabels, - axis3TickLabels - ] + labelFragmentsErr = Array.concat [axisTitlesSvg, axis1TickLabels, axis2TickLabels, axis3TickLabels] - fragments = concat [[tickLinesSvg, axesPathSvg], axisTitlesSvg, tickLabelsSvg] \ No newline at end of file + 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 \ No newline at end of file