△

affinetransform.satyh

@require: pervasives
@require: list

module AT : sig

  type matrix
  
  val transform : matrix -> point -> point

  val id : matrix
  val translate : length -> length -> matrix
  val scale : float -> float -> matrix
  val rotate : point -> float -> matrix
  val skew : float -> float -> matrix
  val reflect-horizontal : matrix
  val reflect-vertical : matrix
  val compose : matrix list -> matrix
  val dump : matrix -> string

end = struct

  type matrix =
    (float * float * float *
     float * float * float *
     float * float * float)

  let id =
    (1., 0., 0.,
     0., 1., 0.,
     0., 0., 1.)

  let compose2 (a11, a12, a13, a21, a22, a23, a31, a32, a33)
               (b11, b12, b13, b21, b22, b23, b31, b32, b33) =
    ((a11 *. b11 +. a12 *. b21 +. a13 *. b31),
     (a11 *. b12 +. a12 *. b22 +. a13 *. b32),
     (a11 *. b13 +. a12 *. b23 +. a13 *. b33),
     (a21 *. b11 +. a22 *. b21 +. a23 *. b31),
     (a21 *. b12 +. a22 *. b22 +. a23 *. b32),
     (a21 *. b13 +. a22 *. b23 +. a23 *. b33),
     0., 0., 1.)
  
  let compose = List.fold-left (fun a m -> compose2 m a) id
  
  let translate x y =
    (1., 0., (x /' 1pt),
     0., 1., (y /' 1pt),
     0., 0., 1.)
  
  let scale scx scy =
    (scx, 0.,  0.,
     0.,  scy, 0.,
     0.,  0.,  1.)
  
  let rotate (ox, oy) theta =
    let c = cos theta in
    let s = sin theta in
    let m = 
      (c, 0. -. s, 0.,
       s, c,       0.,
       0., 0.,     1.) in
      compose [translate (0pt -' ox) (0pt -' oy); m; translate ox oy]

  let skew skx sky =
    (1., skx, 0.,
     sky, 1., 0.,
     0.,  0., 1.)
  
  let reflect-horizontal =
    (0. -. 1., 0., 0.,
     0.,       1., 0.,
     0.,       0., 1.)
  
  let reflect-vertical =
    (1., 0., 0.,
     0., 0. -. 1., 0.,
     0.,       0., 1.)
  

  let transform (a, b, c, d, e, f, g, h, i) (x, y) = 
    (x *' a +' y *' b +' (1pt *' c),
     x *' d +' y *' e +' (1pt *' f))

  let dump (a, b, c, d, e, f, g, h, i) =
    let s f = show-float f ^ `, `# in
    `[` ^ (s a) ^ (s b) ^ (s c)
        ^ (s d) ^ (s e) ^ (s f)
        ^ (s g) ^ (s h) ^ (show-float i) ^ `]`

end

camp-test.saty

@require: stdja
@require: list
@import: camp

let-inline ctx \fsz sz it =
  let c = set-font-size sz ctx in
    read-inline c it

in
document (|
  title = {\Tent((0.0, 0.0));};
  author = {};
  show-title = true;
  show-toc = false;
|) '<
  +p{
    \fsz(40pt){
      \Tent((0.0, 0.0));
      \Tent((0.2, 0.1));
      \Tent((0.4, 0.2));
      \Tent((0.1, 0.1));
      \Tent((0.0, 0.0));
      \Tent((0.2, 0.1));
      \Tent((0.4, 0.2));
      \Tent((0.1, 0.1));
      \Tent((0.0, 0.0));
    }
  }
>

camp.satyh

@require: list
@import: flexpath

module Camp : sig

  direct \Tent : [float * float] inline-cmd

end = struct

let polygon (start::routes) =
  List.fold-left (fun pp p -> Fpath.line-to p pp) (Fpath.start-path start) routes
  |> Fpath.close-with-line

let tent =
  let k = Gray(0.0) in
  let col1 = RGB(1., 0.98, 0.85) in
  let col2 = RGB(1., 0.97, 0.73) in
  let col3 = RGB(0.96, 0.86, 0.64) in
  let col4 = RGB(0.7, 0.6, 0.4) in
  let col5 = RGB(1., 0.89, 0.) in
  let col6 = RGB(0.98, 0.78, 0.04) in
    [Fpath.fill col2 (polygon [(0.052pt, 0.03pt); (0.5pt, 0.74pt); (0.948pt, 0.03pt)]);
     Fpath.fill col1 (polygon [(0.052pt, 0.03pt); (0.26pt, 0.4pt); (0.32pt, 0.3pt); (0.22pt, 0.03pt)]);
     Fpath.fill col3 (polygon [(0.948pt, 0.03pt); (0.74pt, 0.4pt); (0.68pt, 0.3pt); (0.78pt, 0.03pt)]);
     Fpath.fill col5 (polygon [(0.5pt, 0.74pt); (0.32pt, 0.3pt); (0.43pt, 0.35pt); (0.5pt, 0.25pt); (0.57pt, 0.35pt); (0.68pt, 0.3pt)]);
     Fpath.fill col6 (polygon [(0.5pt, 0.74pt); (0.74pt, 0.4pt); (0.68pt, 0.3pt)]);
     Fpath.fill col4 (polygon [(0.38pt, 0.03pt); (0.5pt, 0.25pt); (0.38pt, 0.14pt)]);
     Fpath.fill col4 (polygon [(0.62pt, 0.03pt); (0.5pt, 0.25pt); (0.62pt, 0.14pt)]);
     Fpath.fill k (polygon [(0.38pt, 0.03pt); (0.5pt, 0.25pt); (0.62pt, 0.03pt)]);
     Fpath.fill k
       (Fpath.unite-path
        (polygon [(0pt, 0pt); (0.5pt, 0.8pt); (1pt, 0pt)])
        (polygon [(0.052pt, 0.03pt); (0.5pt, 0.74pt); (0.948pt, 0.03pt)]));
    ]

let-inline ctx \Tent (x, y) =
  let size = get-font-size ctx *' 0.88 in
  let sc = size /' 1pt in
  let m = AT.compose [AT.skew x 0.; AT.scale sc (sc *. (y +. 1.))] in
  let g = List.map (Fpath.transform m) tent
          |> List.map Fpath.draw in
    inline-graphics size size 0pt (fun o -> List.map (shift-graphics o) g)

end

flexpath-test.saty

@require: stdja
@import: affinetransform
@import: flexpath

let polygon t c (start :: routes) =
  List.fold-left (fun pp pt -> Fpath.line-to pt pp)
                 (Fpath.start-path start) 
                 routes
  |> Fpath.close-with-line
  |> Fpath.stroke t c

let triangle = polygon 1pt (RGB(0., 0.8, 0.5)) [(0pt, 0pt); (1pt, 0pt); (0.5pt, 0.866pt)]
let square = polygon 1pt (RGB(0., 0.5, 0.8)) [(0pt, 0pt); (1pt, 0pt); (1pt, 1pt); (0pt, 1pt)]

let draw-grid n interval =
  let fin pp = terminate-path pp |> stroke 0.05pt (Gray(0.7)) in
  let l = interval *' float n in
  let-rec r i a =
    if i < 0 then a
    else
      let p = interval *' float i in
      let v = start-path (p, 0pt) |> line-to (p, l) |> fin in
      let h = start-path (0pt, p) |> line-to (l, p) |> fin in
        r (i - 1) (v :: (h :: a))
  in
    r n []

let-block ctx +Test shape =
  let grid = draw-grid 14 10pt in
  let theta = 0. -. (acos (0. -. 1.)) /. 6. in
  let-rec r i m a =
    if i == 7 then a
    else
      let g = Fpath.transform m shape |> Fpath.draw in
      let p = 20pt *' float i +' 10pt in
      let m = AT.compose [m; AT.rotate (p, p) theta; AT.translate 20pt 20pt] in
        r (i + 1) m (g :: a)
  in
  let g = List.append grid (r 0 (AT.scale 20. 20.) []) in
    inline-graphics 150pt 150pt 10pt (fun o -> List.map (shift-graphics o) g) ++ inline-fil
    |> form-paragraph ctx

in
document (|
  title = {transform test};
  author = {};
  show-title = false;
  show-toc = false;
|) '<
  +Test(square);
  +Test(triangle);
>

flexpath.satyh

@import: affinetransform

module Fpath : sig

  type path-route
  type path-closing
  type shape
  
  val draw : shape -> graphics
  val transform : AT.matrix -> shape -> shape
  
  type shape-pp
  type shape-p
  
  val start-path : point -> shape-pp
  val line-to : point -> shape-pp -> shape-pp
  val bezier-to : point -> point -> point -> shape-pp -> shape-pp
  val terminate-path : shape-pp -> shape-p
  val close-with-line : shape-pp -> shape-p
  val close-with-bezier : point -> point -> shape-pp -> shape-p
  val unite-path : shape-p -> shape-p -> shape-p
  val stroke : length -> color -> shape-p -> shape
  val fill : color -> shape-p -> shape

end = struct

type path-route =
  | Line of point
  | Bezier of point * point * point

type path-closing =
  | Terminate
  | CloseWithLine
  | CloseWithBezier of point * point

type shapetype =
  | Fill
  | Stroke of length

type shape = (|
  t : shapetype;
  color : color;
  path  : (point * (path-route list) * path-closing) list;
|)

let make-path (start, routes, closing) =
  let-rec f
    | [] pp =
      (match closing with
       | Terminate -> terminate-path pp
       | CloseWithLine -> close-with-line pp
       | CloseWithBezier(p, q) -> close-with-bezier p q pp)
    | (h :: t) pp =
      pp |> (match h with
             | Line(p) -> line-to p
             | Bezier(p, q, r) -> bezier-to p q r)
         |> f t
  in
    f routes (start-path start)

let draw s =
  let (p1::pr) = List.map make-path s#path in
  let p = List.fold-left unite-path p1 pr in
    match s#t with
    | Fill      -> fill s#color p
    | Stroke(t) -> stroke t s#color p

type shape-pp = point * path-route list
type shape-p  = (point * path-route list * path-closing) list

let start-path pt = (pt, [])
let line-to p (start, rl) = (start, Line(p) :: rl)
let bezier-to p q r (start, rl) = (start, Bezier(p, q, r) :: rl)
let terminate-path (start, rl) = [(start, List.reverse rl, Terminate)]
let close-with-line (start, rl) = [(start, List.reverse rl, CloseWithLine)]
let close-with-bezier p q (start, rl) = [(start, List.reverse rl, CloseWithBezier(p, q))]

let-rec unite-path : shape-p -> shape-p -> shape-p
  | a b = List.append a b

let-rec fill : color -> shape-p -> shape
  | c p = (| t = Fill; path = p; color = c |)

let-rec stroke : length -> color -> shape-p -> shape
  | t c p = (| t = Stroke(t); path = p; color = c |)


let transform m s =
  let t = AT.transform m in
  let tr route =
    match route with
    | Line(p)         -> Line(t p)
    | Bezier(p, q, r) -> Bezier(t p, t q, t r)
  in
  let tc closing =
    match closing with
    | CloseWithBezier(p, q) -> CloseWithBezier(t p, t q)
    | _ -> closing
  in
  let tp1 (start, pl, clos) = (t start, List.map tr pl, tc clos)
  in
    (| t = s#t; path = List.map tp1 s#path; color = s#color |)

end