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

mdsc.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
@require: math

%=========================================================== 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 hat-red = RGB (0.988, 0.1, 0.1)
let hat-white = RGB (1., 1., 1.)
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))
    % hat🎅
    |> ZGr.fill-stroke hat-red lwd base (path (0.35pt,0.72pt) |> ZGr.curves-to [
         ((0.35pt,0.72pt), (0.35pt,0.88pt), (0.50pt,0.88pt));
         ((0.50pt,0.88pt), (0.525pt,0.88pt), (0.58pt,0.88pt));
         ((0.58pt,0.88pt), (0.70pt,0.88pt), (0.73pt,0.82pt));
         ((0.73pt,0.82pt), (0.73pt,0.82pt), (0.72pt,0.81pt));
         ((0.72pt,0.81pt), (0.66pt,0.85pt), (0.61pt,0.83pt));
         ((0.61pt,0.83pt), (0.66pt,0.78pt), (0.65pt,0.72pt));
       ] |> ZGr.curve-close (0.50pt,0.72pt) (0.35pt,0.72pt))
    |> ZGr.fill-stroke hat-white lwd base (path (0.35pt,0.67pt) |> ZGr.curves-to [
         ((0.35pt,0.67pt), (0.32pt,0.675pt), (0.32pt,0.70pt));
         ((0.32pt,0.70pt), (0.32pt,0.725pt), (0.35pt,0.73pt));
         ((0.35pt,0.73pt), (0.50pt,0.74pt), (0.65pt,0.73pt));
         ((0.65pt,0.73pt), (0.68pt,0.725pt), (0.68pt,0.70pt));
         ((0.68pt,0.70pt), (0.68pt,0.675pt), (0.65pt,0.67pt));
       ] |> ZGr.curve-close (0.50pt,0.66pt) (0.35pt,0.67pt))
    |> ZGr.fill base (ellipse (0.74pt,0.81pt) (0.03pt,0.03pt))
    |> ZGr.fill hat-white (ellipse (0.74pt,0.81pt) (0.02pt,0.02pt))
    % 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)
    % 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 +h1 : [inline-text; block-text] block-cmd
direct +h2 : [inline-text; block-text] block-cmd
direct +h3 : [inline-text; block-text] block-cmd
direct +p : [inline-text] block-cmd
direct +ul : [inline-text list] block-cmd
direct +ol : [inline-text list] block-cmd
direct +code : [string] block-cmd
direct +console : [string] block-cmd
direct +quote : [block-text] block-cmd
direct +hr : [] block-cmd
direct +error : [string] block-cmd

direct \code : [string] inline-cmd
direct \emph : [inline-text] inline-cmd
direct \bold : [inline-text] inline-cmd
direct \link : [string; inline-text] inline-cmd
direct \reference : [string; string; (string * string) option] inline-cmd
direct \hard-break : [] inline-cmd
direct \embed-block : [block-text] inline-cmd
direct \error : [string] inline-cmd

end = struct


let-block ctx +h1 a1 a2 = block-nil
let-block ctx +h2 a1 a2 = block-nil
let-block ctx +h3 a1 a2 = block-nil
let-block ctx +p a1 = block-nil
let-block ctx +ul a1 = block-nil
let-block ctx +ol a1 = block-nil
let-block ctx +code a1 = block-nil
let-block ctx +console a1 = block-nil
let-block ctx +quote a1 = block-nil
let-block ctx +hr = block-nil
let-block ctx +error a1 = block-nil

let-inline ctx \code a1 = inline-nil
let-inline ctx \emph a1 = inline-nil
let-inline ctx \bold a1 = inline-nil
let-inline ctx \link a1 a2 = inline-nil
let-inline ctx \reference a1 a2 a3 = inline-nil
let-inline ctx \hard-break = inline-nil
let-inline ctx \embed-block a1 = inline-nil
let-inline ctx \error a1 = inline-nil

end
%=========================================================== module SCArticle
module MdSCArticle : 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 = MdSCArticle.document

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

mdsc.satysfi-md

{
  "depends": ["mdsc"],
  "document": "MdSCArticle.document",
  "header-default": "(| title = ` `; show-title = false; |)",
  "paragraph": "+p",
  "hr": "+hr",
  "h1": "+h1",
  "h2": "+h2",
  "h3": "+h3",
  "h4": "+h4",
  "h5": "+h5",
  "h6": "+h6",
  "ul-inline": "+ul",
  "ul-block": "+ul-block",
  "ol-inline": "+ol",
  "ol-block": "+ol-block",
  "code-block": [
    ("console", "+console")
  ],
  "code-block-default": "+code",
  "blockquote": "+quote",
  "err-block": "+error",

  "emph": "\\emph",
  "bold": "\\bold",
  "hard-break": <None>,
  "code": [
  ],
  "code-default": "\\code",
  "url": "\\link",
  "reference": "\\reference",
  "embed-block": "\\embed-block",
  "err-inline": "\\error"
}

test.md

mdscを使えばMarkdownの原稿もこんなに素敵な文書に！