pop.satyh

% -*- coding: utf-8 -*-
@require: pervasives
@require: gr
@require: list
@require: option
@require: math
@require: color
@require: vdecoset

% SATySFi-base
@require: base/context
@require: base/block
@require: base/inline
@require: base/image

module Pop : sig

  val document : block-text -> document

  val font-latin-roman  : string * float * float
  val font-latin-italic : string * float * float
  val font-latin-bold   : 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
  val get-latin-font-size : context -> length
  val get-cjk-font-size : context -> length

  %- @doc: {
  %-   段落を挿入するコマンド
  %- }
  direct +p-noindent : [inline-text] block-cmd

  %- @doc: {
  %-   改行を挿入するコマンド
  %- }
  direct +linebreak : [] block-cmd

  %- @doc: {
  %-   最新刊の表紙を表示するコマンド。大きめに出力される
  %- }
  direct +front-image-new : [string] block-cmd

  %- @doc: {
  %-   表紙を表示するコマンド
  %- }
  direct +front-image : [string] block-cmd

  %- @doc: {
  %-   古い版の表紙を表示するコマンド。小さめに出力される
  %- }
  direct +front-image-old : [string] block-cmd

  %- @doc: {
  %-   QRコードを出力する
  %- }
  direct +qr-image : [string] block-cmd

  %- @doc: {
  %-   巻数を表示するコマンド
  %- }
  direct +vol : [int] block-cmd

  %- @doc: {
  %-   古い巻の巻数を表示するコマンド
  %- }
  direct +vol-old : [int] block-cmd

  %- @doc: {
  %-   価格を表示するコマンド
  %- }  
  direct +price: [string?; string; int] block-cmd
  direct \price: [string?; string; int] inline-cmd

  direct \emph : [inline-text] inline-cmd
  direct \bold : [inline-text] inline-cmd
  direct \huge : [inline-text] inline-cmd
  direct \Large : [inline-text] inline-cmd
  direct \large : [inline-text] inline-cmd
  direct \normal : [inline-text] inline-cmd
  direct \small : [inline-text] inline-cmd
  direct \roman : [inline-text] inline-cmd
  direct \mono : [inline-text] inline-cmd

  direct +listing-with-gap : [bool?; length; itemize] block-cmd
  direct \listing-with-gap : [bool?; length; itemize] inline-cmd
  direct +enumerate-with-gap : [int?; length; itemize] block-cmd
  direct \enumerate-with-gap : [length; itemize] inline-cmd
