open Swf

(* DATA *)

type header = {
    hd_major_version : int;
    hd_minor_version : int;
    hd_num_tables : int;
    hd_search_range : int;
    hd_entry_selector : int;
    hd_range_shift : int;
}

type entry = {
    entry_table_name : string;
    entry_checksum : int32;
    entry_offset : int32;
    entry_length: int32;
}

(* GLYF *)

type glyf_header = {
    gh_num_contours : int;
    gh_xmin : int;
    gh_ymin : int;
    gh_xmax : int;
    gh_ymax : int;
}

type glyf_simple = {
    gs_end_pts_of_contours : int array;
    gs_instruction_length : int;
    gs_instructions : char array;
    gs_flags : int array;
    gs_x_coordinates : int array;
    gs_y_coordinates : int array;
}

type transformation_option =
    | Scale of float
    | ScaleXY of float * float
    | ScaleMatrix of float * float * float * float

type glyf_component = {
    gc_flags : int;
    gc_glyf_index : int;
    gc_arg1 : int;
    gc_arg2 : int;
    gc_transformations : transformation_option list;
}

type glyf_def =
    | TglyfSimple of glyf_simple
    | TglyfComposite of glyf_component list

type glyf = {
    glyf_header : glyf_header;
    glyf_def : glyf_def;
}

(* HMTX *)

type hmtx = {
    advance_width : int;
    left_side_bearing : int;
}

(* CMAP *)

type cmap_subtable_header = {
    csh_platform_id : int;
    csh_platform_specific_id : int;
    csh_offset : int32;
}

type cmap_format_0 = {
    c0_format : int;
    c0_length : int;
    c0_language : int;
    c0_glyph_index_array : char array;
}

type cmap_format_4 = {
    c4_format : int;
    c4_length : int;
    c4_language : int;
    c4_seg_count_x2 : int;
    c4_search_range : int;
    c4_entry_selector : int;
    c4_range_shift : int;
    c4_end_code : int array;
    c4_reserved_pad : int;
    c4_start_code : int array;
    c4_id_delta : int array;
    c4_id_range_offset : int array;
    c4_glyph_index_array : int array;
}

type cmap_format_6 = {
    c6_format : int;
    c6_length : int;
    c6_language : int;
    c6_first_code : int;
    c6_entry_count : int;
    c6_glyph_index_array : int array;
}

type cmap_subtable_def =
    | Cmap0 of cmap_format_0
    | Cmap4 of cmap_format_4
    | Cmap6 of cmap_format_6
    | CmapUnk of string

type cmap_subtable = {
    cs_header : cmap_subtable_header;
    cs_def : cmap_subtable_def;
}

type cmap = {
    cmap_version : int;
    cmap_num_subtables : int;
    cmap_subtables : cmap_subtable list;
}

(* KERN *)

type kern_subtable_header = {
    ksh_length : int32;
    ksh_coverage : int;
    ksh_tuple_index : int;
}

type kern_pair = {
    left : int;
    right : int;
    value : int;
}

type kern_format_0 = {
    k0_num_pairs : int;
    k0_search_range : int;
    k0_entry_selector : int;
    k0_range_shift : int;
    k0_pairs : kern_pair list;
}

type kern_format_2 = {
    k2_row_width : int;
    k2_left_offset_table : int;
    k2_right_offset_table : int;
    k2_array : int;
    k2_first_glyph : int;
    k2_num_glyphs : int;
    k2_offsets : int list;
}

type kern_subtable_def =
    | Kern0 of kern_format_0
    | Kern2 of kern_format_2

type kern_subtable = {
    ks_header : kern_subtable_header;
    ks_def : kern_subtable_def;
}

type kern = {
    kern_version : int32;
    kern_num_tables : int32;
    kern_subtables : kern_subtable list;
}

(* NAME *)

type name_record = {
    nr_platform_id : int;
    nr_platform_specific_id : int;
    nr_language_id : int;
    nr_name_id : int;
    nr_length : int;
    nr_offset : int;
    mutable nr_value : string;
}

type name = {
    name_format : int;
    name_num_records : int;
    name_offset : int;
    name_records : name_record array;
}

(* HEAD *)

type head = {
    hd_version : int32;
    hd_font_revision : int32;
    hd_checksum_adjustment : int32;
    hd_magic_number : int32;
    hd_flags : int;
    hd_units_per_em : int;
    hd_created : float;
    hd_modified : float;
    hd_xmin : int;
    hd_ymin : int;
    hd_xmax : int;
    hd_ymax : int;
    hd_mac_style : int;
    hd_lowest_rec_ppem : int;
    hd_font_direction_hint : int;
    hd_index_to_loc_format : int;
    hd_glyph_data_format : int;
}

(* HHEA *)

type hhea = {
    hhea_version : int32;
    hhea_ascent : int;
    hhea_descent : int;
    hhea_line_gap : int;
    hhea_advance_width_max : int;
    hhea_min_left_side_bearing : int;
    hhea_min_right_side_bearing : int;
    hhea_x_max_extent : int;
    hhea_caret_slope_rise : int;
    hhea_caret_slope_run : int;
    hhea_caret_offset : int;
    hhea_reserved : string;
    hhea_metric_data_format : int;
    hhea_number_of_hmetrics :int;
}

(* LOCA *)

type loca = int32 array

(* MAXP *)

