SATySFI: 年賀状宛名印刷用文書クラス

00addrite.md

年賀状宛名印刷用文書クラス Addrite

全体構成

• document : config list?→ block-text → block-text → document
  document ?:cfgs from to で全ての宛先面の印刷からなる文書を出力する。

  cfgs には設定項目のリストを指定し、既定値は空リスト（つまり既定の設定を使う）である。

  from は高々1個の+address-fromコマンドのみからなるブロックテキストで、この+address-fromの出力は全てのページ（宛先面）に共通して配置される。

  to は1個以上の+address-toコマンドのみからなるブロックテキストで、各々の+address-toの出力が各々のページ（宛先面）に配置される。

設定項目

設定項目はconfig型の値で表され、以下の函数で生成する。

• jafont-scale : float -> config
  jafont-scale scale は和文フォントのスケール値を scale に変更する。既定値は0.95。

• update-context : (context -> context) -> config
  update-context upd は全体の出力に使うテキスト処理文脈を文脈更新函数 upd で更新する。

• postal-code-font : (string * float * float) → config
  postal-code-font (fname, fs, fa) は郵便番号の出力に用いるフォントを変更する。既定値は (lmsans, 1.0, 0.0)。

• min-bearing : float -> config
  min-bearing r は縦組出力における字面間の空きの最小値を r 全角に変更する。既定値は0.04。

• space-size : float -> config
  space-size r は縦組出力における標準空白（\tateコマンドで空白文字を入力したときに入る空白）の空きの量を r 全角に変更する。既定値は0.5。

• small-kana-adjust : (float * float) → config
  small-kana-adjust (h, v) は小書き仮名文字の擬似的な縦組字形出力のためのパラメタを設定する。横組字形を水平に h 全角、垂直に v 全角移動させたものを縦組字形とする。既定値は (0.15, 0.22)。

• use-substitute-char : bool → config
  use-substitute-char b は約物の縦組字形の出力のために「Unicodeの互換文字」を利用するかを設定する。trueにした場合、和文フォントがその互換文字をサポートしている必要がある（IPAフォントはOK）。falseにした場合、一部の約物の出力が明らかに異常になる。既定値はtrue。

住所出力命令

• +address-from : [string; inline-text] block-cmd
  +address-from postal address は差出人住所情報を出力する。postal には郵便番号を指定する。address は住所の出力で、その内容は0個以上のテキスト配置コマンド（\tate等）のみからなる必要はある。差出人住所情報は全てのページ（宛先面の印刷）に出力される。

• +address-to : [string; inline-text] block-cmd
  +address-to postal address は宛先人住所情報を出力する。postal には郵便番号を指定する。address は住所の出力で、その内容は0個以上のテキスト配置コマンドのみからなる必要はある。1つの+address-toの内容が1つのページに出力される。

• 郵便番号の文字列で使える文字はASCII数字（0～9）と-と_とASCII空白に限られる。_は空欄を表し、-と空白文字は無視される。数字と空欄を合わせて7文字からなる必要がある。

テキスト配置コマンド

• \tate : [point; pr-option list; length; string] inline-cmd
  \tate point ?:opts fsize input は point の位置に fsize のフォントサイズで縦組で文字列 input を出力する。opts はテキスト配置オプションのリストで、既定値は空リストである。

  入力の文字列中で(と)で囲った部分は「縦中横」で出力される（縦方向の字幅は基本的に全角になる）。-は半角幅のハイフン（縦棒）を出力する。ASCII空白は半角幅（ただしspace-sizeで変更可能）の空白（これを「標準空白」と呼ぶ）を出力する。それ以外の文字は正立して出力する（縦方向の字幅は基本的に全角になる）。

• \yoko : [point; pr-option list; length; string] inline-cmd
  \yoko point ?:opts fsize input は point の位置に fsize のフォントサイズで横組で文字列 input を出力する。opts はテキスト配置オプションのリストで、既定値は空リストである。

  横組の文字列は単純にembed-stringが適用された上でSATySFiの通常の組版規則で出力される。

• \yoko-text : [point; pr-option list; length; inline-text] inline-cmd
  \yoko-text point ?:opts fsize input は point の位置に fsize のフォントサイズで横組でインラインテキスト input を（SATySFiの通常の組版規則に従って）出力する。opts はテキスト配置オプションのリストで、既定値は空リストである。

テキスト配置オプション

テキスト配置オプションはpr-option型の値で表され、以下の函数で生成する。

アンカー位置の指定

既定の動作では、出力するテキストのボックスの中央が「テキスト配置コマンドで指定した point の位置」と一致するように出力される（つまりcenter相当）。この「ボックスの中で point の位置に合わせられる点」のことを「アンカー」と呼ぶ。

以下の値（何れもpr-option型）はアンカーの位置を指定する。

• center ＝ 中央
• top ＝ 上
• top-right ＝ 右上
• right ＝ 右
• bottom-right ＝ 右下
• bottom ＝ 下
• bottom-left ＝ 左下
• left ＝ 左
• top-left ＝ 左上

※横組の場合、center・left・right指定時のアンカーの垂直位置はベースラインの位置となる。

均等割付指定

• spread : length → pr-option
  spread len は全体のテキストを len の幅で均等割付することを指示する。

  ※縦組のテキスト配置命令でのみ使用可能。

  ※均等割付は標準空白（\tateの入力中ではASCII空白で表される）を伸縮することで実現される。ただし、入力が標準空白を全く含まない場合は例外措置として各文字間に標準空白があると見なされる。

