HaskCalc/cp2223t/Svg.hs

{-# OPTIONS_GHC -XNPlusKPatterns #-}

-- (c) Ensico & UM (2022)

module Svg where

import Data.Ratio
import Data.Char
import Data.List
import System.Process
import Cp

--- Basic -----------

open h = do { writeFile "_.html" h ; system ("open _.html") } 

converse = map swap

a .><. b = [ (x,y) | x <- a, y <- b ]

a # b = zip a b

unrstr = (id >< head) . unzip

collapse = map unrstr . transpose

match p l i = p `isPrefixOf` (drop i l)

r2 = (/100) . fromIntegral . round .(100*)

-- Generic "derivative" / "integral"

gderiv :: a -> (a -> a -> c) -> [a] -> [c]
gderiv z f s = ttl (zipWith f s (z:s))
              where ttl [] = []
                    ttl (a:t) = t

ginteg :: (a -> b -> b) -> b -> [a] -> [b]
ginteg f i s = i:aux i s
      where aux i [] = []
            aux i (h:t) = i':(aux i' t)
                          where i'=f h i

-- Repetitions

-- repeat anything 

rep x = map (const x) [0..]

-- (9) Misc.

cut :: Int -> Int -> [a] -> [a]
cut n m = (take (m-n+1)) . drop (n-1)

inds :: [b] -> [Int]
inds = (map fst) . (zip [1..])

elems :: (Ord a) => [a] -> [a]
elems = sort . nub

-- misc

sing a = [a]
dup a = [a,a]

a != b = not(a == b)

a |-> b = (a,b)

supermap f [] = []
supermap f (a:l) = a:(map f (supermap f l))

show2 = show.show

--- list of pairs to list

lp2l :: [(b, b)] -> [b]
lp2l = (concat . map f) where f(a,b)=[a,b]

frac n m = n%m

-- for combinator

for b i 0 = i
for b i (n+1) = b(for b i n)

presort f = map snd . sort . (map (split f id)) -- pre-sorting on f-preorder

apl :: [a -> b] -> [a] -> [b]
apl f l = map ap (zip f l)

--- HTML minimal API ("shallow embedding")

tag t l x = "<"++t++" "++ps++">"++x++"</"++t++">"
             where ps = unwords [concat[t,"=",v]| (t,v)<-l]

tg t l = "<"++t++" "++ps++"/>"
             where ps = unwords [concat[t,"=",v]| (t,v)<-l]

htm = tag "html" []

strong  = tag "strong" []

tr  = tag "tr" []

img fn = tag "img" [ "src" |-> (show fn) ] ""

uli = ul . (>>= li) where
    li  = tag "li" []
    ul  = tag "ul" []

htable = nest "table" [ "border" |-> "1" , "data-toggle" |-> "\"table\"" ]
             (nest "tr" [] (tag "td" [ "align" |-> "center"]))
                where nest t p f = (tag t p) . (>>=f)
                
pretty = (open . htm . htable) 

--- remove diacritics where needed

cl '\237'= 'i'
cl '\243'= 'o'
cl '\227'= 'a'
cl '\231'= 'c'
cl c     = c

--- basic -----------

mT :: Eq a => [(a, b)] -> a -> Maybe b
mT = flip lookup

pap :: Eq a => [(a, t)] -> a -> t
pap m = unJust . (mT m) where unJust (Just a) = a -- partial inspector of simple relation A->B

-- Abstract (point) level

infix 5  .|
infix 4  .+
infix 4  .-

a .| (x,y) = (a*x,a*y)

trans p = map (p .+)

(x,y) .+ (x',y') = (x+x',y+y')

(x,y) .- (x',y') = (x-x',y-y')

a .* (x,y) = (a*x,a*y)

amplia r = map (r .*)

amplia' s p = trans (p .- s .* p) . amplia s

reduz r = amplia (1/r)

-- SVG -----------------------------------

s = (200*)

sstep (x,y) = (200*x,-200*y)

scl p = sstep p .+ (-1400,1400)

