(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            François Pessaux, projet Cristal, INRIA Rocquencourt     *)
(*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
(*            Jun Furuse, projet Cristal, INRIA Rocquencourt           *)
(*                                                                     *)
(*  Copyright 1999,2000,2001,2002,2001,2002                            *)
(*  Institut National de Recherche en Informatique et en Automatique.  *)
(*  Distributed only by permission.                                    *)
(*                                                                     *)
(***********************************************************************)

open Image
open Rgb24

type colormodel = RGB | CMYK | WHITEBLACK | BLACKWHITE

type in_handle
external open_in : string -> int * int * float * colormodel * in_handle
    = "open_tiff_file_for_read"
external read_scanline : in_handle -> string -> int -> unit
    = "read_tiff_scanline"
external close_in : in_handle -> unit
    = "close_tiff_file"

type out_handle
external open_out : string -> int -> int -> float -> out_handle
    = "open_tiff_file_for_write"
external write_scanline : out_handle -> string -> int -> unit
    = "write_tiff_scanline"
external close_out : out_handle -> unit
    = "close_tiff_file"

(* not supported anymore 
external read : string -> int * int * float * string
    = "read_tiff_file";;
external write : string -> string -> int -> int -> float -> unit
    = "write_tiff_file";;

let load name =
  let w, h, dpi, buf = read name in
  let infos = if dpi = -1.0 then [] else [ Info_DPI dpi ] in
  Rgb24 (Rgb24.create_with w h infos buf)

let save name image =
  match image with
    Rgb24 bmp ->
      let resolution = (* resolution in DPI *)
    	match Image.dpi bmp.infos with
    	| Some r -> r
    	| None -> 200.0 
      in
      write name (Bitmap.dump bmp.data) bmp.width bmp.height resolution
  | _ -> raise Wrong_image_type
*)

let load name opts =
  let prog = Image.load_progress opts in
  let w, h, dpi, colormodel, tif = open_in name in
  let img, buf =
    match colormodel with
    | RGB ->
      	let img = Rgb24.create w h in
	Rgb24 img,
      	String.create (w * 3)
    | CMYK ->
	let img = Cmyk32.create w h in
	Cmyk32 img,
      	String.create (w * 4)
    | WHITEBLACK ->
	let img = Index8.create w h in
	img.Index8.colormap.map <- [| {r=255; g=255; b=255};
				      {r=0; g=0; b=0} |];
	Index8 img,
	String.create ((w + 7) / 8)
    | BLACKWHITE ->
	let img = Index8.create w h in
	img.Index8.colormap.map <- [| {r=0; g=0; b=0};
				      {r=255; g=255; b=255} |];
	Index8 img,
	String.create ((w + 7) / 8)
  in
  
  let set_scanline =
    match colormodel, img with
    | _, Rgb24 img -> fun buf y -> Rgb24.set_scanline img y buf
    | _, Cmyk32 img -> fun buf y -> Cmyk32.set_scanline img y buf
    | BLACKWHITE, Index8 img 
    | WHITEBLACK, Index8 img -> 
	let bits = [| 128; 64; 32; 16; 8; 4; 2; 1 |] in
	fun buf y ->
	  for x = 0 to w - 1 do
	    let c = x lsr 3 in
	    let b = x land 7 in
	    if Char.code buf.[c] land Array.unsafe_get bits b <> 0 then 
	      Index8.unsafe_set img x y 1
	  done
    | _ -> assert false
  in
    
  for y = 0 to h - 1 do
    read_scanline tif buf y;
    set_scanline buf y;
    match prog with
      Some p -> p (float (y + 1) /. float h)
    | None -> ()
  done;
  close_in tif;
  img
;;

let save name opts image =
  match image with
    Rgb24 bmp ->
      let resolution = (* resolution in DPI *)
    	match Image.dpi bmp.infos with
    	| Some r -> r
    	| None -> 200.0 
      in
      let oc = open_out name bmp.width bmp.height resolution in
      for y = 0 to bmp.height - 1 do
	write_scanline oc (Rgb24.get_scanline bmp y) y
      done;
      close_out oc
  | _ -> raise Wrong_image_type

let check_header filename =
  let len = 4 in
  let ic = open_in_bin filename in
  try
    let str = String.create len in
    really_input ic str 0 len;
    Pervasives.close_in ic;
    match str with
    | "MM\000\042" ->
      { header_width= -1;
  	header_height= -1;
  	header_infos= [Image.Info_BigEndian] }
    | "II\042\000" -> 
      { header_width= -1;
  	header_height= -1;
  	header_infos= [Image.Info_LittleEndian] }
    | _ -> 
  	raise Wrong_file_type
  with
  | _ -> 
      Pervasives.close_in ic;
      raise Wrong_file_type

let _ = add_methods Tiff { check_header= check_header; 
			   load= Some load;
			   save= Some save;
			   load_sequence = None;
			   save_sequence = None}

