module Main where import Prelude import Data.Array as Array import Data.Either (Either(..)) import Data.Int as Int import Data.Foldable as Foldable import Data.Map as Map import Data.Maybe (Maybe(..)) import Data.Number.Format (toString) 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 Web.DOM.Document (contentType , createElement , Document , getElementsByClassName , importNode , toNode , toNonElementParentNode , toParentNode , url ) 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.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.HTMLInputElement as HTMLInput import Web.HTML.HTMLDocument (toDocument) import Web.HTML.Window (document) myGetElementById :: Document -> String -> Effect Element.Element myGetElementById doc id = do elementMay <- getElementById id $ toNonElementParentNode doc case elementMay of Nothing -> throw $ "Unable to find element with ID '" <> id <> "'" Just e -> pure e getNodeById :: Document -> String -> Effect Node getNodeById doc id = do elementMay <- getElementById id $ toNonElementParentNode doc case elementMay of 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 el :: Element.Element <- createElement "span" doc let styleText = ( "font" <> style.typeface <> ";font: " <> style.typeface <> ";fontSize: " <> (toString style.sizePx) <> "px" <> ";height: " <> "auto" <> ";width: " <> "auto" <> ";position: " <> "absolute" <> ";whiteSpace: " <> "no-wrap" ) Element.setAttribute "style" styleText el setTextContent text (Element.toNode el) width <- Element.clientWidth el height <- Element.clientHeight el 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 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 doc strings = Foldable.foldM (converter doc) Map.empty strings update :: Event -> Effect Unit update e = do w <- window d <- document w let document = toDocument d domParser <- makeDOMParser log "update" inputElement <- myGetElementById document "ticks" inputHTMLElement <- case HTMLInput.fromElement inputElement of Nothing -> throw "'ticks' element is not an input tag" Just e -> pure e ticks <- (liftM1 Int.round) $ HTMLInput.valueAsNumber inputHTMLElement 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 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) ] textDimensions <- getAllTextDimensions document textStyles let mySVG = ternaryGraph 100.0 50.0 50.0 ticks textDimensions svgDocMay <- parseSVGFromString mySVG domParser svgDoc <- case svgDocMay of Left error -> throw error Right doc -> pure doc elMay <- firstElementChild $ toParentNode svgDoc svgNode <- case elMay of Nothing -> throw "no child in svg doc" Just el -> pure $ Element.toNode el -- TODO: remove existing node? newNode <- importNode svgNode true document appendChild newNode svgContainer main :: Effect Unit main = do w <- window d <- document w let dd = toDocument d domParser <- makeDOMParser svgContainer <- getNodeById dd "svg-container" let mySVG = ternaryGraph 100.0 50.0 50.0 10 svgDocMay <- parseSVGFromString mySVG domParser svgDoc <- case svgDocMay of Left error -> throw error Right doc -> pure doc elMay <- firstElementChild $ toParentNode svgDoc svgNode <- case elMay of Nothing -> throw "no child in svg doc" Just el -> pure $ Element.toNode el newNode <- importNode svgNode true dd appendChild newNode svgContainer listener <- eventListener update inputElement <- myGetElementById dd "ticks" addEventListener (EventType "input") listener true (Element.toEventTarget inputElement) log "20250727T183907" --inputMay <- getElementById "ticks" $ toNonElementParentNode dd --inputNode <- case inputMay of --Nothing -> throw $ "Unable to find " <> containerID --Just e -> pure $ Element.toNode e