shp (x,y) = show x ++ "," ++ show y  -- format for coord list

shpts xs = intercalate " " (map (shp.scl) xs) -- with offset

shpts' xs = intercalate " " (map (shp.sstep) xs)

rscale p = let (x,y) = scl p in (round x,round y)

-- paths

path d = tg "path" [ "d" |-> show d ]

slice r (p1,p2) = path $ " M " ++ shp (scl p1) ++ arc (s r) (scl p2) ++ " L " ++ shp (scl p3) where
  arc r p = " A " ++ shp (r,r) ++ " 0 0 0 " ++ shp p ++ " "
  p3 = (0,0)

-- polylines

poly xs = tg "polyline" ["points" |-> show (shpts xs), "style"  |-> show "fill:none;stroke-width:5" ]

poly' xs = tg "polyline" ["points" |-> show (shpts xs), "style"  |-> show "fill:none;stroke-width:8" ]  -- thicker

seg p q = poly [p,q]

-- polygons 

polyg xs = tg "polygon" ["points" |-> show  (shpts xs)] 

tri = polyg

squ = polyg

rect x y = polyg [(0,0),(x,0),(x,y),(0,y),(0,0)]

sqr x = rect x x

cir (x,y) r = tg "circle" [
   "cx" |-> show2 x',"cy" |-> show2 y', "r" |-> show2 r',
   "stroke" |-> show "black", "stroke-width" |-> show2 3 ] where
      (x',y') = scl (x,y)
      (r',_) = sstep (r,0)

elp (x,y) (rx,ry) = tg "ellipse" [
   "cx" |-> show2 x',"cy" |-> show2 y', "rx" |-> show2 rx', "ry" |-> show2 ry', 
   "stroke" |-> show "black", "stroke-width" |-> show2 3 ] where
      (x',y') = scl (x,y)
      (rx',_) = sstep (rx,0)
      (ry',_) = sstep (ry,0)

-- points

point p = let (x,y) = scl p in tg "circle" ["cx" |-> show2 x,"cy" |-> show2 y, "r" |-> show2 15]
point' p = tag "g" ["font-size" |-> show2 60] (point p ++ black(stext (scl (p.+(-0.5,0.2))) (shows p))) where
   shows(x,y) = "("++ s x ++ "," ++ s y ++ ")"
   s x = if abs(x-fromIntegral (round x)) < 0.001 then show (round x) else show (r2 x)

points' = (>>= point')
points = (>>= point)

-- rotation

polar (x,y) = (atan2 y x,sqrt(x^2+y^2))

cart (a,r) = (cos a * r, sin a * r) 

rad r = r*pi/180

rot r p = (x',y') where 
   (a,c) = polar p
   a' = a + rad r
   y' = c*sin a'
   x' = c*cos a'

rotate r p a = tag "g" [ "transform" |-> show ("rotate(" ++ t ++ ")") ] a where
   (x,y) = scl p
   t = unwords [show r, show x, show y]

-- translation

translate p = tag "g" [ "transform" |-> show ("translate"++p') ] where p' = show(sstep p)

put = translate

-- (static) scaling

scale k p = translate (p' .- k .* p') . 
            tag "g" ["transform" |-> show("scale(" ++ show k ++ ")") ]
                where p' = p .- (7,7)

-- colored regions

color c = tag "g" ["fill" |-> show c, "stroke" |-> show c] 
white = color "white"
black = color "black"
gray = color "gray"
yellow = color "yellow"
green = color "green"
red = color "red"
blue = color "blue"
orange = color "orange"
magenta = color "magenta"  
brown = color "brown" 

-- grouping

grp = tag "g" [] . concat

-- vectors, lines and grid

vec p q = 
   let (x1,y1) = scl p
       (x2,y2) = scl q
   in tg "line" [
         "x1" |-> show2 x1, "y1" |-> show2 y1, "x2" |-> show2 x2, "y2" |-> show2 y2,
         "stroke-width" |-> show2 8, "marker-end" |-> show "url(#arrowhead)" ]
         
-- line (x1,y1)(x2,y2) = tag "line" ["x1" |-> x1, "y1" |-> y1, "x2" |-> x2, "y2" |-> y2]

lin (x1,y1) (x2,y2) = tg "line" ["x1" |-> show2 x1, "y1" |-> show2 y1, "x2" |-> show2 x2, "y2" |-> show2 y2]


grid n = f n ++ map (sym><sym) (f n) where 
   f n = [((n,-1500),(n,1500))]
   sym (x,y) = (y,x)

-- definitions

dfs = tag "defs" [] .
      tag "marker" [ "id" |-> show "arrowhead",
                     "markerWidth" |-> show2 10,
                     "markerHeight"|-> show2 8,
                     "refX" |-> show2 9,
                     "refY" |-> show2 4,
                     "orient" |-> show "auto"] $
            tg "polygon" [ "fill" |-> show "gray", "points" |-> show "0,0 10,4 0,8" ]

-- the grid and X-Y plane

planoxy p x = wrap (dfs ++ grd ++ coords ++ axes ++  concat x)
  where
    wrap = tag "svg" [
               "width"   |-> show2 500,
               "height"  |-> show2 500,
               "viewBox" |-> show "-1500 -1500 3000 3000",
               "version" |-> show "1.1",
               "xmlns"   |-> show "http://www.w3.org/2000/svg"
               ]
    trans p = tag "g" [ "transform" |-> show ("translate"++p') ] where p' = show p
    xarrowhead = polyg [(0,-0.1),(0.3,0),(0,0.1)]
    yarrowhead = polyg [(0.1,0),(0,0.3),(-0.1,0)]
    base = let a =[0,40..1500] in a ++ map ((-1)*) a
    xs = [0..13] >>= coordx
    ys = [1..13] >>= coordy
    coordx i = stext (scl (i,-0.4)) (show i)
    coordy i = stext (scl (-0.4,i)) (show i)
    coordy' i = stext (scl (-0.55,i)) (show i)
    lx i = lin (i,-1400) (i,1400) ++ lin (-1400,i) (1400,i)
    ly i = lin (-1400,i) (1400,i)
    --- axes -------------------------------------------------
    axes = blacklines [((-1400.0,1480.0),(-1400.0,-1480.0)),((-1480.0,1400.0),(1480.0,1400.0))] ++
           trans (sstep (14.2,0)) xarrowhead ++
           trans (sstep (0,14.2)) yarrowhead ++
           tag "g" ["font-style" |-> show "italic", "font-size" |-> show2 100] (gray (
              stext (scl (14,-0.5)) "x" ++
              stext (scl (-0.5,14)) "y"
              ))
    blacklines ls = tag "g" ["stroke" |-> show "black", "stroke-width" |-> show2 5.0] (ls >>= uncurry lin)
    --- grid -------------------------------------------------
    grd = graylines (base >>= grid) ++ 
           tag "g" ["stroke" |-> show "gray", "stroke-width" |-> show2 3] ([-1400,-1200..1400] >>= lx)
    graylines ls = tag "g" ["stroke" |-> show "gray", "stroke-width" |-> show2 p] (ls >>= uncurry lin)
    --- coords -----------------------------------------------
    coords = tag "g" ["font-size" |-> show2 80] (xs ++ ys)
    ----------------------------------------------------------
   
-- Show in X-Y Cartesian plane

picd = open . htm . planoxy 0.9

picd' = open  . htm . planoxy 0  -- gray intensity = 0

picd'' = open . htm . wrap . concat

wrap = tag "svg" [
               "width"   |-> show2 500,
               "height"  |-> show2 500,
               "viewBox" |-> show "-1500 -1500 3000 3000",
               "version" |-> show "1.1",
               "xmlns"   |-> show "http://www.w3.org/2000/svg"
               ]

-- HELPER: para mostrar polygs (apenas):

polyd t =  picd [ green(polyg t) ++ points'' t ]

points'' ps = blue(points' ps) ++  red(points projs)
         where projs  = map f ps ++ map (swap.f.swap) ps
               f(x,_) = (x,0)

--- Vectors

pnt p = red (vec (0,0) p)

pnts = grp . map pnt

--- Plotting 

plt f = map (pnt f . (/10)) . take width $ [0..] where
   pnt f x = (x, f x)
   width = 142

plot = poly . plt

plot' = poly' . plt

-- Images

image fn d = tg "image" [ "href" |-> show fn, "height" |-> show2 h, "width" |-> show2 w ]
   where (w,h) = (s >< s) d

-- Animations

anima t f x = animamea x p (show t++"s") where p = take t . map f $ [0..]

anima' t d (i,n,v) x = animamea x p (show d++"s") where 
   p = map v (take m y) -- v is the "view" extracting (x,y) 
   y = ana n i
   ana n s = s : ana n (n s)
   m = sample t d

anims d f t o = translate (-7,-7) x where
   x = tag "g" [] (o' ++ st)
   f' = unwords [show f,show f]
   t' = unwords [show t,show t]
   o' = translate (7,7) o
   st = animT "0s" (show d++"s") "scale" f' t' "0"
 
animf t f a = animamea a (plt f) t  --- animation over function graph

animamea o p t = tag "g" [] (o ++ (animM (shpath p) t "0"))

shpath p = "M " ++ shpts' p ++ " " -- no way back, cf shpath p = "M " ++ shpts' p ++ " Z"

animM p d c = tg "animateMotion" [
   "path" |-> show p, 
   "dur" |-> show d, 
   "repeatCount" |-> show c
   ] 

sample :: Float -> Float -> Int
sample t d = round(d/t)

-- animd o p t = picd [ animamea o p t ]
-- path i n = i : map n (path i n)

-- Reflections

refl q p = q .+ (q .- p)

hrefl y0 p = [ (x,2*y0-y) | (x,y) <- p ]
 
vrefl x0 p = [ (2*x0-x,y) | (x,y) <- p ]


-- Rotations

animT b d k f t c = tg "animateTransform" [
   "attributeName" |-> show "transform",
   "begin" |-> show b, 
   "dur" |-> show d, 
   "type" |-> show k, 
   "from" |-> show f, 
   "to" |-> show t, 
   "repeatCount" |-> show c
   ]
   
animr d f t o = animarot o d f t 

animarot o d (f,p) (t,q) = 
   tag "g" [] (o ++ animT "0s" (show d ++ "s") "rotate" fs ts "indefinite") where
      fs = unwords [show f, show x, show y]
      ts = unwords [show t, show x', show y']
      (x,y) = scl p
      (x',y') = scl q

-- Text

txt p = tag "text" [ "x" |-> show2 x, "y" |-> show2 y, "font-size" |-> show2 100 ] where (x,y) = scl p

italic = tag "g" [ "font-style" |-> "italic" ]

anchor k = tag "g" [ "text-anchor" |-> show k ] -- k = "end"

-- Pie diagrams

mkp r ps = a # rtl a where         -- polar coordinates
    a = aux r ps
    rtl [] = []
    rtl x = tail x ++ [ head x ]
    aux r = map (cart . curry swap r . (2*pi*)) . ginteg (+) 0

dist x = map (/t) x where t = sum x -- distribution

perc x = map (/t) x where t = maximum x -- percentage 

dom = map fst
rng = map snd

pied db = picd' (pie (map snd db) ++ map f a) where
         a = colours # [1,2..] # map sh (dom db # dist(rng db))
         sh (a,n) = a ++ ": " ++ sprec n
         f((c,y),s) = ap(c, txt (1,y) s)

pie d = y where
  r = 4 -- radius
  y = map (translate (9,9) . ap) (colours # x)
  x = map (slice r) . mkp r . dist $ d

colours = [blue,green,yellow,orange,red,magenta,gray,brown,black] ++ colours 

sprec n = show (round(n*100)) ++ " %"

-- histograms in svg

histd db = picd'' $ (db' >>= bar) where 
   span db = 13 / fromIntegral(length db)
   wth db  =  9 / fromIntegral(length db)
   ylabels = (fromIntegral . maximum . map length . dom) db `min` 5
   small p = tag "text" [ "x" |-> show2 x, "y" |-> show2 y, "font-size" |-> show2 80 ] where (x,y) = scl p
   r = map fromIntegral (rng db)
   db'=sort $ db # (perc r # [ span db * fromIntegral i | i <- [1..]] )
   bar ((s,v),(p,x)) =
          [ (brown . translate (x-w/2,y0)) (rect w y),
            (blue  . rotate 90 (x,y0-0.5) . txt (x,y0-0.5)) s,
            (gray  . anchor "middle" . small (x,y0+y + 0.2 ) . show) v
          ] where y  = p*(12-y0)
                  w  = wth db
                  y0 = ylabels

stext (x,y) = tag "text" [ "x" |-> show2 x, "y" |-> show2 y ]  -- simple text


text x y t = tag "text" [ "x" |-> show2 x, "y" |-> show2 y, "dy" |-> show "0.35em", "font-size" |-> show2 5] t

title t s = tag "title" ["id" |-> show "title"] t ++ s

bar s (y,(a,n)) = tag "g" [ "class" |-> show "bar", "transform" |-> show ("translate(0,"++show y++")") ]
      $ aux (a,n) where
        s' n = s (fromIntegral n)
        aux (t,x) = rect (s' x) ++
                    tag "text" [ "x" |-> show2 (s' x+5),
                                 "y" |-> show2 7.5,
                                 "dy" |-> show "0.30em"] (t ++ " [ " ++ show (x) ++ " ]")
        rect x  = tag "rect" [ "width" |-> show2 x, "height" |-> show2 10, "style" |-> show "fill:rgb(185,181,180);stroke-width:1;stroke:rgb(256,256,256)"] ""

fdiv :: Int -> Int -> Float
fdiv n m = fromIntegral n / fromIntegral m

svg' x y = tag "svg" 
     [ "version" |-> show "1.1",
       "xmlns" |-> show "http://www.w3.org/2000/svg",
       "xmlns:xlink" |-> show "http://www.w3.org/1999/xlink",
       "class" |-> show "chart",
       "width" |-> show2 1000,
       "height" |-> show2 (y * 24),
       "aria-labelledby" |-> show "title",
       "role" |-> show "img"
     ]

------ SETS AND FUNCTIONS

src (x,y) t = grp [
       red (point (x,y)),
       blue (end (txt (x-0.29,y-0.15) t)) 
       ] where end = anchor "end"
       
dst (x,y) t = grp [
       red (point (x,y)),
       blue (txt (x+0.29,y-0.15) t)
       ]
       
ffdAux ff = (map (g><id) a,map (h><id) (converse b),[(g i,h(f i)) | i <- map fst a ]) where
  a = zip [1..] l
  b = zip r [1..]
  f = pap b . pap ff . pap a
  (l,r) = (nub >< nub) . unzip $ ff
  g y = (5,y)
  h y = (9,y)

bold = tag "g" [ "font-weight" |-> show "bold" ]
  
container n c x a = grp [
   c (elp (x, (m+1)/2) (2,m')), 
   (red . center . bold) (txt (x,m + 2) n)
   ] where m = fromIntegral (length a)
           m' = 0.6 * m
           center = anchor "middle"

-- diagrams of functions

fund f = ffd (graph f [minBound .. maxBound])

ffd ff na nb = picd'' . singl . (translate (0,3)) . scale 1 (0,0) . grp $ 
     [ container na yellow 4 a,
       container nb orange 10 b, 
       gray (p >>= uncurry vec), 
       a >>= uncurry src,
       b >>= uncurry dst
     ] where (a,b,p) = ffdAux ff

graph f = map (split show (show.f))

graph' f = map (split show f) 

mhd f = histd (graph' f [minBound .. maxBound]) -- measure histograms

---