type maxp = {
    maxp_version_number : int32;
    maxp_num_glyphs : int;
    maxp_max_points : int;
    maxp_max_contours : int;
    maxp_max_component_points : int;
    maxp_max_component_contours : int;
    maxp_max_zones : int;
    maxp_max_twilight_points : int;
    maxp_max_storage : int;
    maxp_max_function_defs : int;
    maxp_max_instruction_defs :int;
    maxp_max_stack_elements : int;
    maxp_max_size_of_instructions :int;
    maxp_max_component_elements :int;
    maxp_max_component_depth :int;
}

(* OS2 *)

type os2 = {
    os2_version : int;
    os2_x_avg_char_width : int;
    os2_us_weight_class : int;
    os2_us_width_class : int;
    os2_fs_type : int;
    os2_y_subscript_x_size : int;
    os2_y_subscript_y_size : int;
    os2_y_subscript_x_offset : int;
    os2_y_subscript_y_offset : int;
    os2_y_superscript_x_size : int;
    os2_y_superscript_y_size : int;
    os2_y_superscript_x_offset : int;
    os2_y_superscript_y_offset : int;
    os2_y_strikeout_size : int;
    os2_y_strikeout_position : int;
    os2_s_family_class : int;
    os2_b_family_type : int;
    os2_b_serif_style : int;
    os2_b_weight : int;
    os2_b_proportion : int;
    os2_b_contrast : int;
    os2_b_stroke_variation : int;
    os2_b_arm_style : int;
    os2_b_letterform : int;
    os2_b_midline : int;
    os2_b_x_height : int;
    os2_ul_unicode_range_1 : int32;
    os2_ul_unicode_range_2 : int32;
    os2_ul_unicode_range_3 : int32;
    os2_ul_unicode_range_4 : int32;
    os2_ach_vendor_id : int32;
    os2_fs_selection : int;
    os2_us_first_char_index : int;
    os2_us_last_char_index : int;
    os2_s_typo_ascender : int;
    os2_s_typo_descender : int;
    os2_us_win_ascent : int;
    os2_us_win_descent : int;
}

type table =
    | TGlyf of glyf array
    | THmtx of hmtx list
    | TCmap of cmap
    | TKern of kern
    | TName of name
    | THead of head
    | THhea of hhea
    | TLoca of loca
    | TMaxp of maxp
    | TOS2 of os2
    | TUnk of string

type ttf = {
    ttf_header : header;
    ttf_name : string;
    ttf_directory: (string,entry) Hashtbl.t;
    ttf_tables : (string * table) list;
}

type ctx = {
    file : in_channel;
    ch : IO.input;
    mutable entry : entry;
}

let rd16 = IO.BigEndian.read_i16
let rdu16 = IO.BigEndian.read_ui16
let rd32 = IO.BigEndian.read_i32
let rd32r = IO.BigEndian.read_real_i32
let rdd = IO.BigEndian.read_double
let rbti ch = int_of_char (IO.read ch)
let ti32 = Int32.of_int
let ti = Int32.to_int

(* PARSING *)

let parse_header ctx =
    let ch = ctx.ch in
    let major_version = rdu16 ch in
    let minor_version = rdu16 ch in
    let num_tables = rdu16 ch in
    let search_range = rdu16 ch in
    let entry_selector = rdu16 ch in
    let range_shift = rdu16 ch in
    {
        hd_major_version = major_version;
        hd_minor_version = minor_version;
        hd_num_tables = num_tables;
        hd_search_range = search_range;
        hd_entry_selector = entry_selector;
        hd_range_shift = range_shift;
    }

let parse_directory ctx header =
    let ch = ctx.ch in
    let directory = Hashtbl.create 0 in
    for i = 0 to header.hd_num_tables - 1 do
        let name = IO.nread ch 4 in
        let cs = rd32r ch in
        let off = rd32r ch in
        let length = rd32r ch in
        Hashtbl.add directory name {
            entry_table_name = name;
            entry_checksum = cs;
            entry_offset = off;
            entry_length = length;
        }
    done;
    directory

let parse_head_table ctx =
    let ch = ctx.ch in
    let version = rd32r ch in
    let font_revision = rd32r ch in
    let checksum_adjustment = rd32r ch in
    let magic_number = rd32r ch in
    let flags = rdu16 ch in
    let units_per_em = rdu16 ch in
    let created = rdd ch in
    let modified = rdd ch in
    let xmin = rd16 ch in
    let ymin = rd16 ch in
    let xmax = rd16 ch in
    let ymax = rd16 ch in
    let mac_style = rdu16 ch in
    let lowest_rec_ppem = rdu16 ch in
    let font_direction_hint = rd16 ch in
    let index_to_loc_format = rd16 ch in
    let glyph_data_format = rd16 ch in
    {
        hd_version = version;
        hd_font_revision = font_revision;
        hd_checksum_adjustment = checksum_adjustment;
        hd_magic_number = magic_number;
        hd_flags = flags;
        hd_units_per_em = units_per_em;
        hd_created = created;
        hd_modified = modified;
        hd_xmin = xmin;
        hd_ymin = ymin;
        hd_xmax = xmax;
        hd_ymax = ymax;
        hd_mac_style = mac_style;
        hd_lowest_rec_ppem = lowest_rec_ppem;
        hd_font_direction_hint = font_direction_hint;
        hd_index_to_loc_format = index_to_loc_format;
        hd_glyph_data_format = glyph_data_format;
    }