addrite-sample.saty

@require: pervasives
@require: math
@import: addrite
open Addrite
in

document '<
  +address-from(`1234567`){
    \tate((3.2cm,8.0cm))[top](10pt)(`東京都羅轍区照府(82)-(3)-(14)`);
    \tate((2.7cm,3.0cm))[bottom](10pt)(`照府ヒルズ(1519)号室`);
    \tate((1.5cm,7.4cm))[top; spread 4.4cm](18pt)(`独 歌  紡 志`);
  }
> '<
  +address-to(`4703389`){
    \tate((9.0cm,12.2cm))[top](15pt)(`愛知県南セントレア市北カエリア区`);
    \tate((8.2cm,3.0cm))[bottom](15pt)(`西アヴィエリア(32)-(512)-(8)`);
    \tate((6.0cm,11.4cm))[top; spread 8.4cm](32pt)(`幸 主  扶 愛  様`);
  }
>

addrite.satyh

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

@require: gr
@require: list
@require: math
@require: option
@require: pervasives

%=========================================================== types

type addrite-config = (|
  pcode-font : string * float * float;
  background : image option;
  % tb-config
  use-substitute : bool;
  min-bearing : float;
  space-size : float;
  skana-adjust : float * float;
|)

type tb-config = (|
  % Allows to substitute with vertical-compatibility characters.
  use-substitute : bool;
  % Minimal side bearing (per em) of non-CJK characters.
  min-bearing : float;
  % Size of space (per em) made by a tate-space.
  space-size : float;
  % Displcement of small kana letters to emulate vertical glyphs.
  skana-adjust : float * float;
|)

%=========================================================== module TateBox
module TateBox : sig

type segment

val std-config : tb-config

%% segments
val tate : string -> segment
val tcy : inline-text -> segment
val tate-hyphen : segment
val tate-space : segment

%% tate boxes
val from-segments : tb-config -> context -> length?-> segment list -> inline-boxes
val from-string : tb-config -> context -> length?-> string -> inline-boxes

end = struct

let std-config = (|
  use-substitute = true;
  min-bearing = 0.04;
  space-size = 0.5;
  skana-adjust = (0.15, 0.22);
|)

%--------------------------------------- character data

type jvo = JvoU | JvoR | JvoV | JvoS
         | JvoTr of int | JvoTu of int

