path: root/slydifi/my-theme.satyh

%% my-theme.satyh
%%
%% SLyDIFi theme file.

@require: gr
@require: annot
@require: base/color-ext
@require: base/int
@require: class-slydifi/slydifi
@require: class-slydifi/footnote
@require: enumitem/enumitem

type my-theme-config = (|
  font-normal : context -> context;
  font-bold : context -> context;
  font-code : context -> context;
  font-slide-title : context -> context;
  font-slide-author : context -> context;
  font-slide-date : context -> context;
  font-section-title : context -> context;
  font-frame-title : context -> context;
  font-pagenum : context -> context;
  font-footnote : context -> context;

  color-bg : color;
  color-fg : color;
  color-emph : color;
  color-link : color;
  color-title : color;
  color-separator : color;
  color-section-ribbon : color;
  color-section-ribbon-intersect : color;

  length-frame-title-height : length;
  length-frame-title-left-margin : length;
  length-frame-title-bot-margin : length;
  length-frame-body-top-margin : length;
|)


module SlydifiMyTheme: sig

  val layout: frame-layout
  val document: block-text -> document

% config
  val config: my-theme-config SlydifiParam.t
  val default-config: my-theme-config
  direct +set-config : [my-theme-config] block-cmd
  direct \set-config : [my-theme-config] inline-cmd
  direct +with-config : [my-theme-config; block-text] block-cmd
  direct \with-config : [my-theme-config; inline-text] inline-cmd

% frames
  %% スライドマスター。
  val frame-master: my-theme-config -> unit Frame.frame
  %% ページ番号の付いたスライドマスター。
  val frame-master-with-footer: my-theme-config -> unit Frame.frame
  %% スライド全体のタイトルフレーム。
  %% title: スライドのタイトル
  %% title: スライドのタイトル
  val frame-slide-title: my-theme-config ->
    ((| title: inline-text list; author: inline-text list; date: inline-text list|))
      Frame.frame
  %% セクションフレーム。
  % val frame-section-title: layout-slydifi-theme ((| title: inline-text list; |)) Frame.frame
  %% タイトルフレーム。
  val frame-normal: my-theme-config -> ((| title: inline-text; inner: block-text |)) Frame.frame

% frame commands
  %% frame-slide-title に従ってタイトルスライドを生成する。
  direct +make-title : [(| title: inline-text list; author: inline-text list; date: inline-text list|);] block-cmd
  %% frame-normal に従って通常のスライドを生成する。
  direct +section : [inline-text list; block-text;] block-cmd
  direct +frame : [int?; inline-text; block-text;] block-cmd

% inline commands
  direct \emph : [(int -> bool)?; inline-text] inline-cmd
  direct \link : [inline-text?; string] inline-cmd
  direct \code : [string] inline-cmd

% listing
  direct +oitem : [(int -> bool); inline-text; block-text] block-cmd

% 脚注
  direct \footnote : [inline-text] inline-cmd
  direct \footnotetext : [string; inline-text] inline-cmd
  direct \footnotemark : [string] inline-cmd

end = struct

  let page-num = SlydifiParam.make 0

  let layout = (|
    paper-width = 254mm;
    paper-height = 142.9mm;
    text-width = 254mm -' 40pt;
    text-height = 142.9mm -' 20pt;
    text-horizontal-margin = 20pt;
    text-vertical-margin = 10pt;
  |)
  let xrel xfloat = layout#paper-width *' xfloat
  let yrel yfloat = layout#paper-height *' yfloat
  let rel xfloat yfloat = (xrel xfloat, yrel yfloat)

