SATySFi：傾いた☃を出す

fillsnowman.satyh

% fillsnowman.satyh
%
% Copyright (c) 2019 Takayuki YATO (aka. "ZR")
%   GitHub:   https:%github.com/zr-tex8r
%   Twitter:  @zr_tex8r
% Distributed under the MIT License.

@require: pervasives
@require: list

%=========================================================== module ZGr0
module ZGr : sig

type matrix
val identity : matrix
val scale : float * float -> matrix
val translate : length * length -> matrix
val matrix : float * float * float * float * length * length -> matrix
type z-pre-path
val path-of : z-pre-path -> pre-path
val path : matrix -> point -> z-pre-path
val line-to : point -> z-pre-path -> z-pre-path
val curve-to : point -> point -> point -> z-pre-path -> z-pre-path
val close : z-pre-path -> path
val line-close : z-pre-path -> path
val curve-close : point -> point -> z-pre-path -> path
val lines-to : point list -> z-pre-path -> z-pre-path
val curves-to : (point * point * point) list -> z-pre-path -> z-pre-path
val ellipse : matrix -> point -> (length * length) -> path
val circle : matrix -> point -> length -> path
type canvas
val make-canvas : length -> length -> length -> matrix -> canvas
val c-path : canvas -> point -> z-pre-path
val c-ellipse : canvas -> point -> (length * length) -> path
val c-circle : canvas -> point -> length -> path
val fill : color -> path -> canvas -> canvas
val stroke : length -> color -> path -> canvas -> canvas
val fill-stroke : color -> length -> color -> path -> canvas -> canvas
val inline-canvas : canvas -> inline-boxes

end = struct

type matrix = float * float * float * float * length * length

let identity = (1., 0., 0., 1., 0pt, 0pt)
let scale (sx, sy) = (sx, 0., 0., sy, 0pt, 0pt)
let translate (tx, ty) = (1., 0., 0., 1., tx, ty)
let matrix mtx = mtx

let trans (a, b, c, d, e, f) (x, y) =
  (x *' a +' y *' c +' e, x *' b +' y *' d +' f)

type z-pre-path = pre-path * matrix

let path-of (pth, _) = pth

let prim-line-to = line-to
let path mtx p =
  (start-path (trans mtx p), mtx)
let line-to p (pth, mtx) =
  (pth |> prim-line-to (trans mtx p), mtx)
let curve-to p1 p2 p3 (pth, mtx) =
  (pth |> bezier-to (trans mtx p1) (trans mtx p2) (trans mtx p3), mtx)
let close (pth, _) =
  terminate-path pth
let line-close (pth, _) =
  close-with-line pth
let curve-close p1 p2 (pth, mtx) =
  close-with-bezier (trans mtx p1) (trans mtx p2) pth

let lines-to ps zpth =
  List.fold-left (fun zpth p -> zpth |> line-to p) zpth ps
let curves-to crvs zpth =
  List.fold-left (fun zpth (p1, p2, p3) -> zpth |> curve-to p1 p2 p3) zpth crvs