let parse_hhea_table ctx =
    let ch = ctx.ch in
    let version = rd32r ch in
    let ascender = rd16 ch in
    let descender = rd16 ch in
    let line_gap = rd16 ch in
    let advance_width_max = rdu16 ch in
    let min_left_side_bearing = rd16 ch in
    let min_right_side_bearing = rd16 ch in
    let x_max_extent = rd16 ch in
    let caret_slope_rise = rd16 ch in
    let caret_slope_run = rd16 ch in
    let caret_offset = rd16 ch in
    let reserved = IO.nread ch 8 in
    let metric_data_format = rd16 ch in
    let number_of_hmetrics = rdu16 ch in
    {
        hhea_version = version;
        hhea_ascent = ascender;
        hhea_descent = descender;
        hhea_line_gap = line_gap;
        hhea_advance_width_max = advance_width_max;
        hhea_min_left_side_bearing = min_left_side_bearing;
        hhea_min_right_side_bearing = min_right_side_bearing;
        hhea_x_max_extent = x_max_extent;
        hhea_caret_slope_rise = caret_slope_rise;
        hhea_caret_slope_run = caret_slope_run;
        hhea_caret_offset = caret_offset;
        hhea_reserved = reserved;
        hhea_metric_data_format = metric_data_format;
        hhea_number_of_hmetrics = number_of_hmetrics;
    }

let parse_maxp_table ctx =
    let ch = ctx.ch in
    let version_number = rd32r ch in
    let num_glyphs = rdu16 ch in
    let max_points = rdu16 ch in
    let max_contours = rdu16 ch in
    let max_component_points = rdu16 ch in
    let max_component_contours = rdu16 ch in
    let max_zones = rdu16 ch in
    let max_twilight_points = rdu16 ch in
    let max_storage = rdu16 ch in
    let max_function_defs = rdu16 ch in
    let max_instruction_defs = rdu16 ch in
    let max_stack_elements = rdu16 ch in
    let max_size_of_instructions = rdu16 ch in
    let max_component_elements = rdu16 ch in
    let max_component_depth = rdu16 ch in
    {
        maxp_version_number = version_number;
        maxp_num_glyphs = num_glyphs;
        maxp_max_points = max_points;
        maxp_max_contours = max_contours;
        maxp_max_component_points = max_component_points;
        maxp_max_component_contours = max_component_contours;
        maxp_max_zones = max_zones;
        maxp_max_twilight_points = max_twilight_points;
        maxp_max_storage = max_storage;
        maxp_max_function_defs = max_function_defs;
        maxp_max_instruction_defs = max_instruction_defs;
        maxp_max_stack_elements = max_stack_elements;
        maxp_max_size_of_instructions = max_size_of_instructions;
        maxp_max_component_elements = max_component_elements;
        maxp_max_component_depth = max_component_depth;
    }

let parse_loca_table head maxp ctx =
    let ch = ctx.ch in
    if head.hd_index_to_loc_format = 0 then
        Array.init (maxp.maxp_num_glyphs + 1) (fun _ -> ti32 ((rdu16 ch) * 2))
    else
        Array.init (maxp.maxp_num_glyphs + 1) (fun _ -> rd32r ch)

let parse_hmtx_table maxp hhea ctx =
    let ch = ctx.ch in
    let last_advance_width = ref 0 in
    ExtList.List.init maxp.maxp_num_glyphs (fun i ->
        let advance_width = if i > hhea.hhea_number_of_hmetrics then
            !last_advance_width
        else
            rdu16 ch
        in
        last_advance_width := advance_width;
        let left_side_bearing = rd16 ch in
        {
            advance_width = advance_width;
            left_side_bearing = left_side_bearing;
        }
    )

let parse_cmap_table ctx =
    let ch = ctx.ch in
    let version = rdu16 ch in
    let num_subtables = rdu16 ch in
    let dir = ExtList.List.init num_subtables (fun _ ->
        let platform_id = rdu16 ch in
        let platform_specific_id = rdu16 ch in
        let offset = rd32r ch in
        {
            csh_platform_id = platform_id;
            csh_platform_specific_id = platform_specific_id;
            csh_offset = offset;
        }
    ) in
    let parse_sub entry =
        seek_in ctx.file ((ti ctx.entry.entry_offset) + (ti entry.csh_offset));
        let format = rdu16 ch in
        let length = rdu16 ch in
        let language = rdu16 ch in
        let def = match format with
            | 0 ->
                let glyph_index = Array.init 256 (fun _ -> IO.read ch) in
                Cmap0 {
                    c0_format = 0;
                    c0_length = length;
                    c0_language = language;
                    c0_glyph_index_array = glyph_index;
                }
            | 4 ->
                let seg_count_x2 = rdu16 ch in
                let seg_count = seg_count_x2 / 2 in
                let search_range = rdu16 ch in
                let entry_selector = rdu16 ch in
                let range_shift = rdu16 ch in
                let end_code = Array.init seg_count (fun _ -> rdu16 ch) in
                let reserved = rdu16 ch in
                assert (reserved = 0);
                let start_code = Array.init seg_count (fun _ -> rdu16 ch) in
                let id_delta = Array.init seg_count (fun _ -> rdu16 ch) in
                let id_range_offset = Array.init seg_count (fun _ -> rdu16 ch) in
                let count = length - (8 * seg_count + 16) / 2 in
                let glyph_index = Array.init count (fun _ -> rdu16 ch) in
                (* TODO: whatever Reader.hx does here *)
                Cmap4 {
                    c4_format = format;
                    c4_length = length;
                    c4_language = language;
                    c4_seg_count_x2 = seg_count;
                    c4_search_range = search_range;
                    c4_entry_selector = entry_selector;
                    c4_range_shift = range_shift;
                    c4_end_code = end_code;
                    c4_reserved_pad = reserved;
                    c4_start_code = start_code;
                    c4_id_delta = id_delta;
                    c4_id_range_offset = id_range_offset;
                    c4_glyph_index_array = glyph_index;
                }
            | 6 ->
                let first_code = rdu16 ch in
                let entry_count = rdu16 ch in
                let glyph_index = Array.init entry_count (fun _ -> rdu16 ch) in
                Cmap6 {
                    c6_format = format;
                    c6_length = length;
                    c6_language = language;
                    c6_first_code = first_code;
                    c6_entry_count = entry_count;
                    c6_glyph_index_array = glyph_index;
                }
            | x ->
                failwith ("Not implemented format: " ^ (string_of_int x));
        in
        {
            cs_def = def;
            cs_header = entry;
        }

    in
    {
        cmap_version = version;
        cmap_num_subtables = num_subtables;
        cmap_subtables = List.rev_map parse_sub dir;
    }

