open TTFData
open IO

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

let rd16 = BigEndian.read_i16
let rdu16 = BigEndian.read_ui16
let rd32 = BigEndian.read_i32
let rd32r = BigEndian.read_real_i32

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 = 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 = BigEndian.read_double ch in
	let modified = BigEndian.read_double 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 = 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 _ -> Int32.of_int ((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 (* check me 1/2*)
	Array.init maxp.maxp_num_glyphs (fun i ->
		let advance_width = if i > hhea.hhea_number_of_hmetrics-1 then (* check me 2/2*)
			!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 dir = List.stable_sort (fun csh1 csh2 ->
		if csh1.csh_platform_id < csh2.csh_platform_id then -1
		else if csh1.csh_platform_id > csh2.csh_platform_id then 1
		else compare csh1.csh_platform_specific_id csh2.csh_platform_specific_id
	) dir in
	let parse_sub entry =
		seek_in ctx.file ((Int32.to_int ctx.entry.entry_offset) + (Int32.to_int entry.csh_offset));
		let format = rdu16 ch in
		let def = match format with
			| 0 ->
				let length = rdu16 ch in
				let language = rdu16 ch in
				let glyph_index = Array.init 256 (fun _ -> read ch) in
				Cmap0 {
					c0_format = 0;
					c0_length = length;
					c0_language = language;
					c0_glyph_index_array = glyph_index;
				}
			| 4 ->
				let length = rdu16 ch in
				let language = rdu16 ch in
				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
				Cmap4 {
					c4_format = format;
					c4_length = length;
					c4_language = language;
					c4_seg_count_x2 = seg_count_x2;
					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 length = rdu16 ch in
				let language = rdu16 ch in
				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;
				}
  			| 12 ->
				ignore (rd16 ch);
				let length = rd32r ch in
				let language = rd32r ch in
				let num_groups = rd32r ch in
				let groups = ExtList.List.init (Int32.to_int num_groups) (fun _ ->
					let start = rd32r ch in
					let stop = rd32r ch in
					let start_glyph = rd32r ch in
					{
						c12g_start_char_code = start;
						c12g_end_char_code = stop;
						c12g_start_glyph_code = start_glyph;
					}
				) in
				Cmap12 {
					c12_format = Int32.of_int 12;
					c12_length = length;
					c12_language = language;
					c12_num_groups = num_groups;
					c12_groups = groups;
				}
			| 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.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 ((Int32.to_int ctx.entry.entry_offset) + (Int32.to_int 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
		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 _ ->
				read ch
			) in
			let flags = DynArray.create () in
			let rec loop index =
				if index >= !num_points then () else begin
					let v = read_byte ch in
					let incr = if (v land 8) == 0 then begin
						DynArray.add flags v;
						1
					end else begin
						let r = (int_of_char (read ch)) in
						for i = 0 to r do DynArray.add flags v done;
						r + 1
					end in
					loop (index + incr)
				end
			in
			loop 0;
			assert (DynArray.length flags = !num_points);
			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 read_byte ch
					else 0
				end else begin
					if flag land 0x02 <> 0 then -read_byte 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 read_byte ch
					else 0
				end else begin
					if flag land 0x04 <> 0 then -read_byte ch
					else rd16 ch
				end;
			) in
			TGlyfSimple (header, {
				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 = read_byte ch in
					let arg2 = read_byte ch in
					arg1,arg2
				end in
				let fmt214 i = (float_of_int i) /. (float_of_int 0x4000) in
				let fmode =	if flags land 8 <> 0 then
					Scale (fmt214 (rd16 ch))
				else if flags land 64 <> 0 then begin
					let s1 = fmt214 (rd16 ch) in
					let s2 = fmt214 (rd16 ch) in
					ScaleXY (s1,s2)
				end else 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
					ScaleMatrix (a,b,c,d)
				end else
					NoScale
				in
				DynArray.add acc {
					gc_flags = flags;
					gc_glyf_index = glyph_index;
					gc_arg1 = if flags land 2 <> 0 then arg1 else 0;
					gc_arg2 = if flags land 2 <> 0 then arg2 else 0;
					gc_transformation = fmode;
				};
				if flags land 0x20 <> 0 then loop ();
			in
			loop ();
			TGlyfComposite (header,(DynArray.to_list acc))
		end else
			failwith "Unknown Glyf"
	in
	Array.init maxp.maxp_num_glyphs (fun i ->
		let len = (Int32.to_int loca.(i + 1)) - (Int32.to_int loca.(i)) in
		if len > 0 then parse_glyf i else TGlyfNull
	)

let parse_kern_table ctx =
	let ch = ctx.ch in
	let version = Int32.of_int (rd16 ch) in
	let num_tables = Int32.of_int (rd16 ch) in
	let tables = ExtList.List.init (Int32.to_int num_tables) (fun _ ->
		let length = Int32.of_int (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
				{
					kern_left = left;
					kern_right = right;
					kern_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
	(* TODO: use real utf16 conversion *)
	let set_name n =
		let l = ExtList.List.init (String.length n / 2) (fun i -> String.make 1 n.[i * 2 + 1]) in
		ttf_name := String.concat "" l
	in
	let records = Array.map (fun r ->
		seek_in ctx.file ((Int32.to_int ctx.entry.entry_offset) + offset + r.nr_offset);
		r.nr_value <- nread ch r.nr_length;
		if r.nr_name_id = 4 && r.nr_platform_id = 3 || r.nr_platform_id = 0 then set_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 = read_byte ch in
	let b_serif_style = read_byte ch in
	let b_weight = read_byte ch in
	let b_proportion = read_byte ch in
	let b_contrast = read_byte ch in
	let b_stroke_variation = read_byte ch in
	let b_arm_style = read_byte ch in
	let b_letterform = read_byte ch in
	let b_midline = read_byte ch in
	let b_x_height = read_byte 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 s_typo_line_gap = 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_s_typo_line_gap = s_typo_line_gap;
		os2_us_win_ascent = us_win_ascent;
		os2_us_win_descent = us_win_descent;
	}

let parse file : ttf =
	let ctx = {
		file = file;
		ch = input_channel file;
		entry = {
			entry_table_name = "";
			entry_offset = Int32.of_int 0;
			entry_length = Int32.of_int 0;
			entry_checksum = Int32.of_int 0;
		}
	} in
	let header = parse_header ctx in
	let directory = parse_directory ctx header in
	let parse_table entry f =
		seek_in file (Int32.to_int entry.entry_offset);
		ctx.entry <- entry;
		f ctx
	in
	let parse_req_table name f =
		try
			let entry = Hashtbl.find directory name in
			parse_table entry f
		with Not_found ->
			failwith (Printf.sprintf "Required table %s could not be found" name)
	in
	let parse_opt_table name f =
		try
			let entry = Hashtbl.find directory name in
			Some (parse_table entry f)
		with Not_found ->
			None
	in
	let head = parse_req_table "head" parse_head_table in
	let hhea = parse_req_table "hhea" parse_hhea_table in
	let maxp = parse_req_table "maxp" parse_maxp_table in
	let loca = parse_req_table "loca" (parse_loca_table head maxp) in
	let hmtx = parse_req_table "hmtx" (parse_hmtx_table maxp hhea) in
	let cmap = parse_req_table "cmap" (parse_cmap_table) in
	let glyfs = parse_req_table "glyf" (parse_glyf_table maxp loca cmap hmtx) in
	let kern = parse_opt_table "kern" (parse_kern_table) in
	let name,ttf_name = parse_req_table "name" (parse_name_table) in
	let os2 = parse_req_table "OS/2" (parse_os2_table) in
	{
		ttf_header = header;
		ttf_font_name = ttf_name;
		ttf_directory = directory;
		ttf_head = head;
		ttf_hhea = hhea;
		ttf_maxp = maxp;
		ttf_loca = loca;
		ttf_hmtx = hmtx;
		ttf_cmap = cmap;
		ttf_glyfs = glyfs;
		ttf_name = name;
		ttf_os2 = os2;
		ttf_kern = kern;
	}