module Macro = struct
  type t =
    { name        : string
    ; params      : int
    ; defn        : ContrlSeq.t
    }

  let macro_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_macro n d = Hashtbl.add macro_tbl n d
  let get_macro n = Hashtbl.find_opt macro_tbl n
  let remove_macro n = Hashtbl.remove macro_tbl n
end

module Dimen = struct
  type t =
    | DIMEN_Absolute of absolute
    | DIMEN_Relative of relative
    | DIMEN_Special of special
  and absolute =
    | ABSDIM_Point of float
    | ABSDIM_Pica of float
    | ABSDIM_Inch of float
    | ABSDIM_BigPoint of float
    | ABSDIM_Centimeter of float
    | ABSDIM_Millimiter of float
    | ABSDIM_DidoPoint of float
    | ABSDIM_Cicero of float
    | ABSDIM_ScaledPoint of float
  and relative =
    | RELDIM_Em of float
    | RELDIM_Ex of float
    | RELDIM_Mu of float
  and special =
    | SPECDIM_Fil of float
    | SPECDIM_Fill of float
    | SPECDIM_Filll of float

  let dimens_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_dimen n d = Hashtbl.add dimens_tbl n d
  let get_dimen n = Hashtbl.find_opt dimens_tbl n
  let remove_dimen n = Hashtbl.remove dimens_tbl n

  let point = 1.0
  let pica = 12.0
  let inch = 72.27
  let bigpoint = 1.003
  let centimeter = 180.67
  let millimeter = 18.6
  let didotpoint = 1238
  let cicreo = 12.8
  let scaledpoint = 0.000015

  let em = 2.0
  let ex = 0.5
  let mu = 0.0555
end

module Character = struct
  type t =
    { value         : char
    ; category      : category
    }
  and category =
    | CAT_Escape
    | CAT_GroupStart
    | CAT_GroupEnd
    | CAT_MathShift
    | CAT_AlignmentTab
    | CAT_EndOfLine
    | CAT_ParameterChar
    | CAT_SuperscriptMark
    | CAT_SubscriptMark
    | CAT_Ignored
    | CAT_BlankSpace
    | CAT_Letter
    | CAT_OtherChars
    | CAT_ActiveChar
    | CAT_Comment
    | CAT_InvalidChar

  let chars_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_chars n d = Hashtbl.add charss_tbl n d
  let get_chars n = Hashtbl.find_opt charss_tbl n
  let remove_chars n = Hashtbl.remove charss_tbl n

  let category_numbers = [| CAT_Escape
                          ; CAT_GroupStart
                          ; CAT_GroupEnd
                          ; CAT_MathShift
                          ; CAT_EndOfLine
                          ; CAT_ParameterChar
                          ; CAT_SuperscriptMark
                          ; CAT_SubscriptMark
                          ; CAT_Ignored
                          ; CAT_BlankSpace
                          ; CAT_Letter
                          ; CAT_OtherChars
                          ; CAT_ActiveChar
                          ; CAT_Comment
                          ; CAT_InvalidChar
                         |]
  let get_category_num cat =
    match Shrdlutil.find_element_index_opt cat category_numbers with
    | Some n -> n
    | None -> failwith No_such_category

  exception No_such_category

  let eqv_tab = [| ref [ $PFX$ ]
                 ; ref [ $GPS$ ]
                 ; ref [ $GPE$ ]
                 ; ref [ $SHF$ ]
                 ; ref [ $NLN$ ]
                 ; ref [ $PAR$ ]
                 ; ref [ $SUP$ ]
                 ; ref [ $SUB$ ]
                 ; ref [ $IGN$ ]
                 ; ref [ $WHS$ ]
                 ; ref [ $LET$ ]
                 ; ref [ $OTH$ ]
                 ; ref [ $ACT$ ]
                 ; ref [ $COM$ ]
                 ; ref [ $INV$ ]
                |]
  let insert_eqv cat ch =
    let cat_num = get_category_num cat in
    eqv_tab.[cat_num] := !eqv_tab.[cat_num] @ [ch]