let parse_glyf_table maxp loca cmap hmtx ctx =
    let ch = ctx.ch in
    let parse_glyf i =
        seek_in ctx.file ((ti ctx.entry.entry_offset) + (ti loca.(i)));
        let num_contours = rd16 ch in
        let xmin = rd16 ch in
        let ymin = rd16 ch in
        let xmax = rd16 ch in
        let ymax = rd16 ch in
        let header = {
            gh_num_contours = num_contours;
            gh_xmin = xmin;
            gh_ymin = ymin;
            gh_xmax = xmax;
            gh_ymax = ymax;
        } in
        let def = if num_contours >= 0 then begin
            let num_points = ref 0 in
            let end_pts_of_contours = Array.init num_contours (fun i ->
                let v = rdu16 ch in
                if i = num_contours - 1 then num_points := v + 1;
                v
            ) in
            let instruction_length = rdu16 ch in
            let instructions = Array.init instruction_length (fun _ ->
                IO.read ch
            ) in
            let flags = DynArray.create () in
            let rec loop index =
                if index >= !num_points then () else begin
                    let v = rbti ch in
                    let incr = if (v land 8) == 0 then begin
                        DynArray.add flags v;
                        1
                    end else begin
                        let r = (int_of_char (IO.read ch)) in
                        for i = 0 to r - 1 do DynArray.add flags v done;
                        r
                    end in
                    loop (index + incr)
                end
            in
            loop 0;
            let x_coordinates = Array.init !num_points (fun i ->
                let flag = DynArray.get flags i in
                if flag land 0x10 <> 0 then begin
                    if flag land 0x02 <> 0 then rbti ch
                    else 0
                end else begin
                    if flag land 0x02 <> 0 then -rbti ch
                    else rd16 ch
                end;
            ) in
            let y_coordinates = Array.init !num_points (fun i ->
                let flag = DynArray.get flags i in
                if flag land 0x20 <> 0 then begin
                    if flag land 0x04 <> 0 then rbti ch
                    else 0
                end else begin
                    if flag land 0x04 <> 0 then -rbti ch
                    else rd16 ch
                end;
            ) in
            TglyfSimple {
                gs_end_pts_of_contours = end_pts_of_contours;
                gs_instruction_length = instruction_length;
                gs_instructions = instructions;
                gs_flags = DynArray.to_array flags;
                gs_x_coordinates = x_coordinates;
                gs_y_coordinates = y_coordinates;
            }
        end else if num_contours = -1 then begin
            let acc = DynArray.create () in
            let rec loop () =
                let flags = rdu16 ch in
                let glyph_index = rdu16 ch in
                let arg1,arg2 = if flags land 1 <> 0 then begin
                    let arg1 = rd16 ch in
                    let arg2 = rd16 ch in
                    arg1,arg2
                end else begin
                    let arg1 = rbti ch in
                    let arg2 = rbti ch in
                    arg1,arg2
                end in
                let fmt214 i = (float_of_int i) /. (float_of_int 0x4000) in
                let tmodes = DynArray.create () in
                if flags land 8 <> 0 then DynArray.add tmodes (Scale (fmt214 (rd16 ch)));
                if flags land 64 <> 0 then begin
                    let s1 = fmt214 (rd16 ch) in
                    let s2 = fmt214 (rd16 ch) in
                    DynArray.add tmodes (ScaleXY (s1,s2))
                end;
                if flags land 128 <> 0 then begin
                    let a = fmt214 (rd16 ch) in
                    let b = fmt214 (rd16 ch) in
                    let c = fmt214 (rd16 ch) in
                    let d = fmt214 (rd16 ch) in
                    DynArray.add tmodes (ScaleMatrix (a,b,c,d))
                end;
                DynArray.add acc {
                    gc_flags = flags;
                    gc_glyf_index = glyph_index;
                    gc_arg1 = arg1;
                    gc_arg2 = arg2;
                    gc_transformations = DynArray.to_list tmodes;
                }
            in
            loop ();
            TglyfComposite (DynArray.to_list acc)
        end else
            failwith "Unknown Glyf"
        in
        {
            glyf_header = header;
            glyf_def = def;
        }
    in
    Array.init maxp.maxp_num_glyphs (fun i -> parse_glyf i)

