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 application = (t -> t * t option)

and t =
  | Consonant of consonant
  | Voyel of voyel
  | Nasal of application
  | App of application
  | Repr of string
  | 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 pair
  : voyel -> consonant -> string
  = fun voyel consonant ->
    match voyel.position with
    | `Above -> voyel.app (fst consonant.position)
    | `Below -> voyel.app (snd consonant.position)

let l =
  let default =
    { position = Pos1, Lower1
    ; 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 v = pair letter c in
        let repr = c.repr ^ v in
        Consonant {c with repr}, Some f
      | Consonant { category = III; _} as f ->
        let Consonant c = gn [@@warning "-8"] in
        let v = pair letter c in
        let repr = c.repr ^ v in
        Consonant {c with repr}, Some f
      | f ->
        let Consonant c = n [@@warning "-8"] in
        let v = pair letter c in
        let repr = c.repr ^ v in
        let default = Consonant { c with repr } in
        default, Some f
    )
let a_nasal = nasal a'
and o_nasal = nasal o'
and i_nasal = nasal i'
and y_nasal = nasal y'

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

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, t2 with
    | Consonant c, Voyel v ->

      Nasal (fun t ->
          match t with
          | Nothing ->
            let repr = c.repr in
            Repr repr, (Some t2)
          | Consonant c2 ->
            let b = Buffer.create 4 in
            Buffer.add_string b c.repr;
            Buffer.add_string b c2.repr;
            let v2 = pair v c2 in
            Buffer.add_string b v2;
            let repr = Buffer.contents b in
            Repr repr, None
          | Repr r ->
            let v_repr = pair v portant in
            Repr(c.repr ^ portant.repr ^ v_repr ^ r), None
          | Voyel _
          | Nasal _
          | App _ ->
            let b = Buffer.create 4 in
            let v = pair v portant in
            Buffer.add_string b c.repr;
            Buffer.add_string b portant.repr;
            Buffer.add_string b v;
            let repr = Buffer.contents b in
            ( Repr repr
            , Some t)
        )

    | Consonant c, Nasal n
    | Consonant c, App n
      ->
      begin match n none with
        | Consonant c2, _ ->
          Repr(c.repr ^ c2.repr)
        | Repr r, _ ->
          Repr(c.repr ^ r)
        | Voyel v, _ ->
          let v_repr = pair v c in
          Repr(c.repr ^ v_repr)
        | Nothing, _
        | Nasal _, _
        | App _, _ ->
          t1
      end
    | _ ->
      print_endline "Ignoring diphtongue";
      none

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 ("`" ^ (pair v portant))
            | Some Voyel ( {position = `Below; _ } as v) ->
              Buffer.add_string buff (v.app Pos1)
            | Some Nasal n
            | Some App n ->
              let result, next = (n Nothing) in
              begin match next with
                | None -> _fold (Some result) []
                | Some v -> _fold (Some result) [v]
              end
            | 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 ^ (pair v c));
            _fold None tl
          | Some Voyel ({position = `Below; _} as v), Consonant c ->
            Buffer.add_string buff ((pair v c) ^ c.repr);
            _fold None tl
          | Some Voyel v, _ ->
            Buffer.add_string buff ("`" ^ (pair v portant));
            _fold (Some hd) tl
          | Some Nasal n, Consonant _
          | Some App n, Consonant _
            ->
            let result, next = n hd in
            begin match next with
              | None -> _fold (Some result) tl
              | Some hd -> _fold (Some result) (hd::tl)
            end
          | Some Nasal n, Voyel v
          | Some App n, Voyel v
            ->
            let result, next = (n hd) in
            begin match next with
              | None -> _fold (Some result) (tl)
              | Some next -> _fold (Some result) (next::tl)
            end
          | Some Nasal n, _
          | Some App n, _ ->
            let result, next = (n (Consonant portant)) in
            begin match next with
              | None -> _fold (Some result) (hd::tl)
              | Some next -> _fold (Some result) (next::hd::tl)
            end
          | 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 _
          | None, App _ ->
            _fold (Some hd) tl

    in
    _fold None elems;
    Buffer.contents buff