bibyfi.satyh

% vim: foldmethod=marker
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%     Original author: T. Suwa (github: gfngfn)                 %
% Original repository: https://github.com/gfngfn/cs-thesis      %
%                                                               %
%              Author: Nakano Masaki<namachan10777@gmail.com>   %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

@require: vdecoset
@require: option

% global types {{{

type bibyfi-article =
  (|
    author       : string list;
    title        : string;
    journal      : string;
    year         : string;
    pages        : (string * string);
    % option
    volume       : string option;
    number       : string option;
    month        : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-book = 
  (|
    author       : string list;
    title        : string;
    publisher    : string;
    year         : string;
    % option
    volume       : string option;
    series       : string option;
    address      : string option;
    edition      : string option;
    month        : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-booklet = 
  (|
    title        : string;
    % option
    author       : (string list) option;
    howpublished : string option;
    address      : string option;
    year         : string option;
    month        : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-incollection = 
  (|
    author       : string list;
    title        : string;
    booktitle    : string;
    year         : string;
    % option
    editor       : (string list) option;
    pages        : (string * string);
    organization : string option;
    publisher    : string option;
    address      : string option;
    month        : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-inproceedings = 
  (|
    author       : string list;
    title        : string;
    booktitle    : string;
    year         : string;
    % option
    editor       : (string list) option;
    pages        : (string * string) option;
    organization : string option;
    publisher    : string option;
    address      : string option;
    month        : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-proceedings = 
  (|
    title        : string;
    year         : string;
    % option
    editor       : (string list) option;
    publisher    : string option;
    organization : string option;
    address      : string option;
    month        : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-manual = 
  (|
    title        : string;
    % option
    author       : (string list) option;
    organization : string option;
    address      : string option;
    edition      : string option;
    month        : string option;
    year         : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-masterthesis = 
  (|
    author       : string list;
    title        : string;
    school       : string;
    year         : string;
    % option
    address      : string option;
    month        : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-phdthesis = 
  (|
    author       : string list;
    title        : string;
    school       : string;
    year         : string;
    % option
    address      : string option;
    month        : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-techreport = 
  (|
    author       : string list;
    title        : string;
    institution  : string;
    year         : string;
    % option
    typeof       : string option;
    number       : string option;
    address      : string option;
    month        : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-misc = 
  (|
    % option
    author       : (string list) option;
    title        : string option;
    howpublished : string option;
    month        : string option;
    year         : string option;
    note         : string option;
    key          : string option;
  |)

type bibyfi-unpublished = 
  (|
    % option
    author       : string list;
    title        : string;
    note         : string;
    %option
    month        : string option;
    year         : string option;
    key          : string option;
  |)

% }}}

type bibyfi-item =
  | Article of bibyfi-article
  | Book of bibyfi-book
  | Booklet of bibyfi-booklet
  | InCollection of bibyfi-incollection
  | InProceedings of bibyfi-inproceedings
  | Manual of bibyfi-manual
  | MasterThesis of bibyfi-masterthesis
  | PhDThesis of bibyfi-phdthesis
  | Misc of bibyfi-misc
  | Proceedings of bibyfi-proceedings
  | TechReport of bibyfi-techreport
  | Unpublished of bibyfi-unpublished
  | WildCard of inline-text

type bibyfi-entry-element = 
  (|
    not-tail : inline-text -> inline-text;
    tail : inline-text -> inline-text;
  |)

type bibyfi-citestyle =
  | CiteAsNumber
  | CiteAsAuthors
  | CiteAsAuthorsEtAl
  | CiteAsAuthorsPlus

type bib-config = (|
  sort-references: bool;
  citestyle: bibyfi-citestyle;
  name-shrink: bool;
|)

module BiByFi: sig
  direct \cite : [string list] inline-cmd
  direct +makebibliography : [bib-config?; context -> int -> bibyfi-item -> block-boxes; (string * bibyfi-item) list] block-cmd
  direct \BiByFi : [] inline-cmd

  val shrink-name : string -> string

  val join-authors : inline-text -> inline-text -> inline-text -> inline-text list -> inline-text
  val make-entry : context -> inline-boxes -> inline-boxes -> block-boxes
  val join-elements : inline-text -> inline-text -> inline-text -> (bibyfi-entry-element option) list -> inline-text
  val lift-elem : inline-text -> bibyfi-entry-element option
  val map-elem : inline-text option -> bibyfi-entry-element option
  val custom-sep : inline-text -> inline-text -> bibyfi-entry-element option -> bibyfi-entry-element option
end = struct
  let bib-left-padding = 20pt

  % internal functions {{{

  let-rec merge xs ys = match (xs, ys) with
    | (x :: xs, y :: ys) ->
      if x < y
      then x :: y :: merge xs ys
      else y :: x :: merge xs ys
    | (_ :: _, []) -> xs
    | ([], _ :: _) -> ys
    | ([], []) -> []

  let-rec split l = match l with
    | x :: y :: l -> (
      let (xs, ys) = split l in
      (x :: xs, y :: ys))
    | x :: [] ->
      ([x], [])
    | [] ->
      ([], [])

  let-rec sort l =
    match l with
    | [] -> []
    | [x] -> [x]
    | [x;y] -> if x < y then [x;y] else [y;x]
    | _ -> 
      let (xs, ys) = split l in
      let xs = sort xs in
      let ys = sort ys in
      merge xs ys

  let int-of-string s =
    let digit-of-string s = match s with
      | `0` -> Some(0)
      | `1` -> Some(1)
      | `2` -> Some(2)
      | `3` -> Some(3)
      | `4` -> Some(4)
      | `5` -> Some(5)
      | `6` -> Some(6)
      | `7` -> Some(7)
      | `8` -> Some(8)
      | `9` -> Some(9)
      | _   -> None
    in
    let-rec f exp s =
      let l = string-length s in
      match l with
      | 0 -> None
      | 1 -> 
        (Option.map (fun d -> exp * d) (digit-of-string (string-sub s (l - 1) 1)))
      | _ ->
        Option.bind
          (f (exp * 10) (string-sub s 0 (l - 1)))
          (fun n -> Option.map (fun d -> n + exp * d) (digit-of-string (string-sub s (l - 1) 1)))
    in
    f 1 s

  % }}}

  let shrinkable codepoint =
       (codepoint >= 97 && codepoint <= 122)
    || (codepoint >= 65 && codepoint <= 90)

  % helpers for style file {{{
  let-rec shrink-name name =
  let splitter = regexp-of-string `[ ]+` in
  let splited = split-on-regexp splitter name in
  let shrink n = 
    let exploded = string-explode n in
    let initial = (match exploded with
      | i :: _ -> (if shrinkable i
        then Some(string-unexplode [i])
        else None)
      | _ -> None)
    in
      match initial with
      | Some(initial) -> initial ^ `. `#
      | None -> n ^ #` `#
  in
  let-rec f name = match name with
    | [] -> ` `
    | [(_, n)] -> n
    | (_, n) :: last -> (shrink n) ^ f last
  in
    f splited


  let join-authors sep-for-double sep sep-last authors =
    match List.reverse authors with
    | []                    -> {}
    | it :: []              -> it
    | it2 :: it1 :: []      -> {#it1;#sep-for-double;#it2;}
    | it-last :: it-rest ->
      let its = it-rest
        |> List.reverse
        |> List.fold-left (fun acc it -> {#acc;#it;#sep;}) {}
      in
        {#its;#sep-last;#it-last;}

  let make-entry ctx ib-num ib-main =
    let ib =
      inline-skip (0pt -' get-natural-width ib-num)
        ++ ib-num ++ ib-main ++ inline-fil
    in
    let pads = (20pt, 0pt, 0pt, 0pt) in
    block-frame-breakable ctx pads VDecoSet.empty (fun ctx -> line-break true true ctx ib)

  let lift-elem e = Some
  (|
    not-tail = fun sep     -> {#e;#sep;};
    tail     = fun periodo -> {#e;#periodo;};
  |)

  let map-elem e = Option.map (fun e ->
  (|
    not-tail = fun sep     -> {#e;#sep;};
    tail     = fun periodo -> {#e;#periodo;};
  |)) e

  let custom-sep sep periodo e = Option.map (fun e ->
    (|
      not-tail = fun _ -> e#not-tail sep;
      tail     = fun _ -> e#tail     periodo;
    |)) e

  let-rec shrink l = match l with
    | [] -> []
    | (None) :: tail -> shrink tail
    | (Some(x)) :: tail -> x :: shrink tail

  let join-elements sep periodo space elements =
    match elements |> shrink |> List.reverse with
    | [] -> {}
    | [elem] ->
      elem#tail periodo
    | elem-last :: elements ->
      let it-body = List.fold-left (fun acc elem -> (
        let it-elem = elem#not-tail sep in
          {#it-elem;#space;#acc;})) {} elements
      in
        let tail = elem-last#tail periodo in
        {#it-body;#tail;}
  % }}}

  % implementations {{{
  let-mutable cite-logs <- []

  let-inline ctx \BiByFi =
    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 ib = 
      f {BiB} ++ kern (size *' 0.05) ++ fd{Y} ++ f{F} ++ kern(size *' 0.05) ++ fd{I}
    in
    script-guard Latin (no-break ib)

  let join-references-smartly =
    List.fold-left-adjacent (fun acc ref-n ref-n-prev ref-n-next -> (
      match (ref-n-prev, ref-n-next) with
      | (_, None) -> acc ^ arabic ref-n
      | (None, Some(n-next)) ->
        if n-next == ref-n + 1
        then (arabic ref-n) ^ `–`
        else (arabic ref-n) ^ `, `#
      | (Some(n-prev), Some(n-next)) ->
        if n-next == ref-n + 1 && n-prev + 1 == ref-n
        % nothing to do because `–` was printed
        then acc
        else (
          if n-next == ref-n + 1
          % 1, 3-4
          then acc ^ (arabic ref-n) ^ `–`
          % 1, 3
          else acc ^ (arabic ref-n) ^ `, `#
        )
      )) ` `

  let-inline ctx \cite labels =
    let sacc =
      labels
      |> List.fold-left (fun (numbers, fullcites) label -> (
        let () = cite-logs <- (
          if List.fold-left (fun acc cited -> (string-same cited label) || acc) false !cite-logs
          then !cite-logs
          else label :: !cite-logs
        )
        in
        match get-cross-reference (`__bibyfi:` ^ label) with
          | None -> (numbers, `unresolved` :: fullcites)
          | Some(l) -> (match (int-of-string l) with
            | Some(i) -> (i :: numbers, fullcites)
            | None -> (numbers, l :: fullcites))
        ))
        ([], [])
      |> (fun (numbers, fullcites) -> (
        let numebers-str =
          match numbers with
          | [] -> ` `
          | _ -> (numbers |> sort |> join-references-smartly)
        in
        let fullcites-str =
          let-rec join cites = match cites with
            | [] -> ` `
            | c :: [] -> c
            | c :: last -> c ^ `, `# ^ join last
          in
            join fullcites
        in
          numebers-str ^ fullcites-str))
    in
      inline-skip 2pt ++ read-inline ctx (embed-string (`[` ^ sacc ^ `]`))

  let-rec sort-same f src refs =
    let pick label lst = lst |> List.filter (fun l -> f l label) |> List.nth 0 in
    match refs with
    | [] -> []
    | label1 :: tl -> (match pick label1 src with
      | Some (l) -> l :: sort-same f src tl
      | None -> sort-same f src tl)

  let default-config = (|
    sort-references = true;
    citestyle = CiteAsNumber;
    name-shrink = true;
  |)

  let authors-of-item i style name-shrink item =
    let f author year = match (author, year) with
      | (Some author, Some year) -> Some (author, year)
      | _ -> None
    in
    let authors = match item with
      | Article(r) -> f (Some r#author) (Some r#year)
      | Book(r) -> f (Some r#author) (Some r#year)
      | Booklet(r) -> f r#author r#year
      | InCollection(r) -> f (Some r#author) (Some r#year)
      | InProceedings(r) -> f (Some r#author) (Some r#year)
      | Manual(r) -> f r#author r#year
      | MasterThesis(r) -> f (Some r#author) (Some r#year)
      | PhDThesis(r) -> f (Some r#author) (Some r#year)
      | Misc(r) -> f r#author r#year
      | Proceedings(r) -> None
      | TechReport(r) -> f (Some r#author) (Some r#year)
      | Unpublished(r) -> f (Some r#author) r#year
      | WildCard(r) -> None
    in
    (match style with
     | CiteAsNumber -> None
     | _ -> (
      authors
      |> Option.map (fun (authors, year) -> (
        let authors = List.map shrink-name authors |> List.reverse in
        match authors with
        | [] -> ` `
        | n1 :: [] -> n1
        | n1 :: n2 :: [] -> (
          match style with
          | CiteAsAuthorsPlus -> n1 ^ `+`
          | _ -> n1 ^ #` and `# ^ n2)
        | n1 :: ns -> (
          match style with
          | CiteAsAuthors -> (
            match List.reverse authors with
            | nlast :: ns ->
              (List.fold-left (^) `, `# ns) ^ #` and `# ^ nlast
            | _ -> ` `)
          | CiteAsAuthorsEtAl ->
            n1 ^ #` et al.`
          | CiteAsAuthorsPlus ->
            n1 ^ `+`
          | CiteAsNumber -> ` `
        )) ^ #` `# ^ year)))
    |> Option.from (arabic (i + 1))

  let-block ctx +makebibliography ?:cfg theme bibs =
      let cfg = Option.from default-config cfg in
      let bibs =
        let sorted =
          sort-same (fun (cited, _) label -> string-same label cited) bibs !cite-logs
          |> List.reverse
        in
        if cfg#sort-references then sorted else bibs
      in
      let () =
        bibs |> List.iteri (fun i (label, item) -> (
          register-cross-reference (`__bibyfi:` ^ label) (authors-of-item i cfg#citestyle cfg#name-shrink item)
        ))
      in
        bibs |> List.fold-lefti (fun i bbacc (_, bibitem) -> (
          bbacc +++ theme ctx  (i + 1) bibitem
        )) block-nil
  % }}}
end