stjarticle.satyh

% -*- coding: utf-8 -*-
%version[1.3.2]
%Repository:https://github.com/puripuri2100/stjarticle
%
%SATySFi:
%https://github.com/gfngfn/SATySFi
%Author:
%(C) Naoki Kaneko and T. Suwa 2018

@require: gr
@require: list
@require: math
@require: color


module Stjarticle : sig

  val document : 'a -> block-text -> document
    constraint 'a :: (|
      title : inline-text;
      author : inline-text;
      date : inline-text;
      normal-font-size : length;
      show-toc : bool;
      show-title : bool;
      show-footer : bool;
      show-header : bool;
      show-title-deco : bool;
    |)

  val font-latin-roman  : string * float * float
  val font-latin-italic : string * float * float
  val font-latin-sans   : string * float * float
  val font-latin-mono   : string * float * float
  val font-cjk-mincho   : string * float * float
  val font-cjk-gothic   : string * float * float
  val set-latin-font : (string * float * float) -> context -> context
  val set-cjk-font   : (string * float * float) -> context -> context
  direct \ref : [string] inline-cmd
  direct \ref-page : [string] inline-cmd
  direct \figure : [string?; inline-text; block-text] inline-cmd
  direct +p : [inline-text] block-cmd
  direct +ph : [inline-text] block-cmd
  direct +pn : [inline-text] block-cmd
  direct +ep : [inline-text] block-cmd
  direct +part : [string?; inline-text; block-text] block-cmd
  direct +chapter : [string?; inline-text; block-text] block-cmd
  direct +section : [string?; inline-text; block-text] block-cmd
  direct +subsection : [string?; inline-text; block-text] block-cmd
  direct +subsubsection : [string?;inline-text;block-text]block-cmd
  direct \textrm : [inline-text] inline-cmd
  direct \textbf : [inline-text] inline-cmd
  direct \textit : [inline-text] inline-cmd
  direct \textsf : [inline-text] inline-cmd
  direct \textgt : [inline-text] inline-cmd
  direct \textmc : [inline-text] inline-cmd
  direct \text-tiny : [inline-text] inline-cmd
  direct \text-scriptsize : [inline-text] inline-cmd
  direct \text-footnotesize : [inline-text] inline-cmd
  direct \text-small : [inline-text] inline-cmd
  direct \text-normalsize : [inline-text] inline-cmd
  direct \text-large : [inline-text] inline-cmd
  direct \text-Large : [inline-text] inline-cmd
  direct \text-LARGE : [inline-text] inline-cmd
  direct \text-huge : [inline-text] inline-cmd
  direct \text-Huge : [inline-text] inline-cmd
  direct \font-size : [length; inline-text] inline-cmd
  direct \font-size-modify : [float; inline-text] inline-cmd

end = struct

 type toc-element =
    | TOCElementPart    of string * inline-text
    | TOCElementChapter    of string * inline-text
    | TOCElementSection    of string * inline-text
    | TOCElementSubsection of string * inline-text


  let generate-fresh-label =
    let-mutable count <- 0 in
      (fun () -> (
        let () = count <- !count + 1 in
          `generated:` ^ (arabic (!count))
      ))


  let-inline ctx \ref key =
    let opt = get-cross-reference (key ^ `:num`) in
    let it =
      match opt with
      | None    -> {?}
      | Some(s) -> embed-string s
    in
      read-inline ctx it


  let-inline ctx \ref-page key =
    let opt = get-cross-reference (key ^ `:page`) in
    let it =
      match opt with
      | None    -> {?}
      | Some(s) -> embed-string s
    in
      read-inline ctx it


  let-mutable font-size-normal-ref <-  0pt
  let font-size-title   = 34pt
  let font-size-author  = 16pt
  let font-size-date = 16pt
  let font-size-part = 28pt
  let font-size-chapter = 24pt
  let font-size-section = 18pt
  let font-size-subsection = 16pt
  let font-size-subsubsection = 14pt

  let section-top-margin = 20pt
  let section-bottom-margin = 12pt
  let section-top-padding = 6pt
  let section-bottom-padding = 7pt
  let section-line-sep = 4pt
  let section-line-thickness1 = 2pt
  let section-line-thickness2 = 1pt
  let title-line-margin = 4pt
  let title-line-thickness = 1pt
  let header-line-thickness = 0.5pt
  let header-line-margin-top = 2pt
  let header-line-margin-bottom = 6pt

  let font-ratio-latin = 1.
  let font-ratio-cjk = 0.88

  let font-latin-roman  = (`Junicode`   , font-ratio-latin, 0.)
  let font-latin-bold  = (`Junicode-b`   , font-ratio-latin, 0.)
  let font-latin-italic = (`Junicode-it`, font-ratio-latin, 0.)
  let font-latin-sans   = (`lmsans`    , font-ratio-latin, 0.)
  let font-latin-mono   = (`lmmono`    , font-ratio-latin, 0.)
  let font-cjk-mincho   = (`ipaexm`    , font-ratio-cjk  , 0.)
  let font-cjk-gothic   = (`ipaexg`    , font-ratio-cjk  , 0.)


  let set-latin-font font ctx =
    ctx |> set-font Latin font


  let set-cjk-font font ctx =
    ctx |> set-font HanIdeographic font
        |> set-font Kana           font


  let get-standard-context wid =
    get-initial-context wid (command \math)
      |> set-dominant-wide-script Kana
      |> set-language Kana Japanese
      |> set-language HanIdeographic Japanese
      |> set-dominant-narrow-script Latin
      |> set-language Latin English
      |> set-font Kana           font-cjk-mincho
      |> set-font HanIdeographic font-cjk-mincho
      |> set-font Latin          font-latin-roman
      |> set-math-font `lmodern`
      |> set-hyphen-penalty 100


  let-mutable ref-float-boxes <- []


  let height-of-float-boxes pageno =
