lang/laantas-script/Svg.hs
2023-12-25 21:49:05 +01:00

125 lines
3.4 KiB
Haskell

module Svg
(module Svg,
Text, pack,
module Graphics.Svg,
module Control.Monad.Reader,
module Control.Monad.State)
where
import Control.Monad.Reader
import Control.Monad.State
import qualified Graphics.Svg as Base
import Graphics.Svg hiding (mA, mR, lA, lR, cA, cR, sA, sR, aA, aR, qA, qR)
import Data.Text (Text, pack)
data Env = E {width, size, stroke :: !Double, color :: !Text}
data St = S {x, y, textWidth, textHeight :: !Double, firstOnLine :: Bool}
-- nb textHeight is one lineheight less than the actual height
-- unless ending with a 'newline'
type M = ReaderT Env (State St)
type Point = (Double, Double)
mA :: Point -> M Text
mA (x', y') =
ReaderT \E {size} -> gets \S {x, y} ->
Base.mA (x + x' * size) (y + y' * size)
mR :: Point -> M Text
mR (x', y') = reader \E {size} -> Base.mR (x' * size) (y' * size)
lA :: Point -> M Text
lA (x', y') =
ReaderT \E {size} -> gets \S {x, y} ->
Base.lA (x + x' * size) (y + y' * size)
lR :: Point -> M Text
lR (x', y') = reader \E {size} -> Base.lR (x' * size) (y' * size)
sA :: Point -> Point -> M Text
sA (x1, y1) (x2, y2) =
ReaderT \E {size} -> gets \S {x, y} ->
Base.sA (x + x1 * size) (y + y1 * size)
(x + x2 * size) (y + y2 * size)
sR :: Point -> Point -> M Text
sR (x1, y1) (x2, y2) =
reader \E {size} ->
Base.sR (x1 * size) (y1 * size) (x2 * size) (y2 * size)
cA :: Point -> Point -> Point -> M Text
cA (x1, y1) (x2, y2) (x3, y3) =
ReaderT \E {size} -> gets \S {x, y} ->
Base.cA (x + x1 * size) (y + y1 * size)
(x + x2 * size) (y + y2 * size)
(x + x3 * size) (y + y3 * size)
<> " " -- lmao
cR :: Point -> Point -> Point -> M Text
cR (x1, y1) (x2, y2) (x3, y3) =
reader \E {size} ->
Base.cR (x1 * size) (y1 * size)
(x2 * size) (y2 * size)
(x3 * size) (y3 * size)
<> " " -- lmao
qA :: Point -> Point -> M Text
qA (x1, y1) (x2, y2) =
reader \E {size} ->
Base.qA (x1 * size) (y1 * size)
(x2 * size) (y2 * size)
qR :: Point -> Point -> M Text
qR (x1, y1) (x2, y2) =
reader \E {size} ->
Base.qR (x1 * size) (y1 * size)
(x2 * size) (y2 * size)
data Arc = Large | Small
data Sweep = CW | CCW
arcToFlag :: Num a => Arc -> a
arcToFlag = \case Large -> 1; Small -> 0
sweepToFlag :: Num a => Sweep -> a
sweepToFlag = \case CW -> 1; CCW -> 0
aA :: Double -> Double -> Double -> Arc -> Sweep -> Point -> M Text
aA rx ry θ arc sweep (x', y') =
ReaderT \E {size} -> gets \S {x, y} ->
Base.aA (rx * size) (ry * size) θ (arcToFlag arc) (sweepToFlag sweep)
(x + x' * size) (y + y' * size)
aR :: Double -> Double -> Double -> Arc -> Sweep -> Point -> M Text
aR rx ry θ arc sweep (x', y') =
reader \E {size} ->
Base.aR (rx * size) (ry * size) θ (arcToFlag arc) (sweepToFlag sweep)
(x' * size) (y' * size)
ellipseX :: (Point -> M Text) -> Double -> Double -> Point -> [M Text]
ellipseX mX rx ry (x', y') =
[mX (x' - rx, y'), aR rx ry 0 Large CW (0,0.0001), pure z]
ellipseR, ellipseA :: Double -> Double -> Point -> [M Text]
ellipseR = ellipseX mR
ellipseA = ellipseX mA
circR :: Double -> Point -> [M Text]
circR r = ellipseR r r
circA :: Double -> Point -> [M Text]
circA r = ellipseA r r
shiftX :: Double -> St -> St
shiftX dx s@(S {x}) = s {x = x + dx}
shiftY :: Double -> St -> St
shiftY dy s@(S {y}) = s {y = y + dy}
shift :: (Double, Double) -> St -> St
shift (dx, dy) = shiftX dx . shiftY dy