let alpha = 0.55228475
let ellipse mtx (cx, cy) (rx, ry) =
  let (ax, ay) = (rx *' alpha, ry *' alpha) in
  path mtx (cx +' rx, cy)
    |> curve-to (cx +' rx, cy +' ay) (cx +' ax, cy +' ry) (cx, cy +' ry)
    |> curve-to (cx -' ax, cy +' ry) (cx -' rx, cy +' ay) (cx -' rx, cy)
    |> curve-to (cx -' rx, cy -' ay) (cx -' ax, cy -' ry) (cx, cy -' ry)
    |> curve-close (cx +' ax, cy -' ry) (cx +' rx, cy -' ay)
let circle mtx ctr rds =
  ellipse mtx ctr (rds, rds)

type metrics = length * length * length

type canvas = metrics * matrix * (graphics list)

let make-canvas wd ht dp mtx =
  ((wd, ht, dp), mtx, [])
let c-path (_, mtx, _) =
  path mtx
let c-ellipse (_, mtx, _) =
  ellipse mtx
let c-circle (_, mtx, _) =
  circle mtx
let fill clr pth (mtr, mtx, gs) =
  (mtr, mtx, (fill clr pth) :: gs)
let stroke lwd clr pth (mtr, mtx, gs) =
  (mtr, mtx, (stroke lwd clr pth) :: gs)
let fill-stroke fclr lwd sclr pth cvs =
  cvs |> fill fclr pth |> stroke lwd sclr pth
let inline-canvas ((wd, ht, dp), mtx, gs) = 
  let gs1 = List.reverse gs in
  inline-graphics wd ht dp (fun p -> List.map (shift-graphics p) gs1)

end
%=========================================================== module Essential0
module Essential : sig

direct \essential : [length; float; color] inline-cmd

end = struct

let white   = Gray(1.000)
let line-width = 0.0139
let descent = 0.08

let strokes lwd clr lins cvs =
  let prc cvs (p1, p2) = cvs |>
    ZGr.stroke lwd clr (ZGr.c-path cvs p1 |> ZGr.line-to p2 |> ZGr.close) in
  List.fold-left prc cvs lins

let rad = 0.0174532925199433
let fng r = 0. -. r

let make-trans siz ang =
  let (s, c) = (sin (ang *. rad), cos (ang *. rad)) in
  let scl = siz /' 1pt in
    ZGr.matrix (c *. scl, s *. scl, fng s *. scl, c *. scl,
                siz *' (0.5 -. 0.5 *. c), siz *' (fng 0.5 *. c))

let draw-essential siz ang clr =
  let lwd = siz *' line-width in
  let (ht, dp) = (siz *' (1. -. descent), siz *' descent) in
  let cvs = ZGr.make-canvas siz ht dp (make-trans siz ang) in
  let (path, ellipse) = (ZGr.c-path cvs, ZGr.c-ellipse cvs) in
  cvs
    % body
    |> ZGr.fill-stroke clr lwd clr (path (0.50pt,0.72pt) |> ZGr.curves-to [
         ((0.64pt,0.72pt), (0.76pt,0.65pt), (0.76pt,0.55pt));
         ((0.76pt,0.51pt), (0.72pt,0.47pt), (0.67pt,0.44pt));
         ((0.79pt,0.41pt), (0.84pt,0.32pt), (0.84pt,0.25pt));
         ((0.84pt,0.13pt), (0.75pt,0.08pt), (0.68pt,0.08pt));
         ((0.50pt,0.08pt), (0.40pt,0.08pt), (0.32pt,0.08pt));
         ((0.25pt,0.08pt), (0.16pt,0.13pt), (0.16pt,0.25pt));
         ((0.16pt,0.32pt), (0.21pt,0.41pt), (0.33pt,0.44pt));
         ((0.28pt,0.47pt), (0.24pt,0.51pt), (0.24pt,0.55pt));
       ] |> ZGr.curve-close (0.24pt,0.65pt) (0.36pt,0.72pt))
    % eyes
    |> ZGr.fill white (ellipse (0.40pt,0.56pt) (0.02pt,0.03pt))
    |> ZGr.fill white (ellipse (0.60pt,0.56pt) (0.02pt,0.03pt))
    % mouth
    |> ZGr.stroke lwd white (path (0.40pt,0.48pt)
       |> ZGr.curve-to (0.45pt,0.45pt) (0.55pt,0.45pt) (0.60pt,0.48pt)
       |> ZGr.close)
    % hat
    |> ZGr.fill-stroke clr lwd clr (path (0.58pt,0.90pt) |> ZGr.lines-to [
         (0.77pt,0.81pt); (0.74pt,0.61pt);
       ] |> ZGr.curve-to (0.66pt,0.60pt) (0.50pt,0.66pt) (0.46pt,0.72pt)
       |> ZGr.line-close)
    % arms
    |> ZGr.fill-stroke clr lwd clr (path (0.20pt,0.31pt) |> ZGr.curves-to [
         ((0.19pt,0.33pt), (0.14pt,0.41pt), (0.13pt,0.42pt));
         ((0.12pt,0.43pt), (0.10pt,0.43pt), (0.07pt,0.44pt));
         ((0.04pt,0.46pt), (0.06pt,0.46pt), (0.08pt,0.46pt));
         ((0.09pt,0.46pt), (0.11pt,0.44pt), (0.12pt,0.44pt));
         ((0.14pt,0.46pt), (0.14pt,0.47pt), (0.15pt,0.49pt));
         ((0.16pt,0.51pt), (0.16pt,0.49pt), (0.16pt,0.48pt));
         ((0.16pt,0.46pt), (0.14pt,0.44pt), (0.15pt,0.43pt));
         ((0.16pt,0.42pt), (0.21pt,0.35pt), (0.22pt,0.33pt));
       ] |> ZGr.curve-close (0.23pt,0.31pt) (0.21pt,0.30pt))
    |> ZGr.fill-stroke clr lwd clr (path (0.80pt,0.31pt) |> ZGr.curves-to [
         ((0.81pt,0.33pt), (0.86pt,0.41pt), (0.87pt,0.42pt));
         ((0.88pt,0.43pt), (0.90pt,0.43pt), (0.93pt,0.44pt));
         ((0.96pt,0.46pt), (0.94pt,0.46pt), (0.92pt,0.46pt));
         ((0.91pt,0.46pt), (0.89pt,0.44pt), (0.88pt,0.44pt));
         ((0.86pt,0.46pt), (0.86pt,0.47pt), (0.85pt,0.49pt));
         ((0.84pt,0.51pt), (0.84pt,0.49pt), (0.84pt,0.48pt));
         ((0.84pt,0.46pt), (0.86pt,0.44pt), (0.85pt,0.43pt));
         ((0.84pt,0.42pt), (0.79pt,0.35pt), (0.78pt,0.33pt));
       ] |> ZGr.curve-close (0.77pt,0.31pt) (0.79pt,0.30pt))
    % buttons
    |> ZGr.fill-stroke clr lwd white
         (ellipse (0.50pt,0.16pt) (0.03pt,0.03pt))
    |> ZGr.fill-stroke clr lwd white
         (ellipse (0.50pt,0.26pt) (0.03pt,0.03pt))
    % muffler
    |> ZGr.fill-stroke clr lwd white (path (0.27pt,0.48pt) |> ZGr.curves-to [
         ((0.42pt,0.38pt), (0.58pt,0.38pt), (0.73pt,0.48pt));
         ((0.75pt,0.46pt), (0.76pt,0.44pt), (0.77pt,0.41pt));
         ((0.77pt,0.39pt), (0.75pt,0.37pt), (0.73pt,0.36pt));
         ((0.74pt,0.33pt), (0.74pt,0.31pt), (0.76pt,0.26pt));
         ((0.75pt,0.25pt), (0.72pt,0.24pt), (0.66pt,0.23pt));
         ((0.66pt,0.27pt), (0.65pt,0.30pt), (0.63pt,0.34pt));
         ((0.42pt,0.30pt), (0.32pt,0.35pt), (0.24pt,0.41pt));
       ] |> ZGr.curve-close (0.25pt,0.45pt) (0.26pt,0.47pt))

let-inline ctx \essential siz ang clr =
  ZGr.inline-canvas (draw-essential siz ang clr)

end
%=========================================================== all done
%% EOF

sample.saty

@require: stdja
@import: fillsnowman

let-inline ctx \force-height ht dp it =
  let ib = read-inline ctx it in
  let (wd, _, _) = get-natural-metrics ib in
  let grph p = [draw-text p ib] in
    inline-graphics wd ht dp grph 

let my-green = RGB(0.0, 0.75, 0.25)

in
document (|
  title = {あけましておめでとう（ただし画期的）};
  author = {某ZR氏};
  show-title = false;
  show-toc = false;
|) '<
  +pn {\force-height(90pt)(20pt){\essential(240pt)(9.)(my-green);}}
>