let parse_kern_table ctx =
    let ch = ctx.ch in
    let version = ti32 (rd16 ch) in
    let num_tables = ti32 (rd16 ch) in
    let tables = ExtList.List.init (ti num_tables) (fun _ ->
        let length = ti32 (rdu16 ch) in
        let tuple_index = rdu16 ch in
        let coverage = rdu16 ch in
        let def = match coverage lsr 8 with
        | 0 ->
            let num_pairs = rdu16 ch in
            let search_range = rdu16 ch in
            let entry_selector = rdu16 ch in
            let range_shift = rdu16 ch in
            let kerning_pairs = ExtList.List.init num_pairs (fun _ ->
                let left = rdu16 ch in
                let right = rdu16 ch in
                let value = rd16 ch in
                {
                    left = left;
                    right = right;
                    value = value;
                }
            ) in
            Kern0 {
                k0_num_pairs = num_pairs;
                k0_search_range = search_range;
                k0_entry_selector = entry_selector;
                k0_range_shift = range_shift;
                k0_pairs = kerning_pairs;
            }
        | 2 ->
            let row_width = rdu16 ch in
            let left_offset_table = rdu16 ch in
            let right_offset_table = rdu16 ch in
            let array_offset = rdu16 ch in
            let first_glyph = rdu16 ch in
            let num_glyphs = rdu16 ch in
            let offsets = ExtList.List.init num_glyphs (fun _ ->
                rdu16 ch
            ) in
            Kern2 {
                k2_row_width = row_width;
                k2_left_offset_table = left_offset_table;
                k2_right_offset_table = right_offset_table;
                k2_array = array_offset;
                k2_first_glyph = first_glyph;
                k2_num_glyphs = num_glyphs;
                k2_offsets = offsets;
            }
        | i ->
            failwith ("Unknown kerning: " ^ (string_of_int i));
        in
        {
            ks_def = def;
            ks_header = {
                ksh_length = length;
                ksh_coverage = coverage;
                ksh_tuple_index = tuple_index;
            }
        }
    ) in
    {
        kern_version = version;
        kern_num_tables = num_tables;
        kern_subtables = tables;
    }

let parse_name_table ctx =
    let ch = ctx.ch in
    let format = rdu16 ch in
    let num_records = rdu16 ch in
    let offset = rdu16 ch in
    let records = Array.init num_records (fun _ ->
        let platform_id = rdu16 ch in
        let platform_specific_id = rdu16 ch in
        let language_id = rdu16 ch in
        let name_id = rdu16 ch in
        let length = rdu16 ch in
        let offset = rdu16 ch in
        {
            nr_platform_id = platform_id;
            nr_platform_specific_id = platform_specific_id;
            nr_language_id = language_id;
            nr_name_id = name_id;
            nr_length = length;
            nr_offset = offset;
            nr_value = "";
        }
    ) in
    let ttf_name = ref "" in
    let records = Array.map (fun r ->
        seek_in ctx.file ((ti ctx.entry.entry_offset) + offset + r.nr_offset);
        r.nr_value <- IO.nread ch r.nr_length;
        if r.nr_name_id = 4 && r.nr_platform_id = 3 || r.nr_platform_id = 0 then ttf_name := r.nr_value;
        r
    ) records in
    {
        name_format = format;
        name_num_records = num_records;
        name_offset = offset;
        name_records = records;
    },!ttf_name

let parse_os2_table ctx =
    let ch = ctx.ch in
    let version = rdu16 ch in
    let x_avg_char_width = rd16 ch in
    let us_weight_class = rdu16 ch in
    let us_width_class = rdu16 ch in
    let fs_type = rd16 ch in
    let y_subscript_x_size = rd16 ch in
    let y_subscript_y_size = rd16 ch in
    let y_subscript_x_offset = rd16 ch in
    let y_subscript_y_offset = rd16 ch in
    let y_superscript_x_size = rd16 ch in
    let y_superscript_y_size = rd16 ch in
    let y_superscript_x_offset = rd16 ch in
    let y_superscript_y_offset = rd16 ch in
    let y_strikeout_size = rd16 ch in
    let y_strikeout_position = rd16 ch in
    let s_family_class = rd16 ch in
    let b_family_type = rbti ch in
    let b_serif_style = rbti ch in
    let b_weight = rbti ch in
    let b_proportion = rbti ch in
    let b_contrast = rbti ch in
    let b_stroke_variation = rbti ch in
    let b_arm_style = rbti ch in
    let b_letterform = rbti ch in
    let b_midline = rbti ch in
    let b_x_height = rbti ch in
    let ul_unicode_range_1 = rd32r ch in
    let ul_unicode_range_2 = rd32r ch in
    let ul_unicode_range_3 = rd32r ch in
    let ul_unicode_range_4 = rd32r ch in
    let ach_vendor_id = rd32r ch in
    let fs_selection = rd16 ch in
    let us_first_char_index = rdu16 ch in
    let us_last_char_index = rdu16 ch in
    let s_typo_ascender = rd16 ch in
    let s_typo_descender = rd16 ch in
    let us_win_ascent = rdu16 ch in
    let us_win_descent = rdu16 ch in
    {
        os2_version = version;
        os2_x_avg_char_width = x_avg_char_width;
        os2_us_weight_class = us_weight_class;
        os2_us_width_class = us_width_class;
        os2_fs_type = fs_type;
        os2_y_subscript_x_size = y_subscript_x_size;
        os2_y_subscript_y_size = y_subscript_y_size;
        os2_y_subscript_x_offset = y_subscript_x_offset;
        os2_y_subscript_y_offset = y_subscript_y_offset;
        os2_y_superscript_x_size = y_superscript_x_size;
        os2_y_superscript_y_size = y_superscript_y_size;
        os2_y_superscript_x_offset = y_superscript_x_offset;
        os2_y_superscript_y_offset = y_superscript_y_offset;
        os2_y_strikeout_size = y_strikeout_size;
        os2_y_strikeout_position = y_strikeout_position;
        os2_s_family_class = s_family_class;
        os2_b_family_type = b_family_type;
        os2_b_serif_style = b_serif_style;
        os2_b_weight = b_weight;
        os2_b_proportion = b_proportion;
        os2_b_contrast = b_contrast;
        os2_b_stroke_variation = b_stroke_variation;
        os2_b_arm_style = b_arm_style;
        os2_b_letterform = b_letterform;
        os2_b_midline = b_midline;
        os2_b_x_height = b_x_height;
        os2_ul_unicode_range_1 = ul_unicode_range_1;
        os2_ul_unicode_range_2 = ul_unicode_range_2;
        os2_ul_unicode_range_3 = ul_unicode_range_3;
        os2_ul_unicode_range_4 = ul_unicode_range_4;
        os2_ach_vendor_id = ach_vendor_id;
        os2_fs_selection = fs_selection;
        os2_us_first_char_index = us_first_char_index;
        os2_us_last_char_index = us_last_char_index;
        os2_s_typo_ascender = s_typo_ascender;
        os2_s_typo_descender = s_typo_descender;
        os2_us_win_ascent = us_win_ascent;
        os2_us_win_descent = us_win_descent;
    }

