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

type position_type =
  [ `Above
  | `Below ]

(** Glyph position for the diacritc *)
type position =
  | Pos1
  | Pos2
  | Pos3
  | Pos4
  | Lower1
  | Lower2

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

type voyel =
  { opened : bool
  ; position : position_type
  ; app : (position -> string) }

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


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

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

let pair
  : voyel -> consonant -> string
  = fun voyel consonant ->
    match voyel.position with
    | `Above -> voyel.app (fst consonant.position)
    | `Below -> voyel.app (snd consonant.position)

let portant =
  { position = Pos4, Lower1
  ; muted = None
  ; category = I
  ; primary = false
  ; repr = "`" }

let repr_glyph
  : glyph -> Buffer.t -> unit
  = fun { 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
  : glyph -> glyph -> 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
    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
  : glyph -> voyel -> glyph
  = fun g v ->
    match v.position with
    | `Above -> { g with tehta_above = Some v }
    | `Below -> { g with tehta_below = Some v }

type application = (t -> t list)

and t =
  | Consonant of consonant
  | Voyel of voyel
  | Nasal of application
  | Repr of string
  | Glyph of glyph
  | Nothing

let none = Nothing

let space s = Repr s

let a' =
  { opened = true
  ; position = `Above
  ; app = function
      | Pos1 -> "#"
      | Pos2 -> "E"
      | Pos3 -> "D"
      | Pos4 -> "C"
      | Lower1 -> ""
      | Lower2 -> ""
  }
let a = Voyel a'

let app_e = function
  | Pos1 -> "$"
  | Pos2 -> "R"
  | Pos3 -> "F"
  | Pos4 -> "V"
  | Lower1 -> ""
  | Lower2 -> ""

and app_eu = function
  | Pos1 -> "Ü"
  | Pos2 -> "Ý"
  | Pos3 -> "Þ"
  | Pos4 -> "ß"
  | Lower1 -> ""
  | Lower2 -> ""

let e_opened =
  Voyel { opened = true ; position = `Above ; app = app_e }
and e_closed =
  Voyel { opened = false; position = `Above ; app = app_e }

and schwa = Voyel
    { opened = true
    ; position = `Below
    ; app = function
        | Pos1 -> "È"
        | Pos2 -> "É"
        | Pos3 -> "Ê"
        | Pos4 -> "Ë"
        | Lower1 -> "Ë"
        | Lower2 -> "L"
    }

and eu_opened = Voyel { opened = true  ; position = `Above ; app = app_eu }
and eu_closed = Voyel { opened = false ; position = `Above ; app = app_eu }

and o' =
  { opened = true
  ; position = `Above
  ; app = function
      | Pos1 -> "^"
      | Pos2 -> "Y"
      | Pos3 -> "H"
      | Pos4 -> "N"
      | Lower1 -> ""
      | Lower2 -> ""
  }

let o = Voyel o'

and i' =
  { opened = true
  ; position = `Above
  ; app = function
      | Pos1 -> "%"
      | Pos2 -> "T"
      | Pos3 -> "G"
      | Pos4 -> "B"
      | Lower1 -> ""
      | Lower2 -> ""
  }

let i = Voyel i'

and y' =
  { opened = true
  ; position = `Above
  ; app = function
      | Pos1 -> "Ø"
      | Pos2 -> "Ù"
      | Pos3 -> "Ú"
      | Pos4 -> "Û"
      | Lower1 -> ""
      | Lower2 -> ""
  }

let y = Voyel y'

and u = Voyel
    { opened = true
    ; position = `Above
    ; app = function
        | Pos1 -> "&"
        | Pos2 -> "U"
        | Pos3 -> "J"
        | Pos4 -> "M"
        | Lower1 -> ""
        | Lower2 -> ""
    }

and p = Consonant
    { position = Pos2, Lower1
    ; muted = Some "y"
    ; category = II
    ; primary = true
    ; repr = "q" }

and b = Consonant
    { position = Pos1, Lower1
    ; muted = Some "y"
    ; category = II
    ; primary = true
    ; repr = "w" }

and t = Consonant
    { position = Pos2, Lower1
    ; muted = Some "6"
    ; category = I
    ; primary = true
    ; repr = "1" }

and d = Consonant
    { position = Pos1, Lower1
    ; muted = Some "6"
    ; category = I
    ; primary = true
    ; repr = "2" }

and k = Consonant
    { position = Pos3, Lower1
    ; muted = Some "h"
    ; category = III
    ; primary = true
    ; repr = "a" }

and g = Consonant
    { position = Pos1, Lower1
    ; muted = Some "h"
    ; category = III
    ; primary = true
    ; repr = "s" }

and f = Consonant
    { position = Pos3, Lower1
    ; muted = None
    ; category = II
    ; primary = true
    ; repr = "e" }

and v = Consonant
    { position = Pos1, Lower1
    ; muted = None
    ; category = II
    ; primary = true
    ; repr = "r" }

and ch = Consonant
    { position = Pos1, Lower1
    ; muted = None
    ; category = III
    ; primary = true
    ; repr = "d" }

and j = Consonant
    { position = Pos1, Lower1
    ; muted = None
    ; category = III
    ; primary = true
    ; repr = "f" }

and s = Consonant
    { position = Pos4, Lower1
    ; muted = Some "i"
    ; category = I
    ; primary = true
    ; repr = "3" }

and z = Consonant
    { position = Pos1, Lower1
    ; muted = None
    ; category = I
    ; primary = true
    ; repr = "4" }

and m = Consonant
    { position = Pos1, Lower1
    ; muted = None
    ; category = II
    ; primary = true
    ; repr = "t" }

and n = Consonant
    { position = Pos1, Lower1
    ; muted = None
    ; category = I
    ; primary = true
    ; repr = "5" }

and gn = Consonant
    { position = Pos1, Lower1
    ; muted = None
    ; category = III
    ; primary = false
    ; repr = "b" }

and r = Consonant
    { position = Pos2, Lower1
    ; muted = Some "u"
    ; category = I
    ; primary = false
    ; repr = "7" }

and semi_voyel_w = Consonant
    { position = Pos3, Lower1
    ; muted = None
    ; category = II
    ; primary = false
    ; repr = "." }

and semi_voyel_y = Consonant
    { position = Pos1, Lower1
    ; muted = None
    ; category = II
    ; primary = false
    ; repr = "l" }

and semi_voyel_u = Consonant
    { position = Pos2, Lower1
    ; muted = None
    ; category = II
    ; primary = false
    ; repr = "]" }

let l =
  let default =
    { position = Pos1, Lower2
    ; muted = None
    ; category = II
    ; primary = false
    ; repr = "j" } in
  Consonant default

let nasal letter =
  Nasal
    ( 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 = gn [@@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 a_nasal = nasal a'
and o_nasal = nasal o'
and i_nasal = nasal i'
and y_nasal = nasal y'

let muted
  : t -> t
  = fun t ->
    match t with
    | Consonant c ->
      begin match c.muted with
        | None -> t
        | Some s -> Consonant {c with repr = s}
      end
    | _ -> t


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

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

let fold
  : t list -> string
  = fun elems ->
    let buff = Buffer.create 16 in

    let rec _fold
      : glyph option -> t list -> unit
      = fun init -> function
        | [] ->
          begin match init with
            | None -> ()
            | Some glyph ->
              repr_glyph 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 ({position = `Above; _} as v) ->
            _fold
              (Some {empty_glyph with tehta_above = Some v})
              tl
          | None, Voyel ({position = `Below; _} as v) ->
            _fold
              (Some {empty_glyph with tehta_below = Some v})
              tl
          | None, Repr r ->
            Buffer.add_string buff r;
            _fold
              None tl
          | any, Nasal 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 t buff;
            Buffer.add_string buff s;
            _fold
              None
              tl
          | Some ({ tengwa = Some _ ; _} as t), Consonant c ->
            repr_glyph t buff;
            _fold
              (Some {empty_glyph with tengwa = Some c})
              tl
          | Some ({ tehta_below = Some _ ; _} as t), Voyel ({position = `Below; _} as v) ->
            repr_glyph t buff;
            _fold
              (Some {empty_glyph with tehta_below = Some v})
              tl
          | Some t, Voyel ({position = `Above; _} as v) ->
            repr_glyph t buff;
            _fold
              (Some {empty_glyph with tehta_above = Some v})
              tl
          | Some t, Voyel v ->
            _fold
              (Some (add_voyel_to_glyph t 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 g1 buff;
                _fold
                  (Some g2)
                  tl
            end


    in
    _fold None elems;
    Buffer.contents buff