SATySFi：非常に画期的な文書クラス

scarticle.satyh

% scarticle.satyh: An essential docuemnt class for SATySFi
%
% Copyright (c) 2018 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
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 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

val draw-essential : length -> ZGr.canvas
direct \essential : [length] inline-cmd

end = struct

let base    = RGB(0.000, 0.000, 0.000)
let muffler = RGB(0.855, 0.000, 0.000)
let arms    = RGB(0.545, 0.188, 0.180)
let buttons = RGB(0.278, 0.498, 0.118)
let broom   = RGB(0.655, 0.529, 0.141)
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 draw-essential siz =
  let lwd = siz *' line-width in
  let (ht, dp) = (siz *' (1. -. descent), siz *' descent) in
  let scl = siz /' 1pt in
  let cvs = ZGr.make-canvas siz ht dp (ZGr.scale (scl, scl)) in
  let (path, ellipse) = (ZGr.c-path cvs, ZGr.c-ellipse cvs) in
  cvs
    % body
    |> ZGr.stroke lwd base (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 base (ellipse (0.40pt,0.56pt) (0.02pt,0.03pt))
    |> ZGr.fill base (ellipse (0.60pt,0.56pt) (0.02pt,0.03pt))
    % mouth
    |> ZGr.stroke lwd base (path (0.40pt,0.48pt)
       |> ZGr.curve-to (0.45pt,0.45pt) (0.55pt,0.45pt) (0.60pt,0.48pt)
       |> ZGr.close)
    % broom
    |> strokes (lwd *' 3.2) broom [((0.03pt,0.06pt), (0.12pt,0.50pt))]
    |> strokes (lwd *' 1.2) broom [
         ((0.11pt,0.50pt), (0.06pt,0.75pt));
         ((0.12pt,0.50pt), (0.12pt,0.72pt));
         ((0.12pt,0.50pt), (0.18pt,0.76pt));
         ((0.12pt,0.50pt), (0.21pt,0.70pt));
         ((0.13pt,0.50pt), (0.27pt,0.74pt))]
    % arms
    |> ZGr.fill-stroke arms lwd arms (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 arms lwd arms (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 buttons lwd buttons
         (ellipse (0.50pt,0.16pt) (0.03pt,0.03pt))
    |> ZGr.fill-stroke buttons lwd buttons
         (ellipse (0.50pt,0.26pt) (0.03pt,0.03pt))
    % muffler
    |> ZGr.fill-stroke muffler lwd muffler (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 =
  ZGr.inline-canvas (draw-essential siz)

end
%=========================================================== module Dummy
module Dummy : sig

direct +align : [(math list) list] block-cmd
direct +math : [math] block-cmd
direct +math-list : [math list] block-cmd
direct +p : [inline-text] block-cmd
direct +pn : [inline-text] block-cmd
direct +section : [string?; inline-text; block-text] block-cmd
direct +subsection : [string?; inline-text; block-text] block-cmd
direct \LaTeX : [] inline-cmd
direct \SATySFi : [] inline-cmd
direct \TeX : [] inline-cmd
direct \align : [(math list) list] inline-cmd
direct \emph : [inline-text] inline-cmd
direct \eqn : [inline-text?; math] inline-cmd
direct \figure : [string?; inline-text; block-text] inline-cmd
direct \fil : [] inline-cmd
direct \fil-both : [] inline-cmd
direct \footnote : [inline-text] inline-cmd
direct \hskip : [length] inline-cmd
direct \math : [math] inline-cmd
direct \math-list : [math list] inline-cmd
direct \no-break : [inline-text] inline-cmd
direct \ref : [string] inline-cmd
direct \ref-page : [string] inline-cmd

end = struct

let-block ctx +align a1 = block-nil
let-block ctx +math a1 = block-nil
let-block ctx +math-list a1 = block-nil
let-block ctx +p a1 = block-nil
let-block ctx +pn a1 = block-nil
let-block ctx +section ?:a1 a2 a3 = block-nil
let-block ctx +subsection ?:a1 a2 a3 = block-nil
let-inline ctx \LaTeX = inline-nil
let-inline ctx \SATySFi = inline-nil
let-inline ctx \TeX = inline-nil
let-inline ctx \align a1 = inline-nil
let-inline ctx \emph a1 = inline-nil
let-inline ctx \eqn ?:a1 a2 = inline-nil
let-inline ctx \figure ?:a1 a2 a3 = inline-nil
let-inline ctx \fil = inline-nil
let-inline ctx \fil-both = inline-nil
let-inline ctx \footnote a1 = inline-nil
let-inline ctx \hskip a1 = inline-nil
let-inline ctx \math a1 = inline-nil
let-inline ctx \math-list a1 = inline-nil
let-inline ctx \no-break a1 = inline-nil
let-inline ctx \ref a1 = inline-nil
let-inline ctx \ref-page a1 = inline-nil

end
%=========================================================== module SCArticle
module SCArticle : sig

val document : 'a -> block-text -> document
  constraint 'a :: (|
    title : string; show-title : bool;
  |)

end = struct
%--------------------------------------- helpers

let iota n =
  let-rec iter | 0 rs = rs
               | k rs = iter (k - 1) ((k - 1) :: rs) in
    iter n []

let-rec zip | (x :: xs) (y :: ys) = (x, y) :: (zip xs ys)
            | _ _ = []

let str-explode str =
  List.map (fun i -> string-sub str i 1) (iota (string-length str))

let round-pt p =
  1pt *' float (round (p /' 1pt +. 0.5))

let natural-width ib =
  let (wd, _, _) = get-natural-metrics ib in wd

let make-box wd ib =
  inline-frame-fixed wd (0pt, 0pt, 0pt, 0pt) (fun _ _ _ _ -> []) ib

let centering ctx ib =
  line-break true true ctx (inline-fil ++ ib ++ inline-fil)

%--------------------------------------- fit-to-width

let ftw-max-font-size = 60pt
let ftw-min-space = 0.125

let ftw-steps wds =
  let-rec iter | _ [] _ dsts = dsts
               | hd (w :: wds) prev dsts =
    if hd then iter false wds (prev +' w *' 0.5) (0pt :: dsts)
    else iter false wds (prev +' w) ((prev +' w *' 0.5) :: dsts)
  in
  let rdsts = iter true wds 0pt [] in
  let tdst = match rdsts with | [] -> 0pt
                              | (d :: _) -> d
  in
  if tdst >' 0pt then
    List.map (fun d -> d /' tdst) (List.reverse rdsts)
  else List.map (fun _ -> 0.) wds

let ftw-make-chunks ctx wd its =
  let-rec iter fsiz =
    let ctx1 = ctx |> set-font-size fsiz in
    let cnks = List.map (fun it -> read-inline ctx1 it) its in
    let twd = List.fold-left (+') 0pt (List.map natural-width cnks) in
      if fsiz >' 1.5pt && twd >' wd then
        let fsiz1 = if fsiz <' ftw-max-font-size then fsiz -' 1pt
                    else round-pt (fsiz *' (wd /' twd)) in
          iter fsiz1
      else (fsiz, twd, cnks)
  in
  iter ftw-max-font-size

let ftw-raised-chunks ctx fsiz rln stps its =
  let ctx1 = ctx |> set-font-size fsiz in
  let zipd = zip stps its in
  let sq v = v *. v in
  let make (stp, it) =
    let r = 1. -. sq (stp *. 2. -. 1.) in
      read-inline (ctx1 |> set-manual-rising (rln *' r)) it
  in
    List.map make zipd

let ftw-place-chunks cnks = match cnks with
  | [] -> inline-fil
  | (c :: []) -> inline-fil ++ c ++ inline-fil
  | (c :: cs) -> List.fold-left (fun c c1 -> c ++ inline-fil ++ c1) c cs

let ftw-inline ctx wd rln str =
  let its = List.map embed-string (str-explode str) in
  let (fsiz, twd, cnks) = ftw-make-chunks ctx wd its in
  let stps = ftw-steps (List.map natural-width cnks) in
  let rcnks = ftw-raised-chunks ctx fsiz rln stps its in
    ftw-place-chunks rcnks

let-inline ctx \fit-to-width wd rln str =
  make-box wd (ftw-inline ctx wd rln str)

%--------------------------------------- document

let document docopt _ =

  let ctx0 = get-initial-context 168mm (command \math)
    |> set-dominant-wide-script Kana
    |> set-dominant-narrow-script Latin
    |> set-font Kana (`ipaexg`, 0.92126, 0.)
    |> set-font HanIdeographic (`ipaexg`, 0.92126, 0.)
    |> set-font Latin (`lmsans`, 1., 0.)
    |> set-math-font `lmodern`
  in

  let title = docopt#title in
  let showttl = docopt#show-title && (string-length title) > 0 in

  let itesnt = {\essential(147mm);} in
  let bbesnt = centering ctx0 (read-inline ctx0 itesnt) in
  let bbmain =
    if showttl then
      let itttl = {\fit-to-width(168mm)(12mm)(title);} in
      let bbttl = centering ctx0 (read-inline ctx0 itttl) in
        bbttl +++ bbesnt
    else bbesnt
  in

  let pglayout _ = (|
      text-origin = (21mm, (if showttl then 56mm else 64mm));
      text-height = if showttl then 192mm else 160mm;
    |) in
  let pgextra _ = (|
      header-origin = (0mm, 0mm); header-content = block-nil;
      footer-origin = (0mm, 0mm); footer-content = block-nil;
    |) in
    page-break A4Paper pglayout pgextra bbmain

end
%=========================================================== global

let document = SCArticle.document

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

test.saty

% scarticle を使おう!
@require: scarticle

document (|
  title = `サンプル`; % タイトルは*文字列で*指定する
  show-title = true; % タイトルを出力するか
|) '<
  % 本文は何か書いてもいいけど非本質的なので全て無視されて,
  % 出力は必ず本質的になる(箒つき)
  +p {scarticle で誰でも\emph{簡単}に\SATySFi;文書を作れます。}
>

インストール方法

• scarticle.satyjを$LIBROOT/dist/packages以下に配置する。

※$LIBROOT（ライブラリルート）の位置は、SATySFiをopamからビルドした場合は~/.satysfiになる。