let-rec jvo-value
  | 0x2015 = JvoR         % HORIZONTAL BAR
  | 0x2018 = JvoR         % LEFT SINGLE QUOTATION MARK
  | 0x2019 = JvoR         % RIGHT SINGLE QUOTATION MARK
  | 0x201C = JvoR         % LEFT DOUBLE QUOTATION MARK
  | 0x201D = JvoR         % RIGHT DOUBLE QUOTATION MARK
  | 0x2025 = JvoR         % TWO DOT LEADER
  | 0x2026 = JvoR         % HORIZONTAL ELLIPSIS
  | 0x205A = JvoR         % TWO DOT PUNCTUATION
  | 0x205D = JvoR         % TRICOLON
  | 0x2190 = JvoR         % LEFTWARDS ARROW
  | 0x2191 = JvoR         % UPWARDS ARROW
  | 0x2192 = JvoR         % RIGHTWARDS ARROW
  | 0x2193 = JvoR         % DOWNWARDS ARROW
  | 0x2196 = JvoR         % NORTH WEST ARROW
  | 0x2197 = JvoR         % NORTH EAST ARROW
  | 0x2198 = JvoR         % SOUTH EAST ARROW
  | 0x2199 = JvoR         % SOUTH WEST ARROW
  | 0x21C4 = JvoR         % RIGHTWARDS ARROW OVER LEFTWARDS ARROW
  | 0x21E6 = JvoR         % LEFTWARDS WHITE ARROW
  | 0x21E7 = JvoR         % UPWARDS WHITE ARROW
  | 0x21E8 = JvoR         % RIGHTWARDS WHITE ARROW
  | 0x21E9 = JvoR         % DOWNWARDS WHITE ARROW
  | 0x2423 = JvoR         % OPEN BOX
  | 0x261E = JvoR         % WHITE RIGHT POINTING INDEX
  | 0x2934 = JvoR         % ARROW POINTING RIGHTWARDS THEN CURVING UPWARDS
  | 0x2935 = JvoR         % ARROW POINTING RIGHTWARDS THEN CURVING DOWNWARDS
  | 0x3001 = JvoTu 0xFE11 % IDEOGRAPHIC COMMA
  | 0x3002 = JvoTu 0xFE12 % IDEOGRAPHIC FULL STOP
  | 0x3008 = JvoTr 0xFE3F % LEFT ANGLE BRACKET
  | 0x3009 = JvoTr 0xFE40 % RIGHT ANGLE BRACKET
  | 0x300A = JvoTr 0xFE3D % LEFT DOUBLE ANGLE BRACKET
  | 0x300B = JvoTr 0xFE3E % RIGHT DOUBLE ANGLE BRACKET
  | 0x300C = JvoTr 0xFE41 % LEFT CORNER BRACKET
  | 0x300D = JvoTr 0xFE42 % RIGHT CORNER BRACKET
  | 0x300E = JvoTr 0xFE43 % LEFT WHITE CORNER BRACKET
  | 0x300F = JvoTr 0xFE44 % RIGHT WHITE CORNER BRACKET
  | 0x3010 = JvoTr 0xFE3B % LEFT BLACK LENTICULAR BRACKET
  | 0x3011 = JvoTr 0xFE3C % RIGHT BLACK LENTICULAR BRACKET
  | 0x3014 = JvoTr 0xFE39 % LEFT TORTOISE SHELL BRACKET
  | 0x3015 = JvoTr 0xFE3A % RIGHT TORTOISE SHELL BRACKET
  | 0x3016 = JvoR         % LEFT WHITE LENTICULAR BRACKET
  | 0x3017 = JvoR         % RIGHT WHITE LENTICULAR BRACKET
  | 0x3018 = JvoR         % LEFT WHITE TORTOISE SHELL BRACKET
  | 0x3019 = JvoR         % RIGHT WHITE TORTOISE SHELL BRACKET
  | 0x301C = JvoV         % WAVE DASH
  | 0x301D = JvoR         % REVERSED DOUBLE PRIME QUOTATION MARK
  | 0x301F = JvoR         % LOW DOUBLE PRIME QUOTATION MARK
  | 0x3041 = JvoS         % HIRAGANA LETTER SMALL A
  | 0x3043 = JvoS         % HIRAGANA LETTER SMALL I
  | 0x3045 = JvoS         % HIRAGANA LETTER SMALL U
  | 0x3047 = JvoS         % HIRAGANA LETTER SMALL E
  | 0x3049 = JvoS         % HIRAGANA LETTER SMALL O
  | 0x3063 = JvoS         % HIRAGANA LETTER SMALL TU
  | 0x3083 = JvoS         % HIRAGANA LETTER SMALL YA
  | 0x3085 = JvoS         % HIRAGANA LETTER SMALL YU
  | 0x3087 = JvoS         % HIRAGANA LETTER SMALL YO
  | 0x308E = JvoS         % HIRAGANA LETTER SMALL WA
  | 0x3095 = JvoS         % HIRAGANA LETTER SMALL KA
  | 0x3096 = JvoS         % HIRAGANA LETTER SMALL KE
  | 0x30A0 = JvoR         % KATAKANA-HIRAGANA DOUBLE HYPHEN
  | 0x30A1 = JvoS         % KATAKANA LETTER SMALL A
  | 0x30A3 = JvoS         % KATAKANA LETTER SMALL I
  | 0x30A5 = JvoS         % KATAKANA LETTER SMALL U
  | 0x30A7 = JvoS         % KATAKANA LETTER SMALL E
  | 0x30A9 = JvoS         % KATAKANA LETTER SMALL O
  | 0x30C3 = JvoS         % KATAKANA LETTER SMALL TU
  | 0x30E3 = JvoS         % KATAKANA LETTER SMALL YA
  | 0x30E5 = JvoS         % KATAKANA LETTER SMALL YU
  | 0x30E7 = JvoS         % KATAKANA LETTER SMALL YO
  | 0x30EE = JvoS         % KATAKANA LETTER SMALL WA
  | 0x30F5 = JvoS         % KATAKANA LETTER SMALL KA
  | 0x30F6 = JvoS         % KATAKANA LETTER SMALL KE
  | 0x30FC = JvoV         % KATAKANA-HIRAGANA PROLONGED SOUND MARK
  | 0x31F0 = JvoS         % KATAKANA LETTER SMALL KU
  | 0x31F1 = JvoS         % KATAKANA LETTER SMALL SI
  | 0x31F2 = JvoS         % KATAKANA LETTER SMALL SU
  | 0x31F3 = JvoS         % KATAKANA LETTER SMALL TO
  | 0x31F4 = JvoS         % KATAKANA LETTER SMALL NU
  | 0x31F5 = JvoS         % KATAKANA LETTER SMALL HA
  | 0x31F6 = JvoS         % KATAKANA LETTER SMALL HI
  | 0x31F7 = JvoS         % KATAKANA LETTER SMALL HU
  | 0x31F8 = JvoS         % KATAKANA LETTER SMALL HE
  | 0x31F9 = JvoS         % KATAKANA LETTER SMALL HO
  | 0x31FA = JvoS         % KATAKANA LETTER SMALL MU
  | 0x31FB = JvoS         % KATAKANA LETTER SMALL RA
  | 0x31FC = JvoS         % KATAKANA LETTER SMALL RI
  | 0x31FD = JvoS         % KATAKANA LETTER SMALL RU
  | 0x31FE = JvoS         % KATAKANA LETTER SMALL RE
  | 0x31FF = JvoS         % KATAKANA LETTER SMALL RO
  | 0xFF08 = JvoTr 0xFE35 % FULLWIDTH LEFT PARENTHESIS
  | 0xFF09 = JvoTr 0xFE36 % FULLWIDTH RIGHT PARENTHESIS
  | 0xFF0C = JvoTu 0xFE10 % FULLWIDTH COMMA
  | 0xFF0D = JvoR         % FULLWIDTH HYPHEN-MINUS
  | 0xFF0E = JvoV         % FULLWIDTH FULL STOP
  | 0xFF1A = JvoR         % FULLWIDTH COLON
  | 0xFF1B = JvoR         % FULLWIDTH SEMICOLON
  | 0xFF1C = JvoR         % FULLWIDTH LESS-THAN SIGN
  | 0xFF1D = JvoR         % FULLWIDTH EQUALS SIGN
  | 0xFF1E = JvoR         % FULLWIDTH GREATER-THAN SIGN
  | 0xFF3B = JvoTr 0xFE47 % FULLWIDTH LEFT SQUARE BRACKET
  | 0xFF3D = JvoTr 0xFE48 % FULLWIDTH RIGHT SQUARE BRACKET
  | 0xFF3F = JvoTr 0xFE33 % FULLWIDTH LOW LINE
  | 0xFF5B = JvoTr 0xFE37 % FULLWIDTH LEFT CURLY BRACKET
  | 0xFF5C = JvoR         % FULLWIDTH VERTICAL LINE
  | 0xFF5D = JvoTr 0xFE38 % FULLWIDTH RIGHT CURLY BRACKET
  | 0xFF5E = JvoV         % FULLWIDTH TILDE
  | 0xFF5F = JvoR         % FULLWIDTH LEFT WHITE PARENTHESIS
  | 0xFF60 = JvoR         % FULLWIDTH RIGHT WHITE PARENTHESIS
  | 0xFFE3 = JvoR         % FULLWIDTH MACRON
  | _      = JvoU

