(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Franois 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.                                    *)
(*                                                                     *)
(***********************************************************************)
(* The image data structure *)

(**************************************************************** Exceptions *)

exception Out_of_image
  (* exception for illegal point access *)
exception Wrong_image_type
  (* exception for illegal internal image type *)
exception Wrong_file_type
  (* exception for unsupported image FILE format *)

(* Update region.error *)
let _ = Region.error := (fun () -> raise Out_of_image);;

(************************************************************* Generic image *)

type t =
   | Index8 of Index8.t
   | Rgb24 of Rgb24.t
   | Index16 of Index16.t
   | Rgba32 of Rgba32.t
   | Cmyk32 of Cmyk32.t
  (* Generic image type *)
  
(******************************************************************** Colors *)

(* Colors: the copies of color.mli *)
type rgb = Color.rgb = { mutable r: int; mutable g: int; mutable b: int }

type rgba = Color.rgba = { color: rgb; mutable alpha: int }

type cmyk = Color.cmyk = 
    { mutable c : int; mutable m : int; mutable y : int; mutable k : int }

type map = Color.map = {
    mutable max: int;  
      (* maximum number allowed in the color map (-1 = unlimited) *)
    mutable map: rgb array
  }

(********************************************************* Image file format *)

(* Image formats *)
type format = 
   | Gif
   | Bmp
   | Jpeg
   | Tiff  
   | Png
   | Xpm
   | Ppm
   | Ps
;;

(************************************************ Image file name extensions *)

let extension = function
  | Gif -> "gif"
  | Bmp -> "bmp"
  | Jpeg -> "jpg"
  | Tiff -> "tif"
  | Png -> "png"
  | Xpm -> "xpm"
  | Ppm -> "ppm"	
  | Ps -> "eps"
;;

let get_extension s =
  try
    let dotpos = String.rindex s '.' in
    String.sub s 0 dotpos,
    String.sub s (dotpos + 1) (String.length s - dotpos - 1)
  with
  | _ -> s, ""
;;

let guess_extension s =
  let s = String.lowercase s in
  match s with
  | "gif" -> Gif
  | "bmp" -> Bmp
  | "jpeg" | "jpg" -> Jpeg
  | "tiff" | "tif" -> Tiff
  | "png" -> Png
  | "xpm" -> Xpm
  | "ppm" | "pgm" | "pbm" -> Ppm
  | "eps" | "ps" | "epsf" | "epsi" -> Ps
  | _ -> raise Not_found
;;

let guess_format file =
  guess_extension (snd (get_extension file))

(******************************************** Image file header informations *)

type colormodel = Info.colormodel =
   | Gray | RGB | Index | GrayA | RGBA
;;

(* Infos attached to bitmaps *)
type info = Info.info =
   | Info_DPI of float (* dot per inch *)
   | Info_BigEndian | Info_LittleEndian (* endianness of image file *)
   | Info_ColorModel of colormodel (* color model of image file *)
   | Info_Depth of int (* Image bit depth *)
   | Info_Corrupted (* For corrupted PNG files *)
;;

(* Info query *)
let rec dpi = function
  | [] -> None
  | Info_DPI dpi :: _ -> Some dpi
  | _ :: xs -> dpi xs
;;

(* Image file header *)
type header = {
     header_width : int;
     header_height : int;
     header_infos : info list
  }
;;

(**************************************************** Image file I/O options *)

(* Load options *)
type load_option =
   | Load_Progress of (float -> unit) (* For progress meters *)
   | Load_Resolution of float * float (* Pixel/Inch for rasterization of PS *)
;;

(* Save options *)
type save_option =
   | Save_Quality of int (* Save quality for Jpeg compression *)
   | Save_Progress of (float -> unit) (* For progress meters *)
   | Save_Interlace (* Interlaced Gif *)
;;

(* Option queries *)
let rec load_progress = function
  | [] -> None
  | Load_Progress p :: _ -> Some p
  | _ :: xs -> load_progress xs
;;

let rec load_resolution = function
  | [] -> None
  | Load_Resolution (px,py) :: _ -> Some (px,py)
  | _ :: xs -> load_resolution xs
;;

let rec save_progress = function
  | [] -> None
  | Save_Progress p :: _ -> Some p
  | _ :: xs -> save_progress xs
;;

let rec save_interlace = function
  | [] -> false
  | Save_Interlace :: _ -> true
  | _ :: xs -> save_interlace xs
;;

let rec save_quality = function
  | [] -> None
  | Save_Quality q :: _ -> Some q
  | _ :: xs -> save_quality xs
;;

(******************************** The type for methods of image file formats *)

