1 files changed, 426 insertions, 0 deletions
diff --git a/slydifi/my-theme.satyh b/slydifi/my-theme.satyh
new file mode 100644
index 0000000..32ddb57
--- /dev/null
+++ b/slydifi/my-theme.satyh
@@ -0,0 +1,426 @@
+%% 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