let-rec has-cjk-glue
  | 0x2010 = true % HYPHEN
  | 0x2013 = true % EN DASH
  | 0x2018 = true % LEFT SINGLE QUOTATION MARK
  | 0x2019 = true % RIGHT SINGLE QUOTATION MARK
  | 0x201C = true % LEFT DOUBLE QUOTATION MARK
  | 0x201D = true % RIGHT DOUBLE QUOTATION MARK
  | 0x3001 = true % IDEOGRAPHIC COMMA
  | 0x3002 = true % IDEOGRAPHIC FULL STOP
  | 0x3008 = true % LEFT ANGLE BRACKET
  | 0x3009 = true % RIGHT ANGLE BRACKET
  | 0x300A = true % LEFT DOUBLE ANGLE BRACKET
  | 0x300B = true % RIGHT DOUBLE ANGLE BRACKET
  | 0x300C = true % LEFT CORNER BRACKET
  | 0x300D = true % RIGHT CORNER BRACKET
  | 0x300E = true % LEFT WHITE CORNER BRACKET
  | 0x300F = true % RIGHT WHITE CORNER BRACKET
  | 0x3010 = true % LEFT BLACK LENTICULAR BRACKET
  | 0x3011 = true % RIGHT BLACK LENTICULAR BRACKET
  | 0x3014 = true % LEFT TORTOISE SHELL BRACKET
  | 0x3015 = true % RIGHT TORTOISE SHELL BRACKET
  | 0x3016 = true % LEFT WHITE LENTICULAR BRACKET
  | 0x3017 = true % RIGHT WHITE LENTICULAR BRACKET
  | 0x3018 = true % LEFT WHITE TORTOISE SHELL BRACKET
  | 0x3019 = true % RIGHT WHITE TORTOISE SHELL BRACKET
  | 0x301C = true % WAVE DASH
  | 0x301D = true % REVERSED DOUBLE PRIME QUOTATION MARK
  | 0x301F = true % LOW DOUBLE PRIME QUOTATION MARK
  | 0x30A0 = true % KATAKANA-HIRAGANA DOUBLE HYPHEN
  | 0x30FB = true % KATAKANA MIDDLE DOT
  | 0xFF08 = true % FULLWIDTH LEFT PARENTHESIS
  | 0xFF09 = true % FULLWIDTH RIGHT PARENTHESIS
  | 0xFF0C = true % FULLWIDTH COMMA
  | 0xFF0E = true % FULLWIDTH FULL STOP
  | 0xFF1A = true % FULLWIDTH COLON
  | 0xFF1B = true % FULLWIDTH SEMICOLON
  | 0xFF3B = true % FULLWIDTH LEFT SQUARE BRACKET
  | 0xFF3D = true % FULLWIDTH RIGHT SQUARE BRACKET
  | 0xFF5B = true % FULLWIDTH LEFT CURLY BRACKET
  | 0xFF5D = true % FULLWIDTH RIGHT CURLY BRACKET
  | 0xFF5F = true % % FULLWIDTH LEFT WHITE PARENTHESIS
  | 0xFF60 = true % % FULLWIDTH RIGHT WHITE PARENTHESIS
  | _      = false

let cjk-forced ch =
  (ch == 0x2010) || (ch == 0x2013)
    || (0xFE10 <= ch && ch < 0xFE50)
    || (0xFF00 <= ch && ch < 0xFFF0)

%--------------------------------------- helpers