end

module Glue = struct
  type t =
    { width         : Dimen.t
    ; stretch       : Dimen.t
    ; shink         : Dimen.t
    }

  let glues_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_glue n d = Hashtbl.add glues_tbl n d
  let get_glue n = Hashtbl.find_opt glues_tbl n
  let remove_glue n = Hashtbl.remove glues_tbl n
end

module Insert = struct
  type t =
    { box_ref       : Box.ref
    ; space         : Dimen.ref
    ; glue          : Glue.ref
    ; height        : Count.ref
    }

  let inserts_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_insert n d = Hashtbl.add inserts_tbl n d
  let get_insert n = Hashtbl.find_opt inserts_tbl n
  let remove_insert n = Hashtbl.remove inserts_tbl n
end

module Mark = struct
  type t =
    | MARK_First of string
    | MARK_Bottom of string
    | MARK_Top of string

  let marks_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_mark n d = Hashtbl.add marks_tbl n d
  let get_mark n = Hashtbl.find_opt marks_tbl n
  let remove_mark n = Hashtbl.remove marks_tbl n
end

module Adjust = struct
  type t =
    { material      : string
    ; destination   : Box.ref
    }

  let adjusts_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_adjust n d = Hashtbl.add adjusts_tbl n d
  let get_adjust n = Hashtbl.find_opt adjusts_tbl n
  let remove_adjust n = Hashtbl.remove adjusts_tbl n
end

module Ligature = struct
  type t =
    { value         : Character.t list
    ; typeface      : Typeface.t
    }

  let ligature_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_ligature n d = Hashtbl.add ligatures_tbl n d
  let get_ligature n = Hashtbl.find_opt ligatures_tbl n
  let remove_ligature n = Hashtbl.remove ligatures_tbl n
end

module Kern = struct
  type t =
    { explicit      : bool
    ; accent        : bool
    ; value         : float
    ; parent        : Box.ref
    }

  let kern_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_kern n d = Hashtbl.add kerns_tbl n d
  let get_kern n = Hashtbl.find_opt kerns_tbl n
  let remove_kern n = Hashtbl.remove kerns_tbl n
end

module Penalty = struct
  type t =
    | PENALTY_Force of float
    | PENALTY_Decide of float
    | PENALTY_Ignore of float

  let penalty_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_penalty n d = Hashtbl.add penaltys_tbl n d
  let get_penalty n = Hashtbl.find_opt penaltys_tbl n
  let remove_penalty n = Hashtbl.remove penaltys_tbl n
end

module Discretionary = struct
  type t =
    { prebreak      : string
    ; postbreak     : string
    ; nobreak       : string
    }

  let disc_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_disc n d = Hashtbl.add discs_tbl n d
  let get_disc n = Hashtbl.find_opt discs_tbl n
  let remove_disc n = Hashtbl.remove discs_tbl n
end

module Color = struct
  type t =
    { fill          : colorspace
    ; stroke        : colorspace
    }
  and colorspace =
    | COLOR_RGB of (float * float * float)
    | COLOR_Hex of string
    | COLOR_RGBA of (float * float * float * float)
    | COLOR_CMYK of (float * float * float * float * float)

  let color_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_color n d = Hashtbl.add colors_tbl n d
  let get_color n = Hashtbl.find_opt colors_tbl n
  let remove_color n = Hashtbl.remove colors_tbl n
end

module Curve = struct
  type t =
    { points        : point list
    ; kind          : curve_kind
    }
  and curve_kind =
    | CURVE_Bezier
    | CURVE_Spline
    | CURVE_Line
    | CURVE_Arc
  and point = (Dimen.t * Dimen.t)

  let curve_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_curve n d = Hashtbl.add curves_tbl n d
  let get_curve n = Hashtbl.find_opt curves_tbl n
  let remove_curve n = Hashtbl.remove curves_tbl n
end

