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

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

type voyel =
  { opened : bool
  ; position : [`Above | `Below ]
  ; app : (position -> string) }

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


type nasal = (t -> string)

and t =
  | Consonant of consonant
  | Voyel of voyel
  | Nasal of nasal
  | Repr of string
  | Nothing

let none = Nothing

let space s = Repr s

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

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

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

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 -> "Ë" }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

and r = Consonant
    { position = Pos2
    ; muted = None
    ; category = I
    ; primary = false
    ; repr = "7" }

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

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

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

let nasal v =
  let Voyel letter = v [@@warning "-8"]in
  Nasal
    ( fun f ->
        let Consonant c = n [@@warning "-8"] in
        let default = c.repr ^ letter.app c.position in

        match f with
        | Consonant c -> begin match c.category with
            | I -> default
            | II ->
              let Consonant c = m [@@warning "-8"] in
              c.repr ^ letter.app c.position
            | III ->
              let Consonant c = gn [@@warning "-8"] in
              c.repr ^ letter.app c.position
          end
        | _ -> default
    )

let a_nasal = nasal a
and o_nasal = nasal o
and i_nasal = nasal i
and y_nasal = nasal y


let diphtongue
  : t -> t -> t
  = fun t1 t2 -> match t1, t2 with
    (*
    | Consonant _, Voyel _ when t1 = semi_voyel_y && t2 = schwa ->
      Consonant
        { position = Pos1
        ; muted = None
        ; category = II
        ; primary = false
        ; repr = "m"}
        *)
    | Consonant c, Voyel v ->
      Repr(c.repr ^ (v.app c.position))
    | Consonant c, Nasal n ->
      Repr(c.repr ^ (n none))
    | _ ->
      print_endline "Ignoring diphtongue";
      none

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


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

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

    let rec _fold
      = fun init -> function
        | [] ->
          begin match init with
            | None
            | Some Nothing
              -> ()
            | Some Voyel ( {position = `Above; _ } as v) ->
              Buffer.add_string buff ("`" ^ (v.app portant.position))
            | Some Voyel ( {position = `Below; _ } as v) ->
              Buffer.add_string buff (v.app Pos1)
            | Some Nasal n ->
              Buffer.add_string buff (n (Consonant portant))
            | Some Repr r ->
              Buffer.add_string buff r
            | Some Consonant c ->
              Buffer.add_string buff (c.repr)
          end
        | hd::tl ->
          match init, hd with
          | Some Nothing, _ -> _fold (Some hd) tl
          | _, Nothing      -> _fold init tl
          | Some Voyel ({position = `Above; _} as v), Consonant c ->
            Buffer.add_string buff (c.repr ^ (v.app c.position));
            _fold None tl
          | Some Voyel ({position = `Below; _} as v), Consonant c ->
            Buffer.add_string buff ((v.app Pos1)^ c.repr);
            _fold None tl
          | Some Nasal n, Consonant c ->
            Buffer.add_string buff ((n hd) ^ c.repr);
            _fold None tl
          | Some Voyel v, _ ->
            Buffer.add_string buff ("`" ^ (v.app portant.position));
            _fold (Some hd) tl
          | Some Nasal n, _ ->
            Buffer.add_string buff (n (Consonant portant));
            _fold (Some hd) tl
          | Some Repr r, _ ->
            Buffer.add_string buff r;
            _fold (Some hd) tl
          | Some Consonant c, _ ->
            Buffer.add_string buff c.repr;
            _fold (Some hd) tl

          | None, Consonant c ->
            Buffer.add_string buff c.repr;
            _fold None tl
          | None, Repr r ->
            Buffer.add_string buff r;
            _fold None tl
          | None, Voyel _
          | None, Nasal _ -> _fold (Some hd) tl

    in
    _fold None elems;
    Buffer.contents buff