let modname = `TateBox`
let info msgs =
  let msg = List.fold-left (fun s1 s2 -> s1 ^ `: `# ^ s2) ` ` msgs in
  display-message (modname ^ msg)
let error msgs =
  let msg = List.fold-left (fun s1 s2 -> s1 ^ `: `# ^ s2) ` ` msgs in
  abort-with-message (modname ^ msg)

let show-len l =
  show-float (l /' 1pt) ^ `pt`

let unichar ch =
  string-unexplode [ ch ]

let unicode str =
  let (ch::_) = string-explode str in ch

let present opt =
  (match opt with Some _ -> true | None -> false)

let list-count pred =
  List.fold-left (fun c v -> (if pred v then c + 1 else c)) 0

let len-same l1 l2 =
  l2 *' 0.999 <' l1 && l1 <' l2 *' 1.001

let len-div l k =
  if k == 0 then 0pt else l *' (1. /. (float k))

let it-jchar = unichar 0x5B57 |> embed-string

let jchar-metrics ctx =
  let ib = read-inline ctx it-jchar in
  let (wd, _, _) = get-natural-metrics ib in
  (wd, wd *' 0.88, wd *' 0.12)

let read-inline-x ctx ch it =
  let ctx = if cjk-forced ch then
      % switch to CJK font
      let f = get-font Kana ctx in
      ctx |> set-font Latin f |> set-font OtherScript f
    else ctx in
  let ib = read-inline ctx it in
  if has-cjk-glue ch then
    let (wdjch, _, _) = jchar-metrics ctx in
    let (wd, _, _) = get-natural-metrics ib in
    if wd >' wdjch then % it happens!
      % force width to wdjch
      let proc ctx = form-paragraph ctx ib in
      embed-block-top ctx wdjch proc
    else ib
  else ib

%--------------------------------------- input-string parser

type segment = Tate of string | TCY of inline-text
             | TateHyphen | TateSpace

let tate str = Tate str
let tcy it = TCY it
let tate-hyphen = TateHyphen
let tate-space = TateSpace

let parse-string str =
  let len = string-length str in
  let err-paren p =
    error [`Unpaired parenthesis in input string: `# ^ str]
  in
  let update k sp inprn segs =
    if sp < k || inprn then
      let sub = string-sub str sp (k - sp) in
      if inprn then (TCY (embed-string sub)) :: segs
      else (Tate sub) :: segs
    else segs
  in
  let-rec iter k sp inprn segs =
    if k < len then
      let c = string-sub str k 1 in
      (match c with
      | `(` -> if not inprn then
            iter (k + 1) (k + 1) true (update k sp false segs)
          else err-paren k
      | `)` -> if inprn then
            iter (k + 1) (k + 1) false (update k sp true segs)
          else err-paren k
      | #` `# -> if not inprn then
            iter (k + 1) (k + 1) false (TateSpace :: update k sp false segs)
          else iter (k + 1) sp inprn segs
      | `-` -> if not inprn then
            iter (k + 1) (k + 1) false (TateHyphen :: update k sp false segs)
          else iter (k + 1) sp inprn segs
      | _ -> iter (k + 1) sp inprn segs)
    else if not inprn then (update k sp false segs)
    else err-paren k
  in
  List.reverse (iter 0 0 false [])

%--------------------------------------- composition

type placement = (|
  char : int;
  width : length;
  height : length;
  llx : length;
  lly : length;
  rotate : jvo;
|)

let char-placement ctx cfg ch =
  let (wdjch, htjch, dpjch) = jchar-metrics ctx in
  let ibch = unichar ch |> embed-string |> read-inline-x ctx ch in
  let (wd, ht, dp) = get-natural-metrics ibch in
  let minbear = wdjch *' cfg#min-bearing in
  % process
  if len-same wdjch wd then % CJK char
    let vo = jvo-value ch in
    let vo = if cfg#use-substitute then vo
      else (match vo with JvoTu _ -> JvoU | JvoTr _ -> JvoR | _ -> vo) in
    (match vo with
    | (JvoTu sch) -> (|
          char = sch; width = wdjch; height = wdjch;
          llx = 0pt; lly = dpjch; rotate = JvoU;
        |)
    | (JvoTr sch) -> (|
          char = sch; width = wdjch; height = wdjch;
          llx = 0pt; lly = dpjch; rotate = JvoU;
        |)
    | JvoS ->
        let (adjx, adjy) = cfg#skana-adjust in
        (|
          char = ch; width = wdjch; height = wdjch;
          llx = wdjch *' adjx; lly = dpjch +' wdjch *' adjy; rotate = JvoU;
        |)
    | _ -> (|
          char = ch; width = wdjch; height = wdjch;
          llx = 0pt; lly = dpjch; rotate = vo;
        |))
  else % non-CJK char (set upright)
    let adjht = length-max (ht +' minbear) htjch in
    let adjdp = length-max (dp +' minbear) dpjch in
    (|
      char = ch; width = wd; height = adjht +' adjdp;
      llx = 0pt; lly = adjdp; rotate = JvoU;
    |)

let char-graphics ctx pl =
  let (wdjch, _, _) = jchar-metrics ctx in
  let ib = unichar pl#char |> embed-string |> read-inline-x ctx pl#char in
  let adjx = (pl#width -' wdjch) *' 0.5 in
  let graw = draw-text (pl#llx -' adjx, pl#lly) ib in
  let gres = (match pl#rotate with
    | JvoR -> graw |> linear-transform-graphics 0. 1. (0. -. 1.) 0.
          |> shift-graphics (0pt, wdjch)
    | JvoV -> graw |> linear-transform-graphics 0. (0. -. 1.) (0. -. 1.) 0.
          |> shift-graphics (wdjch, wdjch)
    | _ -> graw) in
  (pl#height, gres)

let tcy-graphics ctx cfg it =
  let (wdjch, htjch, dpjch) = jchar-metrics ctx in
  let minbear = wdjch *' cfg#min-bearing in
  let ib = read-inline ctx it in
  let (wd, ht, dp) = get-natural-metrics ib in
  let adjht = length-max (ht +' minbear) htjch in
  let adjdp = length-max (dp +' minbear) dpjch in
  let totht = adjht +' adjdp in
  let llx = (wdjch -' wd) *' 0.5 in
  (totht, draw-text (llx, adjdp) ib)

let hyphen-graphics ctx cfg =
  let (wdjch, _, _) = jchar-metrics ctx in
  let ib = unichar 0x2010 |> embed-string |> read-inline-x ctx 0x2010 in
  let (wd, ht, _) = get-natural-metrics ib in
  let adjx = (wdjch *' 0.5 -' wd) *' 0.5 in
  let gr = draw-text (adjx, wdjch *' 0.5 -' ht) ib
    |> linear-transform-graphics 0. 1. (0. -. 1.) 0.
    |> shift-graphics (0pt, wdjch *' 0.5) in
  (wdjch *' 0.5, gr)

let tate-explode segs =
  let-rec each | (Tate str) =
    List.map (fun ch -> Tate (unichar ch)) (string-explode str)
               | seg = [seg]
  in
  List.concat (List.map each segs)

let intersparse segs =
  let-rec has-sp | [] = false
                 | ((TateSpace)::_) = true
                 | (_::segs) = has-sp segs
  in
  let-rec iter | [] = []
               | (seg::segs) = TateSpace :: seg :: (iter segs)
  in
  if has-sp segs then segs
  else
    (match segs with
    | [] -> [TateSpace]
    | [seg] -> [TateSpace; seg; TateSpace]
    | _ -> let (_::r) = iter segs in r)

let make-graphics ctx cfg htopt segs =
  let (wdjch, _, _) = jchar-metrics ctx in
  let segs = if present htopt then intersparse (tate-explode segs)
    else tate-explode segs in
  let-rec seg-gr | (Tate str) =
    let pl = char-placement ctx cfg (unicode str) in
    Some (char-graphics ctx pl)
                 | (TCY it) =
    Some (tcy-graphics ctx cfg it)
                 | (TateHyphen) =
    Some (hyphen-graphics ctx cfg)
                 | (TateSpace) =
    None
  in
  let-rec add-ht | t (Some (ht, _)) = t +' ht
                 | t (None) = t
  in
  let elts = List.map seg-gr segs in
  let nsp = list-count (fun e -> not (present e)) elts in
  let totht = List.fold-left add-ht 0pt elts in
  let spht = wdjch *' cfg#space-size in
  let (tgtht, spht) = (match htopt with
    | Some h -> (h, len-div (h -' totht) nsp)
    | None -> (totht +' spht *' (float nsp), spht)) in
  let () = info [`totht`; show-len totht] in
  let () = info [`tgtht`; show-len tgtht] in
  let () = info [`spht`; show-len spht] in
  let () = info [`nsp`; arabic nsp] in
  let-rec compose | _ [] = []
                  | y ((None)::elts) =
    compose (y -' spht) elts
                  | y ((Some (ht, gr))::elts) =
    let gr = shift-graphics (0pt, y -' ht) gr in
    gr :: (compose (y -' ht) elts)
  in
  (tgtht, compose tgtht elts)

let make-box ctx totht grs =
  let (wdjch, _, _) = jchar-metrics ctx in
  (fun p -> List.map (shift-graphics p) grs)
    |> inline-graphics wdjch totht 0pt

%--------------------------------------- main

let from-segments cfg ctx ?:tght segs =
  let (totht, grs) = make-graphics ctx cfg tght segs in
  make-box ctx totht grs

let from-string cfg ctx ?:tght str =
  let segs = parse-string str in
  let (totht, grs) = make-graphics ctx cfg tght segs in
  make-box ctx totht grs

end
%=========================================================== module Addrite
module Addrite : sig

type config
type pr-option

val document : config list?-> block-text -> block-text -> document

%% configurations
val jafont-scale        : float -> config
val update-context      : (context -> context) -> config
val postal-code-font    : (string * float * float) -> config
val background-image    : image -> config
val use-substitute-char : bool -> config
val min-bearing         : float -> config
val space-size          : float -> config
val small-kana-adjust   : (float * float) -> config

%% address commands
val +address-from : [string; inline-text] block-cmd
val +address-to   : [string; inline-text] block-cmd

%% print commands
val \tate          : [point; pr-option list; length; string] inline-cmd
val \tate-segments : [point; pr-option list; length; TateBox.segment list] inline-cmd
val \yoko          : [point; pr-option list; length; string] inline-cmd
val \yoko-text     : [point; pr-option list; length; inline-text] inline-cmd

%% print options
val center       : pr-option
val top          : pr-option
val top-right    : pr-option
val right        : pr-option
val bottom-right : pr-option
val bottom       : pr-option
val bottom-left  : pr-option
val left         : pr-option
val top-left     : pr-option
val spread : length -> pr-option

end = struct

let paper-size = (10cm, 14.8cm)
let std-jafont-scale = 0.95

let std-a-config =
  let tbcfg = TateBox.std-config in
  (|
    pcode-font = (`lmsans`, 1., 0.);
    background = None;
    use-substitute = tbcfg#use-substitute;
    min-bearing = tbcfg#min-bearing;
    space-size = tbcfg#space-size;
    skana-adjust = tbcfg#skana-adjust;
  |)

%--------------------------------------- helpers

let modname = `Addrite`
let info msgs =
  let msg = List.fold-left (fun s1 s2 -> s1 ^ `: `# ^ s2) ` ` msgs in
  display-message (modname ^ msg)
let error msgs =
  let msg = List.fold-left (fun s1 s2 -> s1 ^ `: `# ^ s2) ` ` msgs in
  abort-with-message (modname ^ msg)
let error-internal msgs =
  error (`INTERNAL ERROR` :: msgs)

let unicode str =
  let (ch::_) = string-explode str in ch

let is-digit str =
  let ch = unicode str in
  (0x30 <= ch) && (ch <= 0x39)

let read-inline-zs ctx it =
  let ctx = ctx |> set-font-size 0pt in
  read-inline ctx it

let render-graphics (wd, ht) grs =
  inline-graphics wd ht 0pt (fun pt -> List.map (shift-graphics pt) grs)

let make-page ctx grs =
  form-paragraph ctx (render-graphics paper-size grs)

let set-jafont-scale r ctx =
  let (kf, _, ka) = get-font Kana ctx in
  let (hf, _, ha) = get-font HanIdeographic ctx in
  ctx |> set-font Kana (kf, r, ka) |> set-font HanIdeographic (hf, r, ha)

let to-tb-config acfg =
  (|
    use-substitute = acfg#use-substitute;
    min-bearing = acfg#min-bearing;
    space-size = acfg#space-size;
    skana-adjust = acfg#skana-adjust;
  |)

%--------------------------------------- controller

let-mutable a-config-ref <- None
let-mutable in-addr-from-ref <- false
let-mutable in-addr-to-ref <- false
let-mutable addr-from-done-ref <- false

let get-a-config () =
  match !a-config-ref with
  | Some acfg -> acfg
  | None -> error-internal [`no config`]

let check-in-addr-from msg =
  if !in-addr-from-ref then ()
  else error [`cannot use here`; msg]

let check-in-addr-to msg =
  if !in-addr-to-ref then ()
  else error [`cannot use here`; msg]

let check-duplicate-addr-from msg =
  if not !addr-from-done-ref then addr-from-done-ref <- true
  else error [`cannot use twice`; msg]

%--------------------------------------- content

type anchor = Center | Top | TopRight | Right | BottomRight
            | Bottom | BottomLeft | Left | TopLeft

type pr-option-state = length option * anchor
type pr-option = pr-option-state -> pr-option-state

let center       (s, a) = (s, Center)
let top          (s, a) = (s, Top)
let top-right    (s, a) = (s, TopRight)
let right        (s, a) = (s, Right)
let bottom-right (s, a) = (s, BottomRight)
let bottom       (s, a) = (s, Bottom)
let bottom-left  (s, a) = (s, BottomLeft)
let left         (s, a) = (s, Left)
let top-left     (s, a) = (s, TopLeft)

let spread l     (s, a) = (Some l, a)

let displace-rate anc =
  (match anc with
  | Center      -> (0.5, 0.5)
  | Top         -> (0.5, 1.0)
  | TopRight    -> (1.0, 1.0)
  | Right       -> (1.0, 0.5)
  | BottomRight -> (1.0, 0.0)
  | Bottom      -> (0.5, 0.0)
  | BottomLeft  -> (0.0, 0.0)
  | Left        -> (0.0, 0.5)
  | TopLeft     -> (0.0, 1.0))

let print-tate pt propts print =
  let prostt = (None, Center) in
  let (spr, anc) = List.fold-left (fun s f -> f s) prostt propts in
  let ib = print spr in
  % displace
  let (wd, ht, _) = get-natural-metrics ib in
  let (drx, dry) = displace-rate anc in
  let (x, y) = pt in
  let pt = (x -' wd *' drx, y -' ht *' dry) in
  render-graphics (0pt, 0pt) [ draw-text pt ib ]

let-inline ctx \tate pt propts fsize str =
  let ctx = ctx |> set-font-size fsize in
  let tbcfg = get-a-config () |> to-tb-config in
  let print spr =
    (match spr with
    | Some l -> TateBox.from-string tbcfg ctx ?:l str
    | None -> TateBox.from-string tbcfg ctx str)
  in
  print-tate pt propts print

let-inline ctx \tate-segments pt propts fsize segs =
  let ctx = ctx |> set-font-size fsize in
  let tbcfg = get-a-config () |> to-tb-config in
  let print spr =
    (match spr with
    | Some l -> TateBox.from-segments tbcfg ctx ?:l segs
    | None -> TateBox.from-segments tbcfg ctx segs)
  in
  print-tate pt propts print

let print-yoko pt propts print =
  let prostt = (None, Center) in
  let (spr, anc) = List.fold-left (fun s f -> f s) prostt propts in
  let ib = print spr in
  % displace
  let (wd, ht, dp) = get-natural-metrics ib in
  let (x, y) = pt in
  let pt = (match anc with
    | Left -> (x, y)
    | Center -> (x -' wd *' 0.5, y)
    | Right -> (x -' wd, y)
    | _ -> let (drx, dry) = displace-rate anc in
        (x -' wd *' drx, y -' (ht +' dp) *' dry +' dp)) in
  render-graphics (0pt, 0pt) [ draw-text pt ib ]

let-inline ctx \yoko pt propts fsize str =
  let ctx = ctx |> set-font-size fsize in
  let print spr =
    (match spr with
    | Some l -> error [`cannot use spread with \yoko`]
    | None -> embed-string str |> read-inline ctx)
  in
  print-yoko pt propts print

let-inline ctx \yoko-text pt propts fsize it =
  let ctx = ctx |> set-font-size fsize in
  let print spr =
    (match spr with
    | Some l -> error [`cannot use spread with \yoko-text`]
    | None -> read-inline ctx it)
  in
  print-yoko pt propts print

%--------------------------------------- postal code

let parse-postal-code str =
  let-rec iter k =
    if k < string-length str then
      let c = string-sub str k 1 in
      (match c with
      | `-` -> iter (k + 1)
      | #` `# -> iter (k + 1)
      | `_` -> #` `# :: (iter (k + 1))
      | _ -> if is-digit c then c :: (iter (k + 1))
          else error [`bad character in postal code`; str])
    else []
  in
  let res = iter 0 in
  if List.length res == 7 then res
  else error [`postal code has bad length`; str]

let postal-code-graphics ctx acfg xs y fsize str =
  let ctx = ctx |> set-font Latin acfg#pcode-font
    |> set-font-size fsize in
  let-rec iter | _ _ [] = []
               | k (x::xs) (c::cs) =
    let ib = embed-string c |> read-inline ctx in
    let (wd, ht, _) = get-natural-metrics ib in
    let gr = draw-text (x -' wd *' 0.5, y -' ht *' 0.5) ib in
    gr :: (iter (k + 1) xs cs)
               | _ _ _ = error-internal []
  in
  iter 0 xs (parse-postal-code str)

%--------------------------------------- address-from

let make-addr-from ctx bt =
  let () = in-addr-from-ref <- true in
  let bb = read-block ctx bt in
  let () = in-addr-from-ref <- false in
  bb

let add-background imgopt grs =
  (match imgopt with
  | None -> grs
  | Some img ->
      let (papwd, _) = paper-size in
      let gr = draw-text (0pt, 0pt) (use-image-by-width img papwd) in
      gr :: grs)

let-block ctx +address-from pcode itctt =
  let () = check-in-addr-from `+address-from` in
  let () = check-duplicate-addr-from `+address-from` in
  let acfg = get-a-config () in
  % postal code
  let xs = [0.70cm; 1.10cm; 1.49cm; 1.99cm; 2.40cm; 2.80cm; 3.20cm] in
  let grpcode = postal-code-graphics ctx acfg xs 2.30cm 15pt pcode in
  % content
  let grctt = draw-text (0pt, 0pt) (read-inline-zs ctx itctt) in
  % render
  make-page ctx (add-background acfg#background (grctt :: grpcode))

%--------------------------------------- address-to

let make-addr-to ctx bt =
  let () = in-addr-to-ref <- true in
  let bb = read-block ctx bt in
  let () = in-addr-to-ref <- false in
  bb

let-block ctx +address-to pcode itctt =
  let () = check-in-addr-to `+address-to` in
  let acfg = get-a-config () in
  % postal code
  let xs = [4.67cm; 5.36cm; 6.05cm; 6.80cm; 7.48cm; 8.17cm; 8.85cm] in
  let grpcode = postal-code-graphics ctx acfg xs 13.30cm 20pt pcode in
  % content
  let grctt = draw-text (0pt, 0pt) (read-inline-zs ctx itctt) in
  % render
  make-page ctx (grctt :: grpcode)

%--------------------------------------- config setters

type config-state = context * addrite-config
type config = config-state -> config-state

let make-config ctx cfgs =
  let cfgstt = (ctx, std-a-config) in
  List.fold-left (fun s f -> f s) cfgstt cfgs

let jafont-scale r (ctx, acfg) =
  (ctx |> set-jafont-scale r, acfg)

let update-context upd (ctx, acfg) =
  (ctx |> upd, acfg)

let postal-code-font fnt (ctx, acfg) =
  (ctx, (| acfg with pcode-font = fnt |))

let background-image img (ctx, acfg) =
  (ctx, (| acfg with background = Some img |))

let use-substitute-char b (ctx, acfg) =
  (ctx, (| acfg with use-substitute = b |))

let min-bearing r (ctx, acfg) =
  (ctx, (| acfg with min-bearing = r |))

let space-size r (ctx, acfg) =
  (ctx, (| acfg with space-size = r |))

let small-kana-adjust rxy (ctx, acfg) =
  (ctx, (| acfg with skana-adjust = rxy |))

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

let document ?:cfgs btfrom btto =
  let (papwd, papht) = paper-size in
  % configuration
  let ctx = get-initial-context papwd (command \math)
    |> set-dominant-wide-script Kana
    |> set-dominant-narrow-script Latin
    |> set-jafont-scale std-jafont-scale in
  let (ctx, acfg) = make-config ctx (Option.from [] cfgs) in
  % typeset
  let () = a-config-ref <- Some acfg in
  let bbfrom = make-addr-from ctx btfrom in
  let bbto = make-addr-to ctx btto in
  page-break (UserDefinedPaper paper-size)
    (fun _ -> (|
      text-origin = (0pt, 0pt); text-height = papht;
    |))
    (fun _ -> (|
      header-origin = (0pt, 0pt); header-content = block-nil;
      footer-origin = (0pt, 0pt); footer-content = bbfrom;
    |))
    bbto

end
%===========================================================

%% EOF

解説記事→SATySFiで年賀状宛名印刷する話