let parse file : ttf =
    let ctx = {
        file = file;
        ch = IO.input_channel file;
        entry = {
            entry_table_name = "";
            entry_offset = ti32 0;
            entry_length = ti32 0;
            entry_checksum = ti32 0;
        }
    } in
    let header = parse_header ctx in
    let directory = parse_directory ctx header in
    let parse_table entry f =
        seek_in file (ti entry.entry_offset);
        ctx.entry <- entry;
        f ctx
    in
    let head = parse_table (Hashtbl.find directory "head") parse_head_table in
    let hhea = parse_table (Hashtbl.find directory "hhea") parse_hhea_table in
    let maxp = parse_table (Hashtbl.find directory "maxp") parse_maxp_table in
    let loca = parse_table (Hashtbl.find directory "loca") (parse_loca_table head maxp) in
    let hmtx = parse_table (Hashtbl.find directory "hmtx") (parse_hmtx_table maxp hhea) in
    let cmap = parse_table (Hashtbl.find directory "cmap") (parse_cmap_table) in
    let glyf = parse_table (Hashtbl.find directory "glyf") (parse_glyf_table maxp loca cmap hmtx) in
    (* let kern = parse_table (Hashtbl.find directory "kern") (parse_kern_table) in *)
    let name,ttf_name = parse_table (Hashtbl.find directory "name") (parse_name_table) in
    let os2 = parse_table (Hashtbl.find directory "OS/2") (parse_os2_table) in
    let tables = ("head", (THead head)) :: ("hhea", (THhea hhea)) :: ("maxp", (TMaxp maxp))
              :: ("loca", (TLoca loca)) :: ("hmtx", (THmtx hmtx)) :: ("cmap", (TCmap cmap))
              :: ("glyf", (TGlyf glyf)) :: ("name", (TName name))
              :: ("OS/2", (TOS2 os2)) :: []
    in
    {
        ttf_header = header;
        ttf_name = ttf_name;
        ttf_directory = directory;
        ttf_tables = tables;
    }

(* WRITING *)

(* TODO: move this to swf.ml *)

type font_language_code =
    | LCNone (*0*)
    | LCLatin (*1*)
    | LCJapanese (*2*)
    | LCKorean (*3*)
    | LCSimplifiedChinese (*4*)
    | LCTraditionalChinese (*5*)

type font_glyph_data = {
    font_char_code: int;
    font_shape: shape_records;
}

type font_layout_glyph_data = {
    font_advance: int;
    font_bounds: rect;
}

type font_kerning_data = {
    font_char_code1: int;
    font_char_code2: int;
    font_adjust: int;
}

type font_layout_data = {
    font_ascent: int;
    font_descent: int;
    font_leading: int;
    font_glyphs: font_layout_glyph_data list;
    font_kerning: font_kerning_data list;
}

type font2_data = {
    font_shift_jis: bool;
    font_is_small: bool;
    font_is_ansi: bool;
    font_is_italic: bool;
    font_is_bold: bool;
    font_language: font_language_code;
    font_name: string;
    font_glyphs: font_glyph_data array;
    font_layout: font_layout_data option;
}

(* This can stay *)

type write_ctx = {
    head : head;
    cmap : cmap;
    glyf : glyf array;
}

type glyf_path = {
    gp_type : int;
    gp_x : float;
    gp_y : float;
    gp_cx : float;
    gp_cy : float;
}

let mk_path t x y cx cy = {
    gp_type = t;
    gp_x = x;
    gp_y = y;
    gp_cx = cx;
    gp_cy = cy;
}