type format_methods = {
    check_header: (string -> header);
    load: (string -> load_option list -> t) option;
    save: (string -> save_option list -> t -> unit) option;
  } 

let methods_list = ref []

let file_format filename =
  let result = ref None in 
  try
    List.iter (fun (format, methods) ->
      try
	result := Some (format, methods.check_header filename);
	raise Exit
      with
      | Wrong_file_type -> ()) !methods_list;
    raise Wrong_file_type
  with
  | Exit -> 
      match !result with
      |	Some r -> r
      |	None -> assert false
;;

(************************************************ Generic image manupilation *)

let add_methods format methods =
  methods_list := (format, methods) :: !methods_list

let load filename load_options =
  let result = ref None in 
  try
    List.iter (fun (format, methods) ->
      try 
	let _ = methods.check_header filename in
	match methods.load with
	  Some load ->
	    result := Some (load filename load_options);
	    raise Exit
	| None -> raise Wrong_file_type
      with
      | Wrong_file_type -> ()) !methods_list;
    raise Wrong_file_type
  with
  | Exit -> 
      match !result with
      |	Some r -> r
      |	None -> assert false
;;

let save filename formatopt save_options t =
  try
    let format = 
      match formatopt with
      |	Some format -> format
      |	None -> guess_format filename
    in
    let methods = List.assoc format !methods_list in
    match methods.save with 
      Some save -> save filename save_options t
    | None -> raise Wrong_file_type
  with
  | Not_found ->
      raise Wrong_file_type
;;

let size img =
  match img with
  | Index8 bmp -> bmp.Index8.width, bmp.Index8.height
  | Rgb24 bmp -> bmp.Rgb24.width, bmp.Rgb24.height
  | Index16 bmp -> bmp.Index16.width, bmp.Index16.height
  | Rgba32 bmp -> bmp.Rgba32.width, bmp.Rgba32.height
  | Cmyk32 bmp -> bmp.Cmyk32.width, bmp.Cmyk32.height
;;

let destroy img =
  match img with
  | Index8 bmp -> Index8.destroy bmp
  | Rgb24 bmp -> Rgb24.destroy bmp
  | Index16 bmp -> Index16.destroy bmp
  | Rgba32 bmp -> Rgba32.destroy bmp
  | Cmyk32 bmp -> Cmyk32.destroy bmp
;;

let blit src sx sy dst dx dy =
  let f =
    match src, dst with
    | Index8 src, Index8 dst -> (fun sx sy -> Index8.blit src sx sy dst)
    | Rgb24 src, Rgb24 dst -> (fun sx sy -> Rgb24.blit src sx sy dst)
    | Index16 src, Index16 dst -> (fun sx sy -> Index16.blit src sx sy dst)
    | Rgba32 src, Rgba32 dst -> (fun sx sy -> Rgba32.blit src sx sy dst)
    | Cmyk32 src, Cmyk32 dst -> (fun sx sy -> Cmyk32.blit src sx sy dst)
    | _ -> raise (Invalid_argument "Image.blit")
  in
  f sx sy dx dy
;;

(*********************************************** Image representation module *)

(* Each image representation module must contain these types and functions, 
   at least *)
module type T = sig
  type t
  type elt

  val create : int -> int -> t  
    (* [create width height] creates an image of the size (width x height) *)

  val destroy : t -> unit
    (* [destroy image] frees the memory and swap files of [image] 
       You have to call this function explicitly if you turn on
       image swapping (See bitmap.mli). *)

  val get : t -> int -> int -> elt
  val set : t -> int -> int -> elt -> unit
    (* [get image x y] and [set image x y v] reads/writes the pixel 
       information at (x,y) of [image]. If (x,y) is out of the image,
       they raise Out_of_image exception. *)

  val unsafe_get : t -> int -> int -> elt
  val unsafe_set : t -> int -> int -> elt -> unit
    (* [unsafe_get] and [unsafe_set] are the same functions as [get] 
       and [set], but they lack the image region checks. So it is fast.
       But you have to use them with being sure that the specified point 
       is in the image. Otherwise the result is unknown, and sometimes 
       a runtime error occurs. *)

  val sub : t -> int -> int -> int -> int -> t
  (* [sub dst x y width height] returns sub-bitmap of [dst],
     at (x,y)-(x+width-1,y+height-1). *)

  val blit : t -> int -> int -> t -> int -> int -> int -> int -> unit
  (* [blit src sx sy dst dx dy width height] copies the rectangle
     region of [src] at (sx,sy)-(sx+width-1,sy+height-1) to [dst], at
     (dx,dy)-(dx+width-1,dy+height-1) *)
end