% configuration
  let default-config =
    let set-font-metrics fsize ctx =
      ctx |> set-font-size fsize
          |> set-paragraph-margin (fsize *' 0.6) (fsize *' 0.6)
          |> set-leading (fsize *' 1.4)
    in
    let default-font ctx =
      ctx |> set-font Latin          (`fonts-noto-sans:NotoSans-Regular`, 1.0, 0.0)
          |> set-font Kana           (`fonts-noto-sans-cjk-jp:NotoSansCJKjp-Regular`, 1.0, 0.0)
          |> set-font HanIdeographic (`fonts-noto-sans-cjk-jp:NotoSansCJKjp-Regular`, 1.0, 0.0)
    in
    let code-font ctx =
      ctx |> set-font Latin          (`lmmono`, 1.0, 0.0)
          |> set-font Kana           (`lmmono`, 1.0, 0.0)
          |> set-font HanIdeographic (`lmmono`, 1.0, 0.0)
    in
    let bold-font ctx =
      ctx |> set-font Latin          (`fonts-noto-sans:NotoSans-Bold`, 1.0, 0.0)
          |> set-font Kana           (`fonts-noto-sans-cjk-jp:NotoSansCJKjp-Bold`, 1.0, 0.0)
          |> set-font HanIdeographic (`fonts-noto-sans-cjk-jp:NotoSansCJKjp-Bold`, 1.0, 0.0)
    in

    (|
      font-normal = SlydifiScheme.apply-font-cfg [default-font; set-font-metrics 30pt];
      font-bold = SlydifiScheme.apply-font-cfg [bold-font];
      font-code = SlydifiScheme.apply-font-cfg [code-font];
      font-slide-title = SlydifiScheme.apply-font-cfg [bold-font; set-font-metrics 36pt];
      font-slide-author = SlydifiScheme.apply-font-cfg [default-font; set-font-metrics 24pt;];
      font-slide-date = SlydifiScheme.apply-font-cfg [default-font; set-font-metrics 20pt;];
      font-section-title = SlydifiScheme.apply-font-cfg [bold-font; set-font-metrics 28pt];
      font-frame-title = SlydifiScheme.apply-font-cfg [bold-font; set-font-metrics 28pt];
      font-pagenum = SlydifiScheme.apply-font-cfg [default-font; set-font-metrics 12pt;];
      font-footnote = SlydifiScheme.apply-font-cfg [default-font; set-font-metrics 12pt;];

      color-bg = Color.of-css `#ffffff`;
      color-fg = Color.of-css `#000000`;
      color-emph = Color.of-css `#000000`;
      color-link = Color.of-css `#2d539e`;
      color-title = Color.of-css `#000000`;
      color-separator = Color.of-css `#000000`;
      color-section-ribbon = Color.of-css `#000000`;
      color-section-ribbon-intersect = Color.of-css `#000000`;

      length-frame-title-height = 0pt;
      length-frame-title-left-margin = 10pt;
      length-frame-title-bot-margin = 10pt;
      length-frame-body-top-margin = 14pt;
    |)

  let config = SlydifiParam.make default-config

  let-block +set-config cfg = '< +SlydifiParam.set-param(config)(cfg); >
  let-inline \set-config cfg = { \SlydifiParam.set-param(config)(cfg); }
  let-block +with-config cfg bt = '< +SlydifiParam.with-param(config)(cfg)(bt); >
  let-inline \with-config cfg it = { \SlydifiParam.with-param(config)(cfg)(it); }

  let-inline ctx \code code =
    let config = SlydifiParam.get config in
    let ctx =
      ctx |> config#font-code
          |> set-text-color config#color-fg
    in
    let fsize = get-font-size ctx in

    script-guard Latin (read-inline ctx (embed-string code))

  let document bt =
    let config = SlydifiParam.get config in
    let hookf _ _ =
      let numpages = SlydifiParam.get page-num in
      register-cross-reference `pagecount` (arabic numpages)
    in
    let init-ctx ctx =
      ctx |> config#font-normal
          |> set-text-color config#color-fg
          |> set-code-text-command (command \code)
    in
    SlydifiScheme.document-scheme layout init-ctx hookf bt

% frames

  let frame-master config =
    let f ctx () =
      (block-nil, [
        Gr.rectangle (0pt, 0pt) (layout#paper-width, layout#paper-height)
          |> fill config#color-bg
      ])
    in
    Frame.make layout f

  let frame-master-with-footer config =
    let f ctx () =
      % frame-master の graphics list を踏襲する
      let (_, gr-frame-master) = frame-master config |> Frame.embed ctx () in

      let pagenum = SlydifiParam.get page-num in
      let total = get-cross-reference `pagecount` |> Option.from `1` in

      let gr-page-number =
        let it-pagenum = pagenum |> arabic |> embed-string in
        let it-total = embed-string total in
        let ctx-pagenum = config#font-pagenum ctx in
        let ib = read-inline ctx-pagenum {#it-pagenum;/#it-total;} in
        let pos = (xrel 1.0 -' 10pt, 12pt) in
        SlydifiGraphics.put-text (1., 0.) pos ib
      in

      (block-nil, [gr-frame-master; gr-page-number; ] |> List.concat)
    in
    Frame.make layout f

  let frame-slide-title config =
    let f ctx content =
      % frame-master の graphics list を踏襲する
      let (_, gr-frame-master) = frame-master config |> Frame.embed ctx () in

      let title-mgn = 24pt in

      let gr-bgs = [
        Gr.rectangle (0pt, yrel 0.45) (xrel 1.0, yrel 1.0) |> fill config#color-title;
      ]
      in

      let gr-title =
        let ctx = ctx |> config#font-slide-title |> set-text-color config#color-bg in
        let iblst = content#title |> List.map (read-inline ctx) in
        let pos = (xrel 0.5, yrel 0.45 +' title-mgn) in
        SlydifiGraphics.put-texts
          (| align = (0.5, 0.0); text-align = 0.5; leading = (get-font-size ctx *' 1.6) |)
            pos iblst
      in

      let gr-author =
        let ctx = ctx |> config#font-slide-author |> set-text-color config#color-fg in
        let iblst = content#author |> List.map (read-inline ctx) in
        let pos = (xrel 0.5, yrel 0.45 -' title-mgn) in
        SlydifiGraphics.put-texts
          (| align = (0.5, 1.0); text-align = 0.5; leading = (get-font-size ctx *' 1.6) |)
            pos iblst
      in

      let gr-date =
        let ctx = ctx |> config#font-slide-date |> set-text-color config#color-fg in
        let iblst = content#date |> List.map (read-inline ctx) in
        let pos = (xrel 0.5, yrel 0.2) in
        SlydifiGraphics.put-texts
          (| align = (0.5, 1.0); text-align = 0.5; leading = (get-font-size ctx *' 1.6) |)
            pos iblst
      in

      (block-nil, [gr-frame-master; gr-bgs; gr-title; gr-author; gr-date] |> List.concat)
    in
    Frame.make layout f

  let frame-section-title config =
    let f ctx content =
      % frame-master の graphics list を踏襲する
      let (_, gr-frame-master) = frame-master config |> Frame.embed ctx () in

      % 設定
      let title-mgn = 24pt in
      let ribbon-width = 5pt in
      let hribbon-t = yrel 0.45 in
      let hribbon-b = yrel 0.45 -' ribbon-width in
      let vribbon-r = xrel 0.1 in
      let vribbon-l = xrel 0.1 -' ribbon-width in

      % タイトルのグラフィックス
      let gr-bgs =
        let north-rect = Gr.rectangle (vribbon-l, hribbon-t) (vribbon-r, yrel 1.00) in
        let south-rect = Gr.rectangle (vribbon-l, hribbon-b) (vribbon-r, yrel 0.00) in
        let east-rect  = Gr.rectangle (vribbon-r, hribbon-b) (xrel 1.00, hribbon-t) in
        let west-rect  = Gr.rectangle (vribbon-l, hribbon-b) (xrel 0.00, hribbon-t) in
        let cent-rect  = Gr.rectangle (vribbon-l, hribbon-b) (vribbon-r, hribbon-t) in

        [
          fill config#color-section-ribbon north-rect;
          fill config#color-section-ribbon south-rect;
          fill config#color-section-ribbon east-rect;
          fill config#color-section-ribbon west-rect;
          fill config#color-section-ribbon-intersect cent-rect;
        ]
      in

      let gr-titles =
        let ctx = ctx |> config#font-section-title |> set-text-color config#color-fg in
        let iblst = content#title |> List.map (read-inline ctx) in
        let pos = (xrel 0.1 +' title-mgn, yrel 0.45 +' title-mgn) in
        SlydifiGraphics.put-texts
          (| align = (0.0, 0.0); text-align = 0.0; leading = (get-font-size ctx *' 1.6) |)
            pos iblst
      in

      (block-nil, [gr-frame-master; gr-bgs; gr-titles] |> List.concat)
    in
    Frame.make layout f

  let frame-normal config =
    let f ctx content =
      % frame-master-with-footer の graphics list を踏襲する
      let (_, gr) = frame-master-with-footer config |> Frame.embed ctx () in

      % 中身のブロックボックス列
      let bb-inner =
        let ctx = ctx |> config#font-normal in
        let bb-blank skip =
          line-break false false (ctx |> set-paragraph-margin 0pt skip) inline-fil
        in
        bb-blank (config#length-frame-title-height +' config#length-frame-body-top-margin)
          +++ (read-block ctx content#inner)
      in


      (bb-inner, [gr] |> List.concat)

    in
    Frame.make layout f

% frame commands

  let-block ctx +make-title content =
    read-block ctx '<
      +SlydifiScheme.genframe(frame-slide-title (SlydifiParam.get config))(1)(content);
    >

  let-block ctx +section title inner =
    read-block ctx '<
      +SlydifiScheme.genframe(frame-section-title (SlydifiParam.get config))(1)(|title = title;|);
      #inner;
    >

  let-block ctx +frame ?:n-frame title inner =
    let () = page-num |> SlydifiParam.set (SlydifiParam.get page-num + 1) in
    let n-frame = n-frame |> Option.from 1 in
    read-block ctx '<
      +SlydifiScheme.genframe(frame-normal (SlydifiParam.get config))(n-frame)(|title = title; inner = inner|);
    >

% listing
  let-block +oitem dcf it bt =
    '< +ghost(dcf)< +item(it)(bt); > >

% inline commands
  let-inline ctx \emph ?:dcf it =
    let config = SlydifiParam.get config in
    let dcf = Option.from (fun _ -> true) dcf in
    let ctx2 =
      SlydifiOverlay.select-from-two dcf (
        ctx |> config#font-bold
            |> set-text-color config#color-emph
      ) ctx
    in
    read-inline ctx2 it

  let-inline ctx \link ?:text url =
    let config = SlydifiParam.get config in
    match text with
    | Some(text) ->
        let ctx =
          ctx |> set-text-color config#color-link
        in
        read-inline ctx {\href(url)(text);}
    | None ->
        let text = embed-string url in
        let ctx =
          ctx
            |> config#font-code
            |> set-text-color config#color-link
        in
        read-inline ctx {\href(url)(text);}

% \footnote{} command

  let-inline ctx \footnotetext ref-label it =
    let config = SlydifiParam.get config in
    let bbf num =
      let it-num = embed-string (arabic num) in
      let ctx = config#font-footnote ctx in
        line-break false false ctx (read-inline ctx {#it-num; #it;} ++ inline-fil)
    in
      FootnoteScheme.main ctx (Some(ref-label)) (fun _ -> inline-nil) bbf

  let-inline ctx \footnotemark ref-label =
    let size = get-font-size ctx in
    let ctx =
      ctx |> set-font-size (size *' 0.75)
          |> set-manual-rising (size *' 0.25)
    in
    let ctx =
      ctx |> set-font-size (size *' 0.75)
          |> set-manual-rising (size *' 0.25)
    in
    match FootnoteScheme.get-footnote-num ref-label with
    | Some(n) ->
      let it-num = embed-string n in
      read-inline ctx {\*#it-num;}
    | _ ->
      read-inline ctx {\*?}

  let-inline ctx \footnote it =
    let config = SlydifiParam.get config in
    let size = get-font-size ctx in
    let ibf num =
      let it-num = embed-string (arabic num) in
      let ctx =
        ctx |> set-font-size (size *' 0.75)
            |> set-manual-rising (size *' 0.25)
      in
        read-inline ctx {\*#it-num;}
    in
    let bbf num =
      let it-num = embed-string (arabic num) in
      let ctx = config#font-footnote ctx in
        line-break false false ctx (read-inline ctx {#it-num; #it;} ++ inline-fil)
    in
      FootnoteScheme.main ctx None ibf bbf

end

let document = SlydifiMyTheme.document