Blockless SLyDIFi

demo.pdf

demo.saty

@import: slydifi-blockless

let-inline ctx \gray it =
  let ctx2 = ctx |> set-text-color (SlydifiColor.html-color 0xAAAAAA) in
  read-inline ctx2 it

in

Slydifi.document(|
  draft-mode = false;
  fonts = (|
    frame-title-cjk = `mplus-sans-b`;    % 自分が持っているフォントに変えること
    normal-text-cjk  = `mplus-sans-r`;   % 自分が持っているフォントに変えること
    frame-title-latin = `mplus-sans-b`;  % 自分が持っているフォントに変えること
    normal-text-latin  = `mplus-sans-r`; % 自分が持っているフォントに変えること
    mono-text-latin  = `mplus-mono-r`;   % 自分が持っているフォントに変えること
    font-ratio-cjk = 1.0;
  |);
|)[
   frame-anime(5){Overlay 機能のテスト}[
     p{こんなふうに，任意の段落の表示切り替えを好きに制御できる．};

     p-switch(Range(2, 4)){☆★★★☆：2–4のとき有効．}{\gray{☆★★★☆：2–4のとき有効．}};
     p-switch(Only(3)    ){☆☆★☆☆：3 枚目だけ有効．}{\gray{☆☆★☆☆：3 枚目だけ有効．}};
     p-switch(Before(2)  ){★★☆☆☆：2 枚目まで有効．}{\gray{★★☆☆☆：2 枚目まで有効．}};
     p-switch(After(3)   ){☆☆★★★：3 枚目以降有効．}{\gray{☆☆★★★：3 枚目以降有効．}};
     p-switch(GeneralRange(fun i -> (i mod 2) == 1))
       {★☆★☆★：奇数枚目のみ有効．}{\gray{★☆★☆★：奇数枚目のみ有効．}};

    p-ghost(Only(5)){終わり．};
   ];
]

demo.satysfi-aux

{"pagecount":"5"}

slydifi-blockless.satyh

% vim: foldmethod=marker
@require: gr
@require: math
@require: list
@require: annot
@require: satysfi-base/block

@import: slydifi-color

type block = context -> block-boxes
type cel = int -> block

type celRange =
  | Always of unit
  | Only of int
  | Before of int
  | After of int
  | Range of int * int
  | GeneralRange of int -> bool

let phantom-block bb = block-skip (get-natural-length bb)

