226 lines
7.4 KiB
Plaintext
226 lines
7.4 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, ternaryGraph, 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
|
|
|
|
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
|
|
<> ";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
|
|
|
|
removeChild (Element.toNode el) bodyNode
|
|
|
|
pure { widthPx: width, heightPx: height }
|
|
|
|
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 => 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
|
|
|
|
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 d textStyles
|
|
|
|
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 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
|
|
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 |