diff --git a/src/Main.purs b/src/Main.purs index 6056d37..dbb98ca 100644 --- a/src/Main.purs +++ b/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 diff --git a/src/TernaryGraph.purs b/src/TernaryGraph.purs index 41ccdd2..f14caef 100644 --- a/src/TernaryGraph.purs +++ b/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 $ " (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 $ " 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 <> "" 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 = [