end = struct
  let font-size-small   = 9pt
  let font-size-normal  = 13pt
  let font-size-large   = 18pt
  let font-size-Large   = 30pt
  let font-size-huge    = 42pt

  let toc-section-indent = 20pt
  let toc-subsection-indent = 40pt

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

  let font-latin-roman  = (`Junicode`   , font-ratio-latin, 0.)
  let font-latin-italic = (`Junicode-it`, font-ratio-latin, 0.)
  let font-latin-bold   = (`fonts-noto-sans:NotoSans-Bold` , 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 font-otherscript-roman = (`cmunrm` , font-ratio-latin, 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-latin-font-size ctx =
    get-font-size ctx *' font-ratio-latin


  let get-cjk-font-size ctx =
    get-font-size ctx *' font-ratio-cjk


  let-inline ctx \roman inner =
    read-inline (ctx |> set-latin-font font-latin-roman) inner

  let-inline ctx \mono inner =
    read-inline (ctx |> set-latin-font font-latin-mono) inner


  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-gothic
      |> set-font HanIdeographic font-cjk-gothic
      |> set-font Latin          font-latin-sans
      |> set-font OtherScript    font-otherscript-roman
      |> set-math-font `fonts-asana-math:AsanaMath`
      |> set-hyphen-penalty 1000
      |> set-space-ratio 0.275 0.08 0.12
      |> set-font-size font-size-normal

  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 get-cross-reference-number prefix label =
    match get-cross-reference (prefix ^ label ^ `:num`) with
    | None    -> `?`
    | Some(s) -> s

  let paper-width = 182mm
  let paper-height = 257mm
  let top-margin = 10mm
  let bottom-margin = 10mm
  let side-margin = 20mm
  let paper-size = UserDefinedPaper(paper-width, paper-height)
  let text-origin = (side-margin, top-margin)
  let text-width = paper-width -' (side-margin *' 2.0)
  let text-height = paper-height -' top-margin -' bottom-margin
  let header-origin = (side-margin, top-margin)
  let header-width = text-width
  let footer-origin = (side-margin, paper-height -' bottom-margin)
  let footer-width = text-width

  let document inner =
    % -- constants --
    let page = paper-size in
    let txtorg = text-origin in
    let txtwid = text-width in
    let txthgt = text-height in
    let hdrorg = header-origin in
    let hdrwid = header-width in

    let ctx-doc =
      get-standard-context txtwid
        |> set-font-size font-size-normal
        |> set-leading 18pt
        |> set-hyphen-penalty 1000
        |> set-paragraph-margin 5pt 5pt
    in

    % -- main --
    let bb-main = read-block ctx-doc inner 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 =
        let ctx =
          get-standard-context hdrwid
            |> set-paragraph-margin 0pt 0pt
        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
          bb-float-boxes
      in
        (|
          header-origin  = hdrorg;
          header-content = header;
          footer-origin  = footer-origin;
          footer-content = Block.nil;
        |)
    in
      page-break page pagecontf pagepartsf bb-main

  let-block ctx +p-noindent inner =
    let ib-inner = read-inline ctx inner ++ inline-fil in
      form-paragraph ctx ib-inner

  let-block ctx +front-image-new path =
    Image.of-jpeg path |>
      Inline.of-image (text-width *' 0.43) |>
      form-paragraph ctx

  let-block ctx +front-image path =
    Image.of-jpeg path |>
      Inline.of-image (text-width *' 0.3) |>
      form-paragraph ctx

  let-block ctx +front-image-old path =
    Image.of-jpeg path |>
      Inline.of-image (text-width *' 0.25) |>
      form-paragraph ctx

  let-block ctx +qr-image path =
    (Inline.fil ++
     (Image.of-jpeg path |> Inline.of-image (text-width *' 0.25)) ++
     Inline.fil) |>
      form-paragraph ctx

  let-block ctx +linebreak =
    form-paragraph ctx inline-fil

  let-inline ctx \emph inner =
    let ctx-emph =
      ctx |> set-font Latin font-latin-italic
          |> set-cjk-font font-cjk-gothic
    in
      read-inline ctx-emph inner

  let-inline ctx \bold inner =
    let ctx-bold =
      ctx |> set-font Latin font-latin-bold
          |> set-cjk-font font-cjk-gothic
    in
      read-inline ctx-bold inner
      
  let-inline ctx \small inner =
    let ctx-large =
      ctx |> set-font-size font-size-small
    in
      Inline.read inner ctx-large

  let-inline ctx \normal inner =
    let ctx-large =
      ctx |> set-font-size font-size-normal
    in
      Inline.read inner ctx-large

  let-inline ctx \large inner =
    let ctx-large =
      ctx |> set-font-size font-size-large
    in
      Inline.read inner ctx-large
     
  let-inline ctx \huge inner =
    let ctx-Large =
      ctx |> set-font-size font-size-huge
    in
      Inline.read inner ctx-Large

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

  let-block ctx +vol vol =
    let vol-it = embed-string (String.of-int vol) in
    let bt = '<+p-noindent{\mono{\large{yabaitech.tokyo}} \Large{\bold{vol.#vol-it;}}}> in
      Block.read bt ctx

  let-block ctx +vol-old vol =
    let vol-it = embed-string (String.of-int vol) in
    let bt = '<+p-noindent{\mono{\normal{yabaitech.tokyo}} \large{\bold{vol.#vol-it;}}}> in
      Block.read bt ctx

  let-inline ctx \price ?:price-prfix-opt title price =
    let price-prefix = Option.unwrap-or String.empty price-prfix-opt in
    let title-it = embed-string title in
    let price-it = embed-string (price-prefix ^ String.of-int price) in
    let it = {\bold{#title-it;: \large{#price-it;円}}} in
      Inline.read it ctx

  let-block ctx +price ?:price-prfix-opt title price =
    let price-prefix = Option.unwrap-or String.empty price-prfix-opt in
    let title-it = embed-string title in
    let price-it = embed-string (price-prefix ^ String.of-int price) in
    let bt = '<+p-noindent{\bold{#title-it;: \large{#price-it;円}}}> in
      Block.read bt ctx

  let (+++>) = List.fold-left (+++)

  let (+++>) = List.fold-left (+++)
  let concat-blocks = (+++>) block-nil


  let item-indent = 16pt
  let item-gap = 10pt


  let bullet color (x, y) =
    let cx = x +' 4pt in
    let cy = y +' 4pt in
    let r = 2pt in
      [ fill color (Gr.circle (cx, cy) r); ]


  let-rec listing-item : context -> int -> itemize -> block-boxes
    | ctx depth (Item(parent, children)) =
        let color = get-text-color ctx in
        let ib-bullet = inline-graphics 8pt 8pt 0pt (bullet color) ++ inline-skip 8pt in
        let bullet-width = get-natural-width ib-bullet in
        let parent-indent = item-indent *' (float depth) in
        let ib-parent =
          embed-block-top ctx ((get-text-width ctx) -' parent-indent -' bullet-width) (fun ctx ->
            form-paragraph (ctx |> set-paragraph-margin item-gap item-gap)
              (read-inline ctx parent ++ inline-fil)
          )
        in
        let bb-parent =
          form-paragraph (ctx |> set-paragraph-margin item-gap item-gap)
            ((inline-skip parent-indent) ++ ib-bullet ++ ib-parent)
        in
        let bblst-children = List.map (listing-item ctx (depth + 1)) children in
        bb-parent +++> bblst-children


  let-rec listing-item-breakable
    | ctx depth (Item(parent, children)) =
        let color = get-text-color ctx in
        let ib-bullet = inline-graphics 8pt 8pt 0pt (bullet color) ++ inline-skip 8pt in
        let bullet-width = get-natural-width ib-bullet in
        let parent-indent = item-indent *' (float depth) in
        let pads = (parent-indent +' bullet-width, 0pt, 0pt, 0pt) in
        let decos =
          let deco _ _ _ _ = [] in
          (deco, deco, deco, deco)
        in
        let bb-parent =
          block-frame-breakable (ctx |> set-paragraph-margin item-gap item-gap) pads decos (fun ctx ->
            form-paragraph ctx
              (inline-skip (0pt -' bullet-width) ++ ib-bullet ++ read-inline ctx parent ++ inline-fil)
          )
        in
        let bblst-children = List.map (listing-item-breakable ctx (depth + 1)) children in
        bb-parent +++> bblst-children


  let listing break ctx outer-gap (Item(_, itmzlst)) =
    if break then
      let bblst = List.map (listing-item-breakable ctx 0) itmzlst in
      block-skip outer-gap +++ concat-blocks bblst +++ block-skip outer-gap
    else
      let bblst = List.map (listing-item ctx 0) itmzlst in
      block-skip outer-gap +++ concat-blocks bblst +++ block-skip outer-gap


  let-block ctx +listing-with-gap ?:breakopt outer-gap item =
    let break = Option.from false breakopt in
    listing break ctx outer-gap item


  let-inline ctx \listing-with-gap ?:breakopt outer-gap item =
    let break = Option.from false breakopt in
      inline-fil ++ embed-block-breakable ctx (listing break ctx outer-gap item)
        ++ omit-skip-after

  let-rec enumerate-item : int -> context -> int -> itemize -> block-boxes
    | index ctx depth (Item(parent, _)) =
        let color = get-text-color ctx in
        let parent-indent = item-indent *' (float depth) in
        let ib-index =
          let it-num = (embed-string (arabic index)) in
            read-inline ctx {#it-num;.\ }
        in
        let index-width = get-natural-width ib-index in
        let ib-parent =
          embed-block-top ctx ((get-text-width ctx) -' parent-indent -' index-width) (fun ctx ->
            form-paragraph (ctx |> set-paragraph-margin item-gap item-gap)
              (read-inline ctx parent ++ inline-fil)
          )
        in
          form-paragraph (ctx |> set-paragraph-margin item-gap item-gap)
            ((inline-skip parent-indent) ++ ib-index ++ ib-parent)


  let enumerate begin ctx outer-gap (Item(_, itmzlst)) =
    let bblst = List.mapi (fun i -> enumerate-item (i + 1 + begin) ctx 0) itmzlst in
      block-skip outer-gap +++ concat-blocks bblst +++ block-skip outer-gap

  let-block ctx +enumerate-with-gap ?:begin-opt outer-gap item =
    let begin = Option.unwrap-or 0 begin-opt in
      enumerate begin ctx outer-gap item


  let-inline ctx \enumerate-with-gap outer-gap item =
    let bb = enumerate 0 ctx outer-gap item in
    inline-fil ++
      embed-block-breakable ctx
        (block-skip outer-gap +++ bb +++ block-skip outer-gap)
      ++ omit-skip-after
end

let document = Pop.document