ternary-graph-generator/src/Main.purs

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