246 lines
11 KiB
Plaintext
246 lines
11 KiB
Plaintext
module TernaryGraph where
|
|
|
|
import Prelude (discard, class Monoid, class Semigroup, Unit, (==), ($), (<), (<=), (<<<), (<>), (*), (+), (-), (/), (&&))
|
|
|
|
--import Data.Array ((!!), concat, cons, mapWithIndex, range)
|
|
import Data.Array as Array
|
|
import Data.Either as Either
|
|
import Data.Functor (map)
|
|
import Data.Int as Int
|
|
import Data.List (fold)
|
|
import Data.Map as Map
|
|
import Data.Maybe as Maybe
|
|
import Data.Number (cos, pi, sin)
|
|
import Data.Number.Format (toString)
|
|
import Data.Ord ((<))
|
|
import Data.Ring (negate)
|
|
import Data.Set as Set
|
|
import Data.Tuple as Tup
|
|
import Data.Tuple.Nested (Tuple3, tuple3, get1, get2, get3)
|
|
|
|
-- A spatial value (position, size) in pixels
|
|
-- TODO: Apply this across all spatial values
|
|
newtype Pixels = Pixels Number
|
|
|
|
unpixel :: Pixels -> Number
|
|
unpixel (Pixels value) = value
|
|
|
|
type Dimension =
|
|
{ widthPx :: Number
|
|
, heightPx :: Number
|
|
}
|
|
|
|
type TextStyle =
|
|
{ typeface :: String
|
|
, sizePx :: Number
|
|
}
|
|
|
|
type Point =
|
|
{ x :: Number
|
|
, y :: Number
|
|
}
|
|
|
|
type GraphDefinition =
|
|
{ axis1Label :: String
|
|
, axis2Label :: String
|
|
, axis3Label :: String
|
|
, axis1Start :: Int
|
|
, axis2Start :: Int
|
|
, axis3Start :: Int
|
|
, numTicks :: Int
|
|
, tickTextStyle :: TextStyle
|
|
, tickSize :: Pixels
|
|
, axisTitleTextStyle :: TextStyle
|
|
}
|
|
|
|
type Line =
|
|
{ start :: Point
|
|
, end :: Point
|
|
}
|
|
|
|
rotate :: Number -> Point -> Point
|
|
rotate angle { x: x, y: y} = {
|
|
x: x * (cos angle) - y * (sin angle),
|
|
y: x * (sin angle) + y * (cos angle)
|
|
}
|
|
|
|
transform :: Number -> Number -> Number -> Point -> Point
|
|
transform scale xOffset yOffset { x: x, y: y} = {
|
|
x: scale * x + xOffset,
|
|
y: scale * y + yOffset
|
|
}
|
|
|
|
rotateLine :: Number -> Line -> Line
|
|
rotateLine angle { start: p1, end: p2} = {
|
|
start: rotate angle p1,
|
|
end: rotate angle p2
|
|
}
|
|
|
|
transformLine :: Number -> Number -> Number -> Line -> Line
|
|
transformLine scale xOffset yOffset { start: start, end: end } = {
|
|
start : t start,
|
|
end : t end
|
|
}
|
|
where t = transform scale xOffset yOffset
|
|
|
|
newtype XMLFragment = XMLFragment String
|
|
|
|
derive newtype instance xmlFragmentSemiGroup :: Semigroup XMLFragment
|
|
derive newtype instance xmlFragmentMonoid :: Monoid XMLFragment
|
|
|
|
-- TODO: Add style configuration
|
|
svgLine :: Line -> XMLFragment
|
|
svgLine { start: {x: x1, y: y1}, end: {x: x2, y: y2} } =
|
|
XMLFragment $ """<path style="fill:none;stroke:#000000;stroke-width:0.5;stroke-linecap:butt;stroke-linejoin:miter;stroke-dasharray:none;stroke-opacity:1"
|
|
""" <> "d=\"M " <> (toString x1) <> "," <> (toString y1) <> " " <> (toString x2) <> "," <> (toString y2) <> "\"/>"
|
|
|
|
svgText :: String -> Point -> Number -> TextStyle -> Dimension -> XMLFragment
|
|
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 $ "<text " <> 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 <> "</text>"
|
|
where
|
|
offset = rotate angle {x: dimension.widthPx / 4.0, y: -dimension.heightPx / 8.0}
|
|
centerX = x - offset.x
|
|
centerY = y - offset.y
|
|
idText = case idMaybe of
|
|
Maybe.Nothing -> ""
|
|
Maybe.Just id -> "id=\"" <> id <> "\""
|
|
|
|
getTick :: Number -> Int -> Pixels -> Int -> Line
|
|
getTick scale numTicks tickSize tickI =
|
|
{start: {x: x, y: -(0.5 + (unpixel tickSize) / scale)}, end: {x: x, y: y}}
|
|
where
|
|
-- For even number of ticks, the ticks don't intersect in the required pattern, so offset them
|
|
x = if (Int.rem numTicks 2) == 0
|
|
then 2.0 * (sin (pi / 3.0)) * (Int.toNumber tickI) / (Int.toNumber numTicks) - (sin (pi / 3.0))
|
|
else 2.0 * (sin (pi / 3.0)) * ((Int.toNumber tickI) + 1.0) / ((Int.toNumber numTicks) + 0.5) - (sin (pi / 3.0)) - ((9.5 / 6.0) / ((Int.toNumber numTicks) + 0.5))
|
|
y = if x < 0.0
|
|
then 1.0 + x * 1.5 / (sin (pi / 3.0))
|
|
else 1.0 - x * 1.5 / (sin (pi / 3.0))
|
|
|
|
getTicks :: Number -> Number -> Pixels -> Int -> Tuple3 (Array Line) (Array Line) (Array Line)
|
|
getTicks scale angle tickSize numTicks =
|
|
tuple3 axis1Lines axis2Lines axis3Lines
|
|
where
|
|
foo = map (getTick scale (numTicks - 1) tickSize) (Array.range 0 (numTicks - 1))
|
|
axis1Lines = map (rotateLine angle) foo
|
|
axis2Lines = map (rotateLine (2.0 * pi / 3.0)) axis1Lines
|
|
axis3Lines = map (rotateLine (2.0 * pi / 3.0)) axis2Lines
|
|
|
|
-- There's probably a better way to do this
|
|
unfragment :: XMLFragment -> String
|
|
unfragment (XMLFragment frag) = frag
|
|
|
|
ternaryGraphSvg :: Array XMLFragment -> String
|
|
ternaryGraphSvg fragments = """<?xml version="1.0" encoding="UTF-8"?>
|
|
<svg
|
|
width="110mm"
|
|
height="80mm"
|
|
viewBox="-75 -50 250 220"
|
|
version="1.1"
|
|
xmlns="http://www.w3.org/2000/svg"
|
|
xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
|
|
xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
|
|
xmlns:svg="http://www.w3.org/2000/svg">
|
|
""" <> unfragment (fold fragments) <> "</svg>"
|
|
|
|
axesPoints :: Number -> Tuple3 Point Point Point
|
|
axesPoints angle = tuple3
|
|
(rotate angle { x: 0.0, y: 1.0 })
|
|
(rotate angle { x: -(sin (2.0 * pi / 3.0)), y : -0.5 })
|
|
(rotate angle { x: (sin (2.0 * pi / 3.0)), y: -0.5 })
|
|
|
|
axesPath :: Point -> Point -> Point -> XMLFragment
|
|
axesPath p1 p2 p3 = XMLFragment $ """<path style="fill:none;stroke:#000000;stroke-width:1;stroke-linecap:bevel;stroke-linejoin:bevel;stroke-dasharray:none;stroke-opacity:1"
|
|
""" <> "d=\"M " <> (toString p1.x) <> "," <> (toString p1.y) <> " " <> (toString p2.x) <> "," <> (toString p2.y) <> " " <> (toString p3.x) <> "," <> (toString p3.y) <> " Z\"/>"
|
|
|
|
tickLabelStrings :: GraphDefinition -> Set.Set String
|
|
tickLabelStrings def =
|
|
Set.map (\x -> "E" <> (toString (Int.toNumber x))) axisTicks
|
|
where
|
|
axis1Ticks = Set.fromFoldable (Array.range def.axis1Start (def.axis1Start + def.numTicks))
|
|
axis2Ticks = Set.fromFoldable (Array.range def.axis2Start (def.axis2Start + def.numTicks))
|
|
axis3Ticks = Set.fromFoldable (Array.range def.axis3Start (def.axis3Start + def.numTicks))
|
|
axisTicks = Set.union (Set.union axis1Ticks axis2Ticks) axis3Ticks
|
|
|
|
ternaryGraph :: Number -> Number -> Number -> GraphDefinition -> Map.Map (Tup.Tuple String TextStyle) Dimension -> Either.Either String String
|
|
ternaryGraph scale xOffset yOffset definition textDimensions = result
|
|
where
|
|
axisTickLines = getTicks scale pi definition.tickSize definition.numTicks
|
|
axis1TickLines = map (transformLine scale xOffset yOffset) (get1 axisTickLines)
|
|
axis2TickLines = map (transformLine scale xOffset yOffset) (get2 axisTickLines)
|
|
axis3TickLines = map (transformLine scale xOffset yOffset) (get3 axisTickLines)
|
|
tickLines = Array.concat [axis1TickLines, axis2TickLines, axis3TickLines]
|
|
tickLinesSvg = fold $ map svgLine tickLines
|
|
|
|
axesPointsPi = axesPoints pi
|
|
axisPoint1 = transform scale xOffset yOffset (get1 axesPointsPi)
|
|
axisPoint2 = transform scale xOffset yOffset (get2 axesPointsPi)
|
|
axisPoint3 = transform scale xOffset yOffset (get3 axesPointsPi)
|
|
axesPathSvg = axesPath axisPoint1 axisPoint2 axisPoint3
|
|
|
|
axis1TitleDim = Map.lookup (Tup.Tuple definition.axis1Label definition.axisTitleTextStyle) textDimensions
|
|
axis2TitleDim = Map.lookup (Tup.Tuple definition.axis2Label definition.axisTitleTextStyle) textDimensions
|
|
axis3TitleDim = Map.lookup (Tup.Tuple definition.axis3Label definition.axisTitleTextStyle) textDimensions
|
|
|
|
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 = [
|
|
case axis1TitleDim of
|
|
Maybe.Nothing -> Either.Left ("Failed to find '" <> definition.axis1Label <> "' in dimensions map")
|
|
Maybe.Just dim -> Either.Right $ svgText definition.axis1Label (transform scale xOffset yOffset axis1TitlePos) 0.0 definition.axisTitleTextStyle dim,
|
|
case axis2TitleDim of
|
|
Maybe.Nothing -> Either.Left ("Failed to find '" <> definition.axis2Label <> "' in dimensions map")
|
|
Maybe.Just dim -> Either.Right $ svgText definition.axis2Label (transform scale xOffset yOffset axis2TitlePos) (-pi / 3.0) definition.axisTitleTextStyle dim,
|
|
case axis3TitleDim of
|
|
Maybe.Nothing -> Either.Left ("Failed to find '" <> definition.axis3Label <> "' in dimensions map")
|
|
Maybe.Just dim -> Either.Right $ svgText definition.axis3Label (transform scale xOffset yOffset axis3TitlePos) (pi / 3.0) definition.axisTitleTextStyle dim
|
|
]
|
|
|
|
tickLength = 5.0
|
|
-- TODO: Base this off of label dimensions / orientation
|
|
labelSpacing = 5.0
|
|
axis1Offset = {x: 0.0, y: tickLength + labelSpacing}
|
|
axis2Offset = rotate (2.0 * pi / 3.0) axis1Offset
|
|
axis3Offset = rotate (-2.0 * pi / 3.0) axis1Offset
|
|
axis1TickStarts = map (\line -> line.start + axis1Offset)
|
|
axis2TickStarts = map (\line -> line.start + axis2Offset)
|
|
axis3TickStarts = map (\line -> line.start + axis3Offset)
|
|
|
|
axisTickLabels = \rotation startI -> Array.mapWithIndex (\i point ->
|
|
let text = ("E" <> (toString (Int.toNumber (i + startI))))
|
|
angle = 0.0
|
|
labelText = case Map.lookup (Tup.Tuple text definition.tickTextStyle) textDimensions of
|
|
Maybe.Nothing -> Either.Left ("Failed to find '" <> text <> "' in dimensions map")
|
|
Maybe.Just dimension -> Either.Right $ svgText text point angle definition.tickTextStyle dimension
|
|
in labelText
|
|
)
|
|
|
|
axis1TickLabels :: Array (Either.Either String XMLFragment)
|
|
axis1TickLabels = axisTickLabels 0.0 definition.axis1Start $ axis1TickStarts axis1TickLines
|
|
axis2TickLabels = axisTickLabels 0.0 definition.axis2Start $ axis2TickStarts axis2TickLines
|
|
axis3TickLabels = axisTickLabels 0.0 definition.axis3Start $ axis3TickStarts axis3TickLines
|
|
|
|
labelFragmentsErr = Array.concat [axisTitlesSvg, axis1TickLabels, axis2TickLabels, axis3TickLabels]
|
|
|
|
labelFragments = Array.foldr (\labelFragmentErr soFar -> case labelFragmentErr of
|
|
Either.Left _ -> soFar
|
|
Either.Right labelFragment -> Array.cons labelFragment soFar) [] labelFragmentsErr
|
|
|
|
errors = Array.foldr (\labelFragmentErr soFar -> case labelFragmentErr of
|
|
Either.Left labelFragment -> Array.cons labelFragment soFar
|
|
Either.Right _ -> soFar) [] labelFragmentsErr
|
|
|
|
fragments = Array.concat [[tickLinesSvg, axesPathSvg], labelFragments]
|
|
result = if Array.all (\x -> Either.isRight x) labelFragmentsErr then
|
|
Either.Right $ ternaryGraphSvg fragments
|
|
else
|
|
-- TODO: Include specific labels
|
|
Either.Left $ Array.intercalate "\n" errors |