let-inline ctx \SLyDiFi =
  let size = get-font-size ctx in
  let f = read-inline ctx in
  let fd = ctx |> set-manual-rising (0pt -' (size *' 0.25)) |> read-inline in
  let fI = ctx |> set-font-size (size *' 0.72)
               |> set-manual-rising (size *' 0.2)
               |> read-inline
  in
  let ib =
    f {SL} ++ kern(size *' 0.05) ++ fd{Y} ++ kern(size *' 0.03) ++ f{DIF}
      ++ kern(size *' 0.05) ++ fd{I}
  in
  script-guard Latin (no-break ib)

module Slydifi : sig

  % Signature {{{
  val document: 'a -> block list -> document
    constraint 'a :: (|
      fonts: (|
        frame-title-cjk : string;
        normal-text-cjk : string;
        frame-title-latin : string;
        normal-text-latin : string;
        mono-text-latin : string;
        font-ratio-cjk : float;
      |);
      draft-mode : bool;
    |)

  val paper-width : length
  val paper-height : length

  direct \emph : [inline-text] inline-cmd
  direct \textbf : [inline-text] inline-cmd
  direct \text-color : [color; inline-text] inline-cmd
  direct \br : [] inline-cmd
  direct \link : [inline-text?; string] inline-cmd

  val frame-anime : int -> inline-text -> cel list -> block
  val frame : inline-text -> cel list -> block

  val p-ghost : celRange -> inline-text -> cel
  val p-switch : celRange -> inline-text -> inline-text -> cel
  val p : inline-text -> cel

  % }}}

end = struct

  % blockless satysfi
  let block-list-to-block-boxes ctx b =
    b |> List.map (fun b -> b ctx)
      |> Block.concat

  let cel-list-to-block-boxes ctx c cel-num =
    c |> List.map (fun c -> c cel-num ctx)
      |> Block.concat

  % 文書設定 {{{1
  let font-size-normal  = 20pt
  let font-size-frame-title = 28pt
  let font-size-header-footer = 12pt
  let font-size-title   = 32pt
  let font-size-author  = 20pt
  let font-size-date  = 18pt
  let font-size-institute  = 20pt
  let font-size-section = 28pt
  let font-size-footnote = 12pt

  % PowerPoint の文書サイズに合わせる
  % let paper-width  = 12.8cm
  % let paper-height = 9.6cm
  let paper-width = 25.4cm
  let paper-height = 14.29cm
    % let header-height = 12pt
  let header-height = 24pt
  let footer-height = 24pt
  let text-horizontal-margin = 30pt
  let text-vertical-margin = font-size-normal *' 1.0
  let text-height = paper-height -' text-vertical-margin *' 2.
  let text-width  = paper-width -' text-horizontal-margin *' 2.

  let relwid relx = paper-width *' relx
  let relht rely = paper-height *' rely
  let relpt relx rely = (relwid relx, relht rely)

  let font-ratio-latin = 1.

  let font-latin-roman  = (`Junicode`   , 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`    , 1.0  , 0.)
  let font-cjk-gothic   = (`ipaexg`    , 1.0  , 0.)

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

  % grid
  let main-grid-size = 50pt
  let sub-grid-size = 10pt

  % page
  let-mutable is-first-page <- true

  % colors

  let color-title = SlydifiColor.html-color 0x076678
  let color-bg = SlydifiColor.html-color 0xF9F5D7
  let color-fg = SlydifiColor.html-color 0x282828
  let color-emph = SlydifiColor.html-color 0xCC241D
  let color-link = SlydifiColor.html-color 0x8F3F71
  let color-footer = SlydifiColor.inner-color color-bg color-fg 0.5

  let main-grid-color = SlydifiColor.inner-color color-bg color-fg 0.7
  let sub-grid-color = SlydifiColor.inner-color color-bg color-fg 0.9


  % options {{{
  let-mutable fonts-frame-title-cjk   <- ` `
  let-mutable fonts-frame-title-latin <- ` `
  let-mutable fonts-normal-text-cjk   <- ` `
  let-mutable fonts-normal-text-latin <- ` `
  let-mutable fonts-mono-text-latin   <- ` `
  let-mutable fonts-font-ratio-cjk    <- 1.0
  let-mutable draft-mode              <- false
  % }}}
  % }}}

  % document command {{{

  let clear-page-or-nil is-first-page =
    match !is-first-page with
    | true ->
        let () = is-first-page <- false in
        block-nil
    | false -> clear-page

  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-font-size font-size-normal
      |> set-math-font `lmodern`
      |> set-hyphen-penalty 100
      |> set-leading (font-size-normal *' 1.4)
      |> set-paragraph-margin (font-size-normal *' 0.6) (font-size-normal *' 0.6)
      |> set-text-color color-fg

  let document record inner =

    let page = UserDefinedPaper  (paper-width, paper-height) in

    let () = fonts-frame-title-cjk   <- record#fonts#frame-title-cjk in
    let () = fonts-frame-title-latin <- record#fonts#frame-title-latin in
    let () = fonts-normal-text-cjk   <- record#fonts#normal-text-cjk in
    let () = fonts-normal-text-latin <- record#fonts#normal-text-latin in
    let () = fonts-font-ratio-cjk    <- record#fonts#font-ratio-cjk in
    let () = fonts-mono-text-latin   <- record#fonts#mono-text-latin in
    let () = draft-mode              <- record#draft-mode in

    let ctx-doc = (get-standard-context text-width)
      |> set-font Kana (record#fonts#normal-text-cjk, !fonts-font-ratio-cjk, 0.)
      |> set-font HanIdeographic (record#fonts#normal-text-cjk, !fonts-font-ratio-cjk, 0.)
      |> set-font Latin (record#fonts#normal-text-latin, font-ratio-latin, 0.)
    in

    let bb-main = block-list-to-block-boxes ctx-doc inner in

    let pagecontf _ =
      (|
        text-origin = (text-horizontal-margin, text-vertical-margin);
        text-height = text-height;
      |)
    in

    let pagepartsf pbinfo =
      let footer =
        let ctx = get-standard-context paper-width
          |> set-font Latin (record#fonts#normal-text-latin, font-ratio-latin, 0.)
          |> set-font-size font-size-header-footer
          |> set-text-color color-footer
        in
        let it-pageno = embed-string (arabic pbinfo#page-number) in
        let it-count = match get-cross-reference `pagecount` with
          | None -> {??}
          | Some(i) -> embed-string i
        in
        line-break true true ctx (inline-fil ++ (read-inline ctx {#it-pageno;/#it-count;}) ++ inline-skip 20pt)
      in
      (|
      header-origin  = (0pt, 0pt);
      header-content = block-nil;
      footer-origin  = (0pt, paper-height -' footer-height);
      footer-content = footer;
      |)
    in

    let hook = line-break false false (get-standard-context 0pt)
        (hook-page-break (fun pbInfo _ -> (
            let numpages = pbInfo#page-number in
            register-cross-reference `pagecount` (arabic numpages)
        )))
    in

    page-break page pagecontf pagepartsf (bb-main +++ hook)

  % }}}

  % common function in slides {{{
  let-rec range n1 n2 =
    let-rec aux min max =
      if min == max  then [min] else min :: (aux (min + 1) max)
    in
    if n1 < n2 then (aux n1 n2) else (aux n2 n1)

  let ib-bg =
    let rect-bg =
      fill color-bg (Gr.rectangle (0pt, 0pt) (paper-width, paper-height))
    in
    inline-graphics 0pt 0pt 0pt (fun _ -> [rect-bg])

  let bg-grids grid-wid grid-ht grid-color =
    let n-grid-vertical   = round(paper-width  /' grid-wid) in
    let n-grid-horizontal = round(paper-height /' grid-ht)  in
    let vlines =
      List.map (
        fun n -> Gr.line (grid-wid *' float(n), 0pt) (grid-wid *' float(n), paper-height)
      ) (range 1 n-grid-vertical) in
      % [Gr.line (grid-wid, 0pt) (grid-wid, paper-height)] in
    let hlines =
      List.map (
        fun n -> Gr.line (0pt, grid-ht *' float(n)) (paper-width, grid-ht *' float(n))
      ) (range 1 n-grid-horizontal) in
    % let hlines = [Gr.line (0pt, grid-ht) (paper-width, grid-ht)] in
    let lines = List.append vlines hlines in
    let grid = List.map (stroke 1pt grid-color) lines in
    let ib = inline-graphics 0pt 0pt 0pt (fun _ -> grid) in
    ib

  let make-grids dmode =
    let main-grid = bg-grids main-grid-size main-grid-size main-grid-color in
    let sub-grid = bg-grids sub-grid-size sub-grid-size sub-grid-color in
    if dmode then (sub-grid ++ main-grid) else inline-nil

  let bb-bg ctx dmode =
    let ctx-phantom =
      ctx |> set-font-size 0pt
          |> set-paragraph-margin 0pt 0pt
          |> set-leading 0pt
    in
    (line-break true true ctx-phantom (ib-bg ++ (make-grids dmode) ++ inline-fil))

  % Overlay

  % celRange 型を，
  % layer 番号 i が， celRange で定まる範囲に入っているかどうかを表す
  % int -> bool 型に変換する．
  let-rec is-in-range : celRange -> int -> bool | cel-range i =
    match cel-range with
    | Always() -> true
    | Only(n) -> (i == n)
    | Before(n) -> (i <= n)
    | After(n) -> (i >= n)
    | Range(m, n) -> (i >= m) && (i <= n)
    | GeneralRange(f) -> (f i)

  % cel-num (cel number) が crange (cel range) に入っているときだけ
  % 具現化され，それ以外は phantom となる block-box.
  let ghost-block crange cel-num bb =
    if is-in-range crange cel-num then bb else phantom-block bb

  % cel-num が crange に入っているときだけ bb-true が使われ，
  % それ以外は bb-false に擬態する block-box.
  let block-switch crange cel-num bb-true bb-false =
    if is-in-range crange cel-num then bb-true else bb-false

  % }}}

  % frame{} function {{{

  let placeholder height (origX, origY) =
    [fill Color.white (Gr.rectangle (origX, origY) (origX, origY +' height))]

  let make-frame-title ctx =

    ctx |> set-font-size font-size-frame-title
        |> set-font Latin (!fonts-frame-title-latin, 1.0, 0.)
        |> set-cjk-font (!fonts-frame-title-cjk, !fonts-font-ratio-cjk, 0.)
        |> set-text-color color-title

  let make-placeholder ctx glue-height =
    let ht = length-max 0pt glue-height in
    let ctx2 = ctx |> set-paragraph-margin 0pt 0pt in
    line-break true false ctx2 (inline-graphics 0pt ht 0pt (placeholder ht) ++ inline-fil)

  let frame-anime max-frame title inner ctx =
    let ctx-title = make-frame-title ctx in
    let title-padding = 12pt in
    let deco (x, y) wid hgt dpt =
      let path1 =
        let xL = x -' text-horizontal-margin +' title-padding in
        let yT = y +' text-vertical-margin in
        let xR = xL +' paper-width -' title-padding *' 2.0 in
        let yB = yT -' 3pt in
        Gr.rectangle (xL, yT) (xR, yB)
      in
      [
        (fill color-title path1);
      ]
    in
    let bb-title cel-num =
      let it-number =
        if max-frame == 1 then {}
        else
          let it-cel-num = embed-string(arabic cel-num) in
          let it-max-frame = embed-string(arabic max-frame) in
          { (#it-cel-num;/#it-max-frame;)}
      in
      let ib-title = read-inline ctx-title {#title;#it-number;} in
      block-frame-breakable
        (ctx |> set-paragraph-margin 0pt 0pt)
          (title-padding -' text-horizontal-margin, title-padding,
          title-padding -' text-vertical-margin, title-padding +' text-vertical-margin)
            (deco, deco, deco, deco)
              (fun ctx ->
                line-break true true (make-frame-title ctx) (ib-title ++ inline-fil)
              )
    in
    let ib-inner cel-num = embed-block-top ctx text-width (fun ctx -> cel-list-to-block-boxes ctx inner cel-num) in
    let bb-inner cel-num = line-break false false ctx (ib-inner cel-num) in

    let-rec content n =
      if n == 0
      then block-nil
      else
      (content (n - 1)) +++
        (clear-page-or-nil is-first-page) +++
        (bb-bg ctx !draft-mode) +++ (bb-title n) +++ (bb-inner n)
    in

    content max-frame

  let frame = frame-anime 1

  let frame-anime-nt max-frame inner ctx =

    let ib-inner cel-num = embed-block-top ctx text-width (fun ctx -> cel-list-to-block-boxes ctx inner cel-num) in
    let bb-inner cel-num = line-break false false ctx (ib-inner cel-num) in

    let-rec content n =
      if n == 0
      then block-nil
      else
      (content (n - 1)) +++
        (clear-page-or-nil is-first-page) +++
        (bb-bg ctx !draft-mode) +++ (bb-inner n)
    in

    content max-frame

  let frame-nt = frame-anime-nt 1

      % }}}

  % 文書構造 {{{

  let p-ghost crange it cel-num ctx =
    ghost-block crange cel-num
      (line-break true true ctx (read-inline ctx it ++ inline-fil))

  let p-switch crange it1 it2 cel-num ctx =
    let ib-paragraph it =
      line-break true true ctx (read-inline ctx it ++ inline-fil)
    in
    block-switch crange cel-num (ib-paragraph it1) (ib-paragraph it2)

  let p = p-ghost (Always())

  % }}}

  % インラインテキスト装飾 {{{

  let-inline ctx \emph it =
    let ctx2 = ctx |> set-text-color color-emph
                   |> set-font Latin (!fonts-frame-title-latin, 1.0, 0.)
                   |> set-cjk-font (!fonts-frame-title-cjk, !fonts-font-ratio-cjk, 0.)
    in
    (read-inline ctx2 it)

  let-inline ctx \text-color clr it =
    let ctx2 = ctx |> set-text-color clr in
    (read-inline ctx2 it)

  let-inline ctx \textbf it =
    let ctx2 = ctx |> set-font Latin (!fonts-frame-title-latin, 1.0, 0.)
                   |> set-cjk-font (!fonts-frame-title-cjk, !fonts-font-ratio-cjk, 0.)
    in
    (read-inline ctx2 it)

  let-inline ctx \link ?:it url =
    let ctx2 = ctx |> set-text-color color-link in
    let ctx-link = match it with
      | None    -> ctx2 |> set-font Latin (!fonts-mono-text-latin, 1.0, 0.)
      | Some(v) -> ctx2
    in
    let text = match it with
      | None    -> (embed-string url)
      | Some(v) -> v
    in
    read-inline ctx-link {\href(url){#text;}}

  let-inline ctx \br =
    discretionary (- 1000) inline-nil inline-fil inline-nil

  % }}}

end


let frame-anime = Slydifi.frame-anime
let frame = Slydifi.frame
let p-ghost = Slydifi.p-ghost
let p-switch = Slydifi.p-switch
let p = Slydifi.p

slydifi-color.satyh

@require: color

module SlydifiColor : sig

  val gray   : float -> color
  val rgb    : float -> float -> float -> color
  val html-color : int   -> color
  val black  : color
  val white  : color
  val red    : color
  val yellow : color
  val orange : color
  val blue   : color

  % val are : color * color -> color
  val rgb-value : color -> (float * float * float)
  val inner-color : color -> color -> float -> color

end = struct

  let gray x = Gray(x)

  let rgb r g b = RGB(r, g, b)

  let html-color rgb =
    let r = rgb / 65536 in
    let g = (rgb - r * 65536) / 256 in
    let b = rgb mod 256 in
    RGB(float r /. 255. , float g /. 255. , float b /. 255.)

  let rgb-value clr =
    match clr with
    | RGB(r, g, b) -> (r, g, b)
    | Gray(z) -> (z, z, z)
    | CMYK(c, m, y, k) -> (0., 0., 0.)

  let inner-color clr1 clr2 r =
    let (r1, g1, b1) = rgb-value clr1 in
    let (r2, g2, b2) = rgb-value clr2 in
    let inner-division f1 f2 r = f1 *. r +. f2 *. (1. -. r) in
    RGB(inner-division r1 r2 r, inner-division g1 g2 r, inner-division b1 b2 r)

  let black  = gray 0.
  let white  = gray 1.
  let red    = rgb 1. 0. 0.
  let yellow = rgb 1. 1. 0.
  let orange = rgb 1. 0.5 0.
  let blue   = rgb 0. 0. 1.
end