238 lines
8.1 KiB
Plaintext
238 lines
8.1 KiB
Plaintext
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.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 (Dimension, svgTextID, ternaryGraph, ternaryGraphSvg, TextStyle, 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, 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 as HTMLDoc
|
|
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
|
|
|
|
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
|
|
|
|
-- 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
|
|
|
|
-- create svg string
|
|
let svg = ternaryGraphSvg fragments
|
|
|
|
-- add to container
|
|
svgDocMay <- parseSVGFromString svg myDomParser
|
|
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 document
|
|
appendChild newNode svgContainer
|
|
|
|
-- 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))
|
|
|
|
-- remove the svg
|
|
containerKids <- (childNodes svgContainer) >>= NodeList.toArray
|
|
Foldable.for_ containerKids \kid -> do
|
|
removeChild kid svgContainer
|
|
|
|
pure myMap
|
|
|
|
update :: Event -> Effect Unit
|
|
update e = do
|
|
w <- window
|
|
d <- document w
|
|
let document = HTMLDoc.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 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 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 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
|
|
Left error -> throw error
|
|
Right svg -> pure svg
|
|
|
|
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
|
|
|
|
containerKids <- (childNodes svgContainer) >>= NodeList.toArray
|
|
Foldable.for_ containerKids \kid -> do
|
|
removeChild kid svgContainer
|
|
|
|
newNode <- importNode svgNode true document
|
|
appendChild newNode svgContainer
|
|
|
|
main :: Effect Unit
|
|
main = do
|
|
w <- window
|
|
d <- document w
|
|
let dd = HTMLDoc.toDocument d
|
|
domParser <- makeDOMParser
|
|
|
|
svgContainer <- getNodeById dd "svg-container"
|
|
|
|
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 dd svgContainer 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
|
|
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 |