%    let () = display-message `get height` in
    (!ref-float-boxes) |> List.fold-left (fun h (pn, bb) -> (
      if pn < pageno then h +' (get-natural-length bb) else h
    )) 0pt


  let-mutable ref-figure <- 0


  let-inline ctx \figure ?:labelopt caption inner =
    let () = ref-figure <- !ref-figure + 1 in
    let s-num = arabic (!ref-figure) in
    let () =
      match labelopt with
      | Some(label) -> register-cross-reference (label ^ `:num`) s-num
      | None        -> ()
    in
    let it-num = embed-string s-num in
    let bb-inner =
      let d (_, _) _ _ _ = [] in
      block-frame-breakable ctx (2pt, 2pt, 2pt, 2pt) (d, d, d, d) (fun ctx -> (
        read-block ctx inner
          +++ line-break true true ctx (inline-fil ++ read-inline ctx {図#it-num; #caption;} ++ inline-fil)
      ))
    in
      hook-page-break (fun pbinfo _ -> (
%        let () = display-message (`register` ^ (arabic pbinfo#page-number)) in
        ref-float-boxes <- (pbinfo#page-number, bb-inner) :: !ref-float-boxes
      ))


let title-deco =
    let pads = (5pt, 5pt, 10pt, 10pt) in
    let deco (x, y) wid hgt dpt =
      let path1 =
        let cx = 14pt in
        let cy = 8pt in
        let xL = x in
        let xR = x +' wid in
        let yT = y +' hgt in
        let yB = y -' dpt in
          start-path (xL, yT)
            |> line-to (xR, yT)
            |> bezier-to (xR +' cx, yT -' cy) (xR +' cx, yB +' cy) (xR, yB)
            |> line-to (xL, yB)
            |> close-with-bezier (xL -' cx, yB +' cy) (xL -' cx, yT -' cy)
      in
      let path2 =
        let cx = 12pt in
        let cy = 8pt in
        let gapx = 3pt in
        let gapy = 5pt in
        let xL = x +' gapx in
        let xR = x +' wid -' gapx in
        let yT = y +' hgt -' gapy in
        let yB = y -' dpt +' gapy in
          start-path (xL, yT)
            |> line-to (xR, yT)
            |> bezier-to (xR +' cx, yT -' cy) (xR +' cx, yB +' cy) (xR, yB)
            |> line-to (xL, yB)
            |> close-with-bezier (xL -' cx, yB +' cy) (xL -' cx, yT -' cy)
      in
        [
          stroke 3pt Color.black path1;
          stroke 1pt Color.black path2;
        ]
    in
      (deco, deco, deco, deco)


  let-block ctx +make-title it-title it-author it-date record =
    let pads = (20pt, 20pt, 10pt, 10pt) in
    let nodeco (_, _) _ _ _ = [] in
    let deco = if record#show-title-deco
      then title-deco
      else (nodeco, nodeco, nodeco, nodeco) in
    block-frame-breakable ctx pads deco (fun ctx -> (
      let ctx-title =
        ctx |> set-font-size font-size-title
            |> set-font Latin font-latin-roman
      in
      let ctx-author =
        ctx |> set-font-size font-size-author
            |> set-font Latin font-latin-roman
      in
      let ctx-date =
        ctx |> set-font-size font-size-date
            |> set-font Latin font-latin-roman
     in    
      let ib-title = read-inline ctx-title it-title in
      let ib-line =
        let thk = title-line-thickness in
        let wid = get-text-width ctx in
        let path (x, y) =
          start-path (x, y +' thk *' 0.5)
            |> line-to (x +' wid, y +' thk *' 0.5)
            |> terminate-path
        in
        inline-graphics wid thk 0pt (fun pt -> (
          [ stroke thk Color.black (path pt); ]
        ))
      in
      let ib-author = read-inline ctx-author it-author in
      let ib-date = read-inline ctx-date it-date in
      let bb-title =
%        if get-text-width ctx <' get-natural-width ib-title then
%          form-paragraph ctx-title (ib-title ++ inline-fil)
%        else
          form-paragraph (ctx-title |> set-paragraph-margin 12pt 0pt)
            (inline-fil ++ ib-title ++ inline-fil)
      in
      let bb-line =
        form-paragraph (ctx |> set-paragraph-margin title-line-margin title-line-margin)
          (ib-line ++ inline-fil)
      in
      let bb-author = form-paragraph ctx-author (ib-date ++ inline-fil ++ ib-author) in
        bb-title +++ bb-line +++ bb-author
    ))

  let make-part-title ctx =
    ctx |> set-font-size font-size-section
        |> set-font Latin font-latin-sans
        |> set-cjk-font font-cjk-gothic

  let make-chapter-title ctx =
    ctx |> set-font-size font-size-section
        |> set-font Latin font-latin-sans
        |> set-cjk-font font-cjk-gothic

  let make-section-title ctx =
    ctx |> set-font-size font-size-section
        |> set-font Latin font-latin-sans
        |> set-cjk-font font-cjk-gothic


  let make-subsection-title ctx =
    ctx |> set-font-size font-size-subsection
        |> set-font Latin font-latin-sans
        |> set-cjk-font font-cjk-gothic


  let make-subsubsection-title ctx =
    ctx |> set-font-size font-size-subsubsection
        |> set-font Latin font-latin-sans
        |> set-cjk-font font-cjk-gothic

  let-mutable toc-acc-ref <- []


  let get-cross-reference-number label =
    match get-cross-reference (label ^ `:num`) with
    | None    -> `?`
    | Some(s) -> s


  let get-cross-reference-page label =
    match get-cross-reference (label ^ `:page`) with
    | None    -> `?`
    | Some(s) -> s


  let section-heading ctx ib-heading =
    let wid = get-text-width ctx in
    let h = section-line-sep in
    let th1 = section-line-thickness1 in
    let th2 = section-line-thickness2 in
    let color = get-text-color ctx in
      line-break true false (ctx |> set-paragraph-margin section-top-margin 0pt)
        (inline-graphics wid h 0pt (fun (x, y) -> [
          stroke th1 color (Gr.line (x, y +' h) (x +' wid, y +' h));
          stroke th2 color (Gr.line (x, y) (x +' wid, y));
        ]))
    +++
      line-break false false (ctx |> set-paragraph-margin section-top-padding section-bottom-padding)
        ib-heading
    +++
      line-break false false (ctx |> set-paragraph-margin 0pt section-bottom-margin)
        (inline-graphics wid h 0pt (fun (x, y) -> [
          stroke th2 color (Gr.line (x, y +' h) (x +' wid, y +' h));
          stroke th1 color (Gr.line (x, y) (x +' wid, y));
        ]))


  let-inline ctx \dummy it =
    let ib = read-inline (ctx |> set-text-color Color.white) it in
    let w = get-natural-width ib in
      ib ++ inline-skip (0pt -' w)


  let-rec repeat-inline n ib =
    if n <= 0 then inline-nil else
      ib ++ (repeat-inline (n - 1) ib)


  let make-dots-line ctx w =
    let ib = read-inline ctx {.} ++ inline-skip 1pt in
    let wdot = get-natural-width ib in
    let n = round (w /' wdot) in
      inline-fil ++ (repeat-inline n ib)


  let document record inner =
    % -- constants --
    let () = font-size-normal-ref <- record#normal-font-size in
    let title = record#title in
    let author = record#author in
    let date = record#date in
    let page = A4Paper in
    let txtorg = (80pt, 100pt) in
    let txtwid = 440pt in
    let txthgt = 630pt in
    let hdrorg = (40pt, 30pt) in
    let ftrorg = (40pt, 780pt) in
    let hdrwid = 520pt in
    let ftrwid = 520pt in
    let thickness = header-line-thickness in

    let ctx-doc = get-standard-context txtwid in

    % -- title --
    let bb-title =
      if record#show-title then
        read-block ctx-doc '<+make-title(title)(author)(date)(record);>
      else
        block-nil
    in

    % -- main --
    let bb-main = read-block ctx-doc inner in

    % -- table of contents --
    let toc-part-indent = 0pt in
    let toc-chapter-indent = 0pt in
    let toc-section-indent = 13.5pt in
    let toc-subsection-indent = 13.5pt in
    let bb-toc =
      if not record#show-toc then
        block-nil
      else
        let ib-toc-title =
          read-inline (make-section-title ctx-doc) {目次} ++ inline-fil
        in
        let bb-toc-main =
          (!toc-acc-ref) |> List.reverse |> List.fold-left (fun bbacc tocelem -> (
            match tocelem with
          | TOCElementPart(label, title) ->
                let it-num = embed-string (get-cross-reference-number label) in
                let it-page = embed-string (get-cross-reference-page label) in
                let ib-title =
                  inline-skip toc-part-indent
                    ++ read-inline ctx-doc {#it-num; #title;}
                      ++ inline-skip 3pt
                in
                let ib-page = inline-skip 3pt ++ read-inline ctx-doc it-page in
                let ib-middle =
                  let w = (get-text-width ctx-doc) -' (get-natural-width ib-title) -' (get-natural-width ib-page) in
                    if w <' 0pt then inline-fil else
                      make-dots-line ctx-doc w
                in
                  bbacc +++ line-break true true ctx-doc
                    (ib-title ++ inline-fil ++ib-page)


          | TOCElementChapter(label, title) ->
                let it-num = embed-string (get-cross-reference-number label) in
                let it-page = embed-string (get-cross-reference-page label) in
                let ib-title =
                  inline-skip toc-chapter-indent
                    ++ read-inline ctx-doc {#it-num; #title;}
                      ++ inline-skip 3pt
                in
                let ib-page = inline-skip 3pt ++ read-inline ctx-doc it-page in
                let ib-middle =
                  let w = (get-text-width ctx-doc) -' (get-natural-width ib-title) -' (get-natural-width ib-page) in
                    if w <' 0pt then inline-fil else
                      make-dots-line ctx-doc w
                in
                  bbacc +++ line-break true true ctx-doc
                    (ib-title ++ inline-fil ++ ib-page)


        | TOCElementSection(label, title) ->
            let it-num = embed-string (get-cross-reference-number label) in
            let it-page = embed-string (get-cross-reference-page label) in
            let ib-title = 
              inline-skip toc-section-indent
              ++ read-inline ctx-doc {#it-num;. #title;} ++ inline-skip 3pt in
            let ib-page = inline-skip 3pt ++ read-inline ctx-doc it-page in
            let ib-middle =
              let w = (get-text-width ctx-doc) -' (get-natural-width ib-title) -' (get-natural-width ib-page) in
                    if w <' 0pt then inline-fil else
                      make-dots-line ctx-doc w
                in
                  bbacc +++ line-break true true ctx-doc
                    (ib-title ++ ib-middle ++ ib-page)

          | TOCElementSubsection(label, title) ->
                let it-num = embed-string (get-cross-reference-number label) in
                let it-page = embed-string (get-cross-reference-page label) in
                let ib-title =
                  inline-skip toc-subsection-indent
                    ++ read-inline ctx-doc {#it-num;. #title;}
                      ++ inline-skip 3pt
                in
                let ib-page = inline-skip 3pt ++ read-inline ctx-doc it-page in
                let ib-middle =
                  let w = (get-text-width ctx-doc) -' (get-natural-width ib-title) -' (get-natural-width ib-page) in
                    if w <' 0pt then inline-fil else
                      make-dots-line ctx-doc w
                in
                  bbacc +++ line-break true true ctx-doc
                    (ib-title ++ ib-middle ++ ib-page)

          )) block-nil
        in
          (section-heading ctx-doc ib-toc-title) +++ bb-toc-main
    in

    % -- page settings --
    let pagecontf pbinfo =
      let hgtfb = height-of-float-boxes pbinfo#page-number in
      let (txtorgx, txtorgy) = txtorg in
      (|
        text-origin = (txtorgx, txtorgy +' hgtfb);
        text-height = txthgt -' hgtfb;
      |)
    in
    let pagepartsf pbinfo =
      let pageno = pbinfo#page-number in
      let header =
       if not record#show-header then
        block-nil
       else
        if record#show-title && pbinfo#page-number == 1 then
            block-nil
          else
        let ctx =
          get-standard-context hdrwid
            |> set-paragraph-margin 0pt 0pt
        in
        let ib-text =
         if pageno mod 2 == 0 then
           (read-inline ctx author++ inline-fil ++ read-inline ctx title)
         else
           (read-inline ctx title ++ inline-fil ++ read-inline ctx author)
       in
%       let () = display-message `insert` in
       let (bb-float-boxes, acc) =
         (!ref-float-boxes) |> List.fold-left (fun (bbacc, acc) elem -> (
           let (pn, bb) = elem in
             if pn < pageno then
               let bbs =
                 line-break true true (ctx |> set-paragraph-margin 0pt 12pt)
                   (inline-fil ++ embed-block-top ctx txtwid (fun _ -> bb) ++ inline-fil)
                     % 'ctx' is a dummy context
               in
                 (bbacc +++ bbs, acc)
             else
               (bbacc, elem :: acc)
         )) (block-nil, [])
       in
       let () = ref-float-boxes <- acc in
          line-break true true ctx ib-text
            +++ line-break true true (ctx |> set-paragraph-margin header-line-margin-top header-line-margin-bottom)
              ((inline-graphics hdrwid thickness 0pt
                (fun (x, y) -> [ fill Color.black (Gr.rectangle (x, y) (x +' hdrwid, y +' thickness))])) ++ inline-fil)
            +++ bb-float-boxes
      in
      let footer =
       if not record#show-footer then
         block-nil
       else
         let ctx = get-standard-context ftrwid in
         let it-pageno = embed-string (arabic pbinfo#page-number) in
           line-break true true ctx
             (inline-fil ++ (read-inline ctx {— #it-pageno; —}) ++ inline-fil)
      in
        (|
          header-origin  = hdrorg;
          header-content = header;
          footer-origin  = ftrorg;
          footer-content = footer;
        |)
    in
      page-break page pagecontf pagepartsf (bb-title +++ bb-toc +++ bb-main)


  let-mutable needs-indentation-ref <- true

  let-mutable num-part <- 0
  let-mutable num-chapter <- 0
  let-mutable num-section <- 0
  let-mutable num-subsection <- 0
  let-mutable num-subsubsection <- 0


  let quad-indent-ja ctx =
    inline-skip (get-font-size ctx *' 0.88)

 let quad-indent-en ctx =
    inline-skip (get-font-size ctx *' 1.0)


  let-block ctx +p inner =
    let ib-inner = 
        let ctx-normal = 
        ctx |> set-font-size !font-size-normal-ref
    in
    read-inline ctx-normal inner in
    let br-parag =
        (quad-indent-ja ctx) ++ ib-inner ++ inline-fil
    in
      form-paragraph ctx br-parag

  let-block ctx +ph inner =
    let ib-inner = 
        let ctx-normal = 
        ctx |> set-font-size !font-size-normal-ref
    in
    read-inline ctx-normal inner in
    let br-parag =
        (quad-indent-en ctx) ++ ib-inner ++ inline-fil
    in
      form-paragraph ctx br-parag


  let-block ctx +pn inner =
    let () = needs-indentation-ref <- true in
    let ib-inner = 
        let ctx-normal = 
        ctx |> set-font-size !font-size-normal-ref
    in
    read-inline ctx-normal inner in
      form-paragraph ctx (ib-inner ++ inline-fil)

 let-block ctx +ep inner =
    let needs-indentation =
      if !needs-indentation-ref then true else
        let () = needs-indentation-ref <- true in
          false
    in
    let ib-inner = 
        let ctx-normal = 
        ctx |> set-font-size !font-size-normal-ref
    in
    read-inline ctx-normal inner in
    let br-parag =
      if needs-indentation then
        (quad-indent-en ctx) ++ ib-inner ++ inline-fil
      else
        ib-inner ++ inline-fil
    in
      form-paragraph ctx br-parag

  let part-scheme ctx label title inner =
    let ctx-title = make-part-title ctx in
    let () = num-part <- !num-part + 1 in
    let () = num-chapter <- 0 in
    let () = needs-indentation-ref <- false in
    let s-num = `第` ^ arabic (!num-part) ^ `部` in
    let () = register-cross-reference (label ^ `:num`) s-num in
    let () = toc-acc-ref <- (TOCElementPart(label, title)) :: !toc-acc-ref in
    let ctx-title = make-part-title ctx in
    let ib-num =
      read-inline ctx-title (embed-string (s-num))
        ++ hook-page-break (fun pbinfo _ -> register-cross-reference (label ^ `:page`) (arabic pbinfo#page-number))
    in
    let ib-title = read-inline ctx-title title in
    let bb-title =
      line-break true false (ctx |> set-paragraph-margin section-top-margin section-bottom-margin)
        (ib-num ++ (inline-skip 20pt) ++ ib-title ++ (inline-fil))
    in
    let bb-inner = read-block ctx inner in
      bb-title +++ bb-inner


  let chapter-scheme ctx label title inner =
    let () = num-chapter <- !num-chapter + 1 in
    let () = num-section <- 0 in
    let () = needs-indentation-ref <- false in
    let s-num = `第` ^ arabic (!num-chapter) ^ `章` in
    let () = register-cross-reference (label ^ `:num`) s-num in
    let () = toc-acc-ref <- (TOCElementChapter(label, title)) :: !toc-acc-ref in
    let ctx-title = make-chapter-title ctx in
    let ib-num =
      read-inline ctx-title (embed-string (s-num))
        ++ hook-page-break (fun pbinfo _ -> register-cross-reference (label ^ `:page`) (arabic pbinfo#page-number))
    in
    let ib-title = read-inline ctx-title title in
    let bb-title =
      line-break true false (ctx |> set-paragraph-margin section-top-margin section-bottom-margin)
        (ib-num ++ (inline-skip 15pt) ++ ib-title ++ (inline-fil))
    in
    let bb-inner = read-block ctx inner in
      bb-title +++ bb-inner


  let section-scheme ctx label title inner =
    let ctx-title = make-section-title ctx in
    let () = num-section <- !num-section + 1 in
    let () = num-subsection <- 0 in
    let () = needs-indentation-ref <- false in
    let s-num = arabic (!num-section) in
    let () = register-cross-reference (label ^ `:num`) s-num in
    let () = toc-acc-ref <- (TOCElementSection(label, title)) :: !toc-acc-ref in
    let ib-num =
      read-inline ctx-title (embed-string (s-num ^ `.`))
        ++ hook-page-break (fun pbinfo _ -> register-cross-reference (label ^ `:page`) (arabic pbinfo#page-number))
    in
    let ib-title = read-inline ctx-title title in
    let bb-title = 
      line-break true false (ctx |> set-paragraph-margin section-top-margin section-bottom-margin)
        (ib-num ++ (inline-skip 10pt) ++ ib-title ++ (inline-fil))
    in
%    section-heading ctx (ib-num ++ (inline-skip 10pt) ++ ib-title ++ (inline-fil))    in
    let bb-inner = read-block ctx inner in
      bb-title +++ bb-inner


  let subsection-scheme ctx label title inner =
    let () = num-subsection <- !num-subsection + 1 in
    let () = needs-indentation-ref <- false in
    let s-num = arabic (!num-section) ^ `.` ^ arabic (!num-subsection) in
    let () = register-cross-reference (label ^ `:num`) s-num in
    let () = toc-acc-ref <- (TOCElementSubsection(label, title)) :: !toc-acc-ref in
    let ctx-title = make-subsection-title ctx in
    let ib-num =
      read-inline ctx-title (embed-string (s-num ^ `.`))
        ++ hook-page-break (fun pbinfo _ -> register-cross-reference (label ^ `:page`) (arabic pbinfo#page-number))
    in
    let ib-title = read-inline ctx-title title in
    let bb-title =
      line-break true false (ctx |> set-paragraph-margin section-top-margin section-bottom-margin)
        (ib-num ++ (inline-skip 10pt) ++ ib-title ++ (inline-fil))
    in
    let bb-inner = read-block ctx inner in
      bb-title +++ bb-inner


  let subsubsection-scheme ctx label title inner =
    let () = num-subsubsection <- !num-subsubsection + 1 in
    let () = needs-indentation-ref <- false in
    let s-num = arabic (!num-section) ^ `.` ^ arabic (!num-subsection) ^ `.` ^arabic(!num-subsubsection) in
    let () = register-cross-reference (label ^ `:num`) s-num in
    let ctx-title = make-subsubsection-title ctx in
    let ib-num =
      read-inline ctx-title (embed-string (s-num ^ `.`))
        ++ hook-page-break (fun pbinfo _ -> register-cross-reference (label ^ `:page`) (arabic pbinfo#page-number))
    in
    let ib-title = read-inline ctx-title title in
    let bb-title =
      line-break true false (ctx |> set-paragraph-margin section-top-margin section-bottom-margin)
        (ib-num ++ (inline-skip 10pt) ++ ib-title ++ (inline-fil))
    in
    let bb-inner = read-block ctx inner in
      bb-title +++ bb-inner

  let-block ctx +part ?:labelopt title inner =
    let label =
      match labelopt with
      | None        -> generate-fresh-label ()
      | Some(label) -> label
    in
      part-scheme ctx label title inner

  let-block ctx +chapter ?:labelopt title inner =
    let label =
      match labelopt with
      | None        -> generate-fresh-label ()
      | Some(label) -> label
    in
      chapter-scheme ctx label title inner

  let-block ctx +section ?:labelopt title inner =
    let label =
      match labelopt with
      | None        -> generate-fresh-label ()
      | Some(label) -> label
    in
      section-scheme ctx label title inner


  let-block ctx +subsection ?:labelopt title inner =
    let label =
      match labelopt with
      | None        -> generate-fresh-label ()
      | Some(label) -> label
    in
      subsection-scheme ctx label title inner

  let-block ctx +subsubsection ?:labelopt title inner =
    let label =
      match labelopt with
      | None        -> generate-fresh-label ()
      | Some(label) -> label
    in
      subsubsection-scheme ctx label title inner

let-inline ctx \textrm it =
    let ctxrm =
        ctx |> set-latin-font font-latin-roman
            |> set-cjk-font font-cjk-mincho
    in
read-inline ctxrm it

let-inline ctx \textbf it =
    let ctxbf =
        ctx |> set-latin-font font-latin-bold
            |> set-cjk-font font-cjk-gothic
    in
read-inline ctxbf it

let-inline ctx \textit it =
    let ctxit =
        ctx |> set-latin-font font-latin-italic
            |> set-cjk-font font-cjk-mincho
in
read-inline ctxit it

let-inline ctx \textsf it =
    let ctxsf =
        ctx |> set-latin-font font-latin-sans
            |> set-cjk-font font-cjk-gothic
    in
read-inline ctxsf it

let-inline ctx \textmc it =
    let ctxmc =
        ctx |> set-latin-font font-latin-roman
            |> set-cjk-font font-cjk-mincho
    in
read-inline ctxmc it

let-inline ctx \textgt it =
    let ctxgt =
        ctx |> set-latin-font font-latin-bold
            |> set-cjk-font font-cjk-gothic
    in
read-inline ctxgt it

let-inline ctx \font-size size inner = 
    let ctx-size = 
        ctx |> set-font-size size
    in
        read-inline ctx-size inner

let font-size-modify ctx scale inner =
        let ctx-size =
          ctx |> set-font-size (get-font-size ctx *' scale)
        in read-inline ctx-size inner

let-inline ctx \text-tiny = font-size-modify ctx .5

let-inline ctx \text-scriptsize = font-size-modify ctx .7

let-inline ctx \text-footnotesize = font-size-modify ctx .8

let-inline ctx \text-small = font-size-modify ctx .9

let-inline ctx \text-normalsize = font-size-modify ctx 1.

let-inline ctx \text-large = font-size-modify ctx 1.2

let-inline ctx \text-Large = font-size-modify ctx 1.44

let-inline ctx \text-LARGE = font-size-modify ctx 1.728

let-inline ctx \text-huge = font-size-modify ctx 2.074

let-inline ctx \text-Huge = font-size-modify ctx 2.488

let-inline ctx \font-size-modify scale inner = 
    let ctx-size-modify = 
        ctx |> set-font-size (get-font-size ctx *' scale)
    in
        read-inline ctx-size-modify inner

end


let document = Stjarticle.document
  % ad-hoc