let make_path ctx pq p1 p2 arr g =
    let p1_on_curve = g.gs_flags.(p1) land 0x01 <> 0 in
    let p2_on_curve = g.gs_flags.(p2) land 0x01 <> 0 in
    match p1_on_curve, p2_on_curve with
    | true, true ->
        let path = mk_path 1 (float_of_int g.gs_x_coordinates.(p2)) (float_of_int g.gs_y_coordinates.(p2)) 0.0 0.0 in
        DynArray.add arr path;
    | false, false ->
        let path = mk_path 2 !pq.gp_x !pq.gp_y (float_of_int g.gs_x_coordinates.(p1)) (float_of_int g.gs_y_coordinates.(p1)) in
        DynArray.add arr path;
        pq := (mk_path (-1) (float_of_int g.gs_x_coordinates.(p2)) (float_of_int g.gs_y_coordinates.(p2)) 0.0 0.0)
    | true, false ->
        pq := (mk_path (-1) (float_of_int g.gs_x_coordinates.(p2)) (float_of_int g.gs_y_coordinates.(p2)) 0.0 0.0)
    | false, true ->
        let path = mk_path 2 (float_of_int g.gs_x_coordinates.(p2)) (float_of_int g.gs_y_coordinates.(p2)) !pq.gp_x !pq.gp_y in
        DynArray.add arr path

let build_paths ctx g =
    let len = Array.length g.gs_end_pts_of_contours in
    let arr = DynArray.create () in
    let cp = ref 0 in
    let start = ref 0 in
    let stop = ref 0 in
    let pq = ref (mk_path (-1) 0.0 0.0 0.0 0.0) in
    for i = 0 to len - 1 do
        start := !cp;
        stop := g.gs_end_pts_of_contours.(i);
        let path = mk_path 0 (float_of_int g.gs_x_coordinates.(!start)) (float_of_int g.gs_y_coordinates.(!start)) 0.0 0.0 in
        DynArray.add arr path;
        for j = 0 to !stop - !start - 1 do
            make_path ctx pq !cp (!cp + 1) arr g;
            incr cp;
        done;
        make_path ctx pq !stop !start arr g;
        incr cp;
    done;
    DynArray.to_list arr

let begin_fill ctx c a =
    SRStyleChange {
        scsr_move = None;
        scsr_fs0 = None;
        scsr_fs1 = Some(1); (* Some (c lor (a lsl 24));*) (* CHECK *)
        scsr_ls = None; (* CHECK *)
        scsr_new_styles = None;
    }

let move_to ctx x y =
    SRStyleChange {
        scsr_move = Some (0,int_of_float x, int_of_float y); (* TODO *)
        scsr_fs0 = None;
        scsr_fs1 = None; (* TODO *)
        scsr_ls = None;
        scsr_new_styles = None;
    }

let line_to ctx x y =
    SRStraightEdge {
        sser_nbits = max (SwfParser._nbits (abs(int_of_float x))) (SwfParser._nbits (abs(int_of_float y))); (* TODO ? *)
        sser_line = Some (int_of_float x), Some (int_of_float y);
    }

let curve_to ctx cx cy x y =
    SRCurvedEdge {
        scer_nbits = 2 + (max
            (max (SwfParser._nbits (abs(int_of_float x))) (SwfParser._nbits (abs(int_of_float y))))
            (max (SwfParser._nbits (abs(int_of_float cx))) (SwfParser._nbits (abs(int_of_float cy))))); (* TODO ? *)
        scer_cx = int_of_float cx;
        scer_cy = int_of_float cy;
        scer_ax = int_of_float x;
        scer_ay = int_of_float y;
    }

let write_paths ctx paths =
    let scale = 100. /. (float_of_int ctx.head.hd_units_per_em) in
    let srl = DynArray.create () in
    DynArray.add srl (begin_fill ctx 0 1);
    List.iter (fun path ->
        DynArray.add srl (match path.gp_type with
        | 0 -> move_to ctx (path.gp_x *. scale) ((-1.) *. path.gp_y *. scale);
        | 1 -> line_to ctx (path.gp_x *. scale) ((-1.) *. path.gp_y *. scale);
        | 2 -> curve_to ctx (path.gp_cx *. scale) ((-1.) *. path.gp_cy *. scale) (path.gp_x *. scale) ((-1.) *. path.gp_y *. scale);
        | _ -> assert false)
    ) paths;
    {
        srs_nfbits = 2; (* TODO *)
        srs_nlbits = 0; (* TODO *)
        srs_records = DynArray.to_list srl;
    }

let write_glyph ctx glyf =
    match glyf.glyf_def with
    | TglyfSimple g ->
        let path = build_paths ctx g in
        {
            font_char_code = 0; (* TODO *)
            font_shape = write_paths ctx path;
        }
    | TglyfComposite g ->
        {
            font_char_code = 0; (* TODO *)
            font_shape = write_paths ctx []; (* TODO *)
        }

let map_char_code cc c4 =
    (* TODO: well yeah... *)
    0

let make_cmap4_map ctx c4 =
    let lut = Hashtbl.create 0 in
    let seg_count = c4.c4_seg_count_x2 / 2 in
    for i = 0 to seg_count - 1 do
        for j = c4.c4_start_code.(i) to c4.c4_end_code.(i) do
            let index = map_char_code j c4 in
            Hashtbl.add lut j index
        done;
    done;
    lut

let bi v = if v then 1 else 0