module Math = struct
  type t =
    { elements      : math_elt list
    ; is_display    : bool
    }
  and math_elt =
    { subelements   : math_subelt list
    ; supers        : math_subelt option
    ; subs          : math_subelt option
    }
  and math_subelt =
    | MATH_Ord of string
    | MATH_Op of string
    | MATH_Bin of string
    | MATH_Rel of string
    | MATH_Open of string
    | MATH_Close of string
    | MATH_Punct of string
    | MATH_Inner of string

  let math_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_math n d = Hashtbl.add maths_tbl n d
  let get_math n = Hashtbl.find_opt maths_tbl n
  let remove_math n = Hashtbl.remove maths_tbl n

  let math_subelt_list: math_subelt Array.t = [||]
end

module Box = struct
  type t =
    { contents      : contents list
    ; vertical      : bool
    ; glue          : Glue.t
    ; demerits      : Demerits.t
    }
  and contents =
    { height        : Dimen.t
    ; width         : Dimen.t
    ; depth         : Dimen.t
    ; vshift        : Dimen.t
    ; hshift        : Dimen.t
    ; box           : box_node list
    }
  and box_node =
    | NODE_Character of Character.t
    | NODE_Math of Math.t
    | NODE_Penalty of Penalty.t
    | NODE_Mark of Mark.t
    | NODE_Discretionary of Discretionary.t
    | NODE_Color of Color.t
    | NODE_Adjust of Adjust.t
    | NODE_Ligature of Ligature.t
    | NODE_Kern of Kern.t
    | NODE_Insert of Insert.t

  let box_tbl: (string, t) Hashtbl.t = Hashtbl.create 21
  let add_box n d = Hashtbl.add boxs_tbl n d
  let get_box n = Hashtbl.find_opt boxs_tbl n
  let remove_box n = Hashtbl.remove boxs_tbl n
end

module Demerits = struct
  type t =
    { badness       : Badness.score
    ; penalty       : Penalty.score
    ; hyphenation   : Hyphenetion.score
    ; discretionary : Discretionary.score
    ; adjust        : Adjust.score
    }
end

module Hyphenation = struct
  type t =
    | HYPH_Pattern
    | HYPH_Intredit

  let hyph_mode = $HYHP_DEFAULT$

                  let intredit_tbl = ref [  $HYPH_INTREDIT$   ]
  let word_is_intredit word =
    List.mem word !intredit_tbl
  let mark_word_intredit word =
    intredit_tbl := !intredt_tbl :: word
  let mark_word_not_intredit word =
    if (word_is_intredit word) = false
    then Runtime.error "Word " ^ word ^ " is not in exception list"
    else intredit_tbl := List.filter (fun word' -> word != word') !intredit_tbl
end

module Trie = struct
  type t =
         | Leaf of 'a
         | Node of (char * 'a trie) list

  let rec insert trie key value =
    match key with
    | [] -> Leaf value
    | h :: t ->
        match trie with
        | Leaf _ -> failwith "Cannot insert into leaf node"
        | Node children ->
           let insert_child (ch, subtree) =
            if ch = h then
                (ch, insert t value subtree)
            else
                (ch, subtree)
           in
           let new_children =
             match List.assoc_op children with
             | Some subtree -> List.map insert_child children
             | None -> (c, insert t value (Node [])) :: children
           in
           Node new_children

  let rec search trie key =
    match key with
    | [] ->
       match trie with
       | Leaf v -> Some v
       | Node _ -> None
    | h :: t ->
      match trie with
      | Leaf _ -> None
      | Node children ->
         let rec find_child = function
          | [] -> None
          | (ch, subtree) :: t ->
                if ch = c then search t subtree
                else find_child t
         in
         find_child children


end

module Typeface = struct
  type t = None (* TODO *)
end

module Shrdlutil = struct
  let find_element_index_opt element arr =
    let indexed_array = Array.mapi (fun i -> (i, x)) arr in
    try
      let (_, index) = Array.find (fun (_, x) -> x = element) indexed_array;
        Some index
    with Not_found -> None
end