path: root/src/lib/repr/rousseau.ml

type position_type =
  [ `Above
  | `Below ]

(** Consonant category *)
type category =
  | I
  | II
  | III

type 'a voyel =
  { position : position_type
  ; app : ('a -> string) }

type 'a consonant =
  { position : 'a
  ; muted: string option
  ; repr : string
  ; primary : bool
  ; category : category }

type 'a glyph =
  { tengwa : 'a consonant option
  (* The eventual Tehta above the tengwa *)
  ; tehta_above : 'a voyel option
  (* And below *)
  ; tehta_below : 'a voyel option
  }

let empty_glyph =
  { tengwa = None
  ; tehta_above = None
  ; tehta_below = None }

let pair
  : 'a voyel -> 'a consonant -> string
  = fun voyel consonant ->
    voyel.app consonant.position

let repr_glyph
  : portant:'a consonant -> 'a glyph -> Buffer.t -> unit
  = fun ~portant { tengwa; tehta_above; tehta_below } b ->
    let () =  match tengwa with
      | None -> Buffer.add_string b @@ portant.repr
      | Some c ->Buffer.add_string b @@ c.repr in
    let () = match tehta_above, tengwa with
      | None, _ -> ()
      | Some v, Some c ->  Buffer.add_string b @@ pair v c
      | Some v, None ->    Buffer.add_string b @@ pair v portant in
    let () = match tehta_below, tengwa with
      | None, _ -> ()
      | Some v, Some c ->  Buffer.add_string b @@ pair v c
      | Some v, None ->    Buffer.add_string b @@ pair v portant in
    ()

let combine_glyph
  : 'a glyph -> 'a glyph -> 'a glyph option
  = fun g1 g2 ->
    let tengwa = match g1.tengwa, g2.tengwa with
      | Some _, Some _ -> Error ()
      | None, any -> Ok (any)
      | any, None -> Ok (any) in
    let above = match g1.tehta_above, g2.tehta_above with
      | Some _, Some _ -> Error ()
      | None, any -> Ok any
      | any, None -> Ok any in
    let below = match g1.tehta_below, g2.tehta_below with
      | Some _, Some _ -> Error ()
      | None, any -> Ok any
      | any, None -> Ok any in
    (* Combine only if everything is ok *)
    match tengwa, above, below with
    | Ok tengwa, Ok tehta_above, Ok tehta_below ->
      Some { tengwa; tehta_above; tehta_below}
    | _, _, _ -> None

let add_voyel_to_glyph
  : 'a glyph -> 'a voyel -> 'a glyph
  = fun g v ->
    match v.position with
    | `Above -> { g with tehta_above = Some v }
    | `Below -> { g with tehta_below = Some v }

type 'a t =
  | Consonant: 'a consonant -> 'a t
  | Voyel: 'a voyel -> 'a t
  | Application: ('a t -> 'a t list) -> 'a t
  | Repr of string
  | Glyph: 'a glyph -> 'a t
  | Nothing

let voyel
  : position_type -> ('a -> string) -> 'a t
  = fun position app ->
    Voyel { position ; app }

let none = Nothing

let space s = Repr s

let nasal m ng n letter =
  Application
    ( function
      | Consonant { category = II; _} as f ->
        let Consonant c = m [@@warning "-8"] in
        let g = Glyph
            {empty_glyph with
             tengwa = Some c
           ; tehta_above = Some letter } in
        g::f::[]
      | Consonant { category = III; _} as f ->
        let Consonant c = ng [@@warning "-8"] in
        let g = Glyph
            {empty_glyph with
             tengwa = Some c
           ; tehta_above = Some letter } in
        g::f::[]

      | f ->
        let Consonant c = n [@@warning "-8"] in
        let g = Glyph
            {empty_glyph with
             tengwa = Some c
           ; tehta_above = Some letter } in
        g::f::[] )

let diphtongue
  : 'a t -> 'a t -> 'a t
  = fun t1 t2 ->
    match t1 with

    | Consonant c->
      let semi_voyel =
        Glyph
          { empty_glyph with tengwa = Some c} in
      Application (fun t -> semi_voyel::t2::t::[])
    | _ ->
      print_endline "Ignoring diphtongue";
      Nothing

let fold
  : portant:'a consonant -> 'a t list -> string
  = fun ~portant elems ->
    let buff = Buffer.create 16 in

    let rec _fold
      : 'a glyph option -> 'a t list -> unit
      = fun init -> function
        | [] ->
          begin match init with
            | None -> ()
            | Some glyph -> repr_glyph ~portant glyph buff
          end
        | hd::tl ->
          match init, hd with
          | any, Nothing -> _fold any tl
          | None, Consonant c ->
            _fold
              (Some {empty_glyph with tengwa = Some c})
              tl
          | None, Voyel v ->
            _fold
              (Some (
                  add_voyel_to_glyph
                    {empty_glyph with tehta_above = Some v}
                    v) )
              tl
          | None, Repr r ->
            Buffer.add_string buff r;
            _fold
              None tl
          | any, Application n ->
            let next, rest = match tl with
              | [] -> Nothing, []
              | other::ll -> other, ll in
            let result = n next in
            _fold any (result @ rest)

          | Some t, Repr s ->
            repr_glyph ~portant t buff;
            Buffer.add_string buff s;
            _fold
              None
              tl
          | Some ({ tengwa = Some _ ; _} as t), Consonant c ->
            repr_glyph ~portant t buff;
            _fold
              (Some {empty_glyph with tengwa = Some c})
              tl
          | Some ({ tehta_below = None ; _} as t), Voyel ({position = `Below; _} as v) ->
            _fold
              (Some {t with tehta_below = Some v})
              tl
          | Some ({ tehta_below = Some _ ; _} as t), Voyel ({position = `Below; _} as v) ->
            repr_glyph ~portant t buff;
            _fold
              (Some {empty_glyph with tehta_below = Some v})
              tl
          | Some ({ tehta_below = Some _ ; _} as t), Consonant c ->
            repr_glyph ~portant t buff;
            _fold
              (Some {empty_glyph with tengwa = Some c})
              tl
          | Some t, Voyel ({position = `Above; _} as v) ->
            repr_glyph ~portant t buff;
            _fold
              (Some {empty_glyph with tehta_above = Some v})
              tl
          | Some ({ tengwa = None ; _} as t), Consonant c ->
            _fold
              (Some {t with tengwa = Some c})
              tl
          | None, Glyph g ->
            _fold
              (Some g)
              tl
          | Some g1, Glyph g2 ->
            begin match combine_glyph g1 g2 with
              | Some _ as res ->
                _fold
                  res
                  tl
              | None ->
                repr_glyph ~portant g1 buff;
                _fold
                  (Some g2)
                  tl
            end
    in
    _fold None elems;
    Buffer.contents buff

let p repr muted position = Consonant
    { position
    ; muted
    ; category = II
    ; primary = true
    ; repr }

and b repr muted position = Consonant
    { position
    ; muted
    ; category = II
    ; primary = true
    ; repr }

and t repr muted position = Consonant
    { position
    ; muted
    ; category = I
    ; primary = true
    ; repr }

and d repr muted position = Consonant
    { position
    ; muted
    ; category = I
    ; primary = true
    ; repr }

and k repr muted position = Consonant
    { position
    ; muted
    ; category = III
    ; primary = true
    ; repr }

and g repr muted position = Consonant
    { position
    ; muted
    ; category = III
    ; primary = true
    ; repr }

and f repr position = Consonant
    { position
    ; muted = None
    ; category = II
    ; primary = true
    ; repr }

and v repr position = Consonant
    { position
    ; muted = None
    ; category = II
    ; primary = true
    ; repr }

and ch repr position = Consonant
    { position
    ; muted = None
    ; category = III
    ; primary = true
    ; repr }

and j repr position = Consonant
    { position
    ; muted = None
    ; category = III
    ; primary = true
    ; repr }

and s repr muted position = Consonant
    { position
    ; muted
    ; category = I
    ; primary = true
    ; repr }

and z repr position = Consonant
    { position
    ; muted = None
    ; category = I
    ; primary = true
    ; repr }

and m repr position = Consonant
    { position
    ; muted = None
    ; category = II
    ; primary = true
    ; repr }

and n repr position = Consonant
    { position
    ; muted = None
    ; category = I
    ; primary = true
    ; repr }

and gn repr position = Consonant
    { position
    ; muted = None
    ; category = III
    ; primary = false
    ; repr }

and ng repr position = Consonant
    { position
    ; muted = None
    ; category = III
    ; primary = true
    ; repr }

and r repr muted position = Consonant
    { position
    ; muted
    ; category = I
    ; primary = false
    ; repr }

and semi_voyel_w repr position = Consonant
    { position
    ; muted = None
    ; category = II
    ; primary = false
    ; repr }

and semi_voyel_y repr position = Consonant
    { position
    ; muted = None
    ; category = II
    ; primary = false
    ; repr }

and semi_voyel_u repr position = Consonant
    { position
    ; muted = None
    ; category = II
    ; primary = false
    ; repr }

let l repr position =
  let default =
    { position
    ; muted = None
    ; category = II
    ; primary = false
    ; repr } in
  Consonant default

let portant repr position =
  { position
  ; muted = None
  ; category = I
  ; primary = false
  ; repr }