let write_font2 ch b f2 =
    IO.write_byte ch 255; (* 48 DefineFont 1/2 *)
    IO.write_byte ch 18; (* 48 DefineFont 2/2 *)
    IO.write_i32 ch 16777215; (* TODO: tag body size/length *)
    IO.write_ui16 ch 1; (*TODO: Char id *)

    IO.write_bits b 1 (bi (f2.font_layout <> None));
    IO.write_bits b 1 (bi f2.font_shift_jis);
    IO.write_bits b 1 (bi f2.font_is_small);
    IO.write_bits b 1 (bi f2.font_is_ansi);
    IO.write_bits b 1 (bi false); (* TODO: wide offsets *)
    IO.write_bits b 1 (bi true); (* TODO: wide codes *)
    IO.write_bits b 1 (bi f2.font_is_italic);
    IO.write_bits b 1 (bi f2.font_is_bold);

    IO.write_byte ch 0; (* TODO: f2.font_language; LCNone *)

    IO.write_byte ch (String.length f2.font_name);
    IO.nwrite ch f2.font_name;
    IO.write_ui16 ch (Array.length f2.font_glyphs); (* numglyps *)
    Array.iter (fun _ -> IO.write_ui16 ch 0) f2.font_glyphs; (* TODO: offsetTable *)
    IO.write_ui16 ch (2 * Array.length f2.font_glyphs); (* TODO: offset to codeTable depends on 16 or 32 bit *)

    Array.iter (fun g ->
        (* let b = IO.output_bits ch in *)
        print_string "===========================================================================\n";
        let nlbits = ref g.font_shape.srs_nlbits in
        let nfbits = ref g.font_shape.srs_nfbits in
        List.iter (fun r ->
            match r with
            | SRStyleChange s ->
                print_string "SRStyleChange\n";
                (match s.scsr_move with
                |None -> ();
                    print_string "s.scsr_move 0: 0"; print_string "\n";
                    print_string "s.scsr_move x: 0"; print_string "\n";
                    print_string "s.scsr_move y: 0"; print_string "\n\n";
                |Some (w , x, y) ->
                    print_string "s.scsr_move 0: "; print_int w; print_string "\n";
                    print_string "s.scsr_move x: "; print_int x; print_string "\n";
                    print_string "s.scsr_move y: "; print_int y; print_string "\n\n";);
            | SRStraightEdge s->
                print_string "SRStraightEdge\n";
                print_string "s.sser_nbits: "; print_int s.sser_nbits; print_string "\n";
                (match s.sser_line with
                |None, None ->
                    print_string "s.sser_line x: None";
                    print_string "s.sser_line y: None\n\n";
                |Some (x), None ->
                    print_string "s.sser_line x: "; print_int x; print_string "\n";
                    print_string "s.sser_line y: None\n\n";
                |None, Some (y) ->
                    print_string "s.sser_line x: None\n";
                    print_string "s.sser_line y: "; print_int y; print_string "\n\n";
                |Some (x), Some (y) ->
                    print_string "s.sser_line x: "; print_int x; print_string "\n";
                    print_string "s.sser_line y: "; print_int y; print_string "\n\n";);
            | SRCurvedEdge s ->
                print_string "SRCurvedEdge\n";
                print_string "s.scer_nbits: "; print_int s.scer_nbits; print_string "\n";
                print_string "s.scer_cx: "; print_int s.scer_cx; print_string "\n";
                print_string "s.scer_cy: "; print_int s.scer_cy; print_string "\n";
                print_string "s.scer_ax: "; print_int s.scer_ax; print_string "\n";
                print_string "s.scer_ay: "; print_int s.scer_ay; print_string "\n\n";

            (* try *)
                SwfParser.write_shape_record ch b nlbits nfbits r;
            (* with _ -> print_string "----------^^ FAILURE!"; print_string "\n\n"; *)

        ) g.font_shape.srs_records
    ) f2.font_glyphs
    (* TODO: rest *)

let write_swf ttf range_str =
    let ctx = {
        head = (match List.assoc "head" ttf.ttf_tables with THead head -> head | _ -> assert false);
        cmap = (match List.assoc "cmap" ttf.ttf_tables with TCmap cmap -> cmap | _ -> assert false);
        glyf = (match List.assoc "glyf" ttf.ttf_tables with TGlyf glyf -> glyf | _ -> assert false);
    } in
    let rec loop cl = match cl with
        | [] -> failwith "Cmap4 table not found"
        | {cs_def = Cmap4 c4} :: _ ->
            make_cmap4_map ctx c4
        | _ :: cl ->
            loop cl
    in
    let glyph_lut = loop ctx.cmap.cmap_subtables in
    ignore(glyph_lut);
    (* TODO: check range, perform lookup *)
    {
        font_shift_jis = false;
        font_is_small = false;
        font_is_ansi = false;
        font_is_italic = false;
        font_is_bold = false;
        font_language = LCNone;
        font_name = "chopin"; (* ttf.ttf_name; *)
        font_glyphs = Array.map (write_glyph ctx) ctx.glyf;
        font_layout = None;
    }
;;
let f2 = write_swf (parse (open_in_bin "chopin.ttf")) "" in
let ch = (IO.output_channel (open_out_bin "chopin_test.dat")) in
let b = IO.output_bits ch in
write_font2 ch b f2

(* ocamlopt -I ../extlib -I ../extc enum.cmx extlist.cmx extstring.cmx io.cmx dynarray.cmx multiarray.cmx swf.cmx as3code.cmx as3parse.cmx actionscript.cmx swfparser.cmx ttf.ml -o run.exe *)