external rawget : string -> bytes

    = "camltk_getimgdata"

external rawset : string -> bytes -> int -> int -> int -> int -> unit

    = "camltk_setimgdata_bytecode"  (* all int parameters MUST be positive *)

      "camltk_setimgdata_native"

type t = {

  pixmap_width : int;

  pixmap_height: int;

  pixmap_data: bytes

}

let (.![]<-) = Bytes.set

type pixel = string  (* 3 chars *)

(* pixmap will be an abstract type *)

let width pix = pix.pixmap_width

let height pix = pix.pixmap_height

(* note: invalid size would have been caught by Bytes.create, but we put

 * it here for documentation purpose *)

let create w h =

  if w < 0 || h < 0 then invalid_arg "invalid size"

  else {

    pixmap_width = w;

    pixmap_height = h;

    pixmap_data = Bytes.create (w * h * 3);

  }

(*

 * operations on pixmaps

 *)

let unsafe_copy pix_from pix_to =

  Bytes.unsafe_blit pix_from.pixmap_data 0

                     pix_to.pixmap_data 0

                     (Bytes.length pix_from.pixmap_data)

(* We check only the length. w,h might be different... *)

let copy pix_from pix_to =

  let l = Bytes.length pix_from.pixmap_data in

  if l <> Bytes.length pix_to.pixmap_data then

    raise (Invalid_argument "copy: incompatible length")

  else unsafe_copy pix_from pix_to

(* Pixel operations *)

let unsafe_get_pixel pixmap x y =

  let pos = (y * pixmap.pixmap_width + x) * 3 in

  Bytes.sub_string pixmap.pixmap_data pos 3

let unsafe_set_pixel pixmap x y pixel =

  let pos = (y * pixmap.pixmap_width + x) * 3 in

  Bytes.unsafe_blit (Bytes.unsafe_of_string pixel) 0 pixmap.pixmap_data pos 3

(* To get safe operations, we can either check x,y wrt [0,w[ and [0,h[

   or rely on blit checking. We choose the first for clarity.

 *)

let get_pixel pix x y =

  if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height

  then invalid_arg "invalid pixel"

  else unsafe_get_pixel pix x y

(* same check (pixel being abstract, it must be of good size *)

let set_pixel pix x y pixel =

  if x < 0 || y < 0 || x >= pix.pixmap_width || y >= pix.pixmap_height

  then invalid_arg "invalid pixel"

  else unsafe_set_pixel pix x y pixel

(* black as default_color, if at all needed *)

let default_color = "\000\000\000"

(* Char.chr does range checking *)

let pixel r g b =

  let s = Bytes.create 3 in

  s.![0] <- Char.chr r;

  s.![1] <- Char.chr g;

  s.![2] <- Char.chr b;

  Bytes.unsafe_to_string s

##ifdef CAMLTK

(* create pixmap from an existing image *)

let get photo =

  match photo with

  | PhotoImage s -> {

      pixmap_width = CImagephoto.width photo;

      pixmap_height = CImagephoto.height photo;

      pixmap_data = rawget s;

    }

(* copy a full pixmap into an image *)

let set photo pix =

  match photo with

  | PhotoImage s ->

      rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height

(* general blit of pixmap into image *)

let blit photo pix x y w h =

  if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument"

  else match photo with

  | PhotoImage s ->

      rawset s pix.pixmap_data x y w h

(* get from a file *)

let from_file filename =

  let img = CImagephoto.create [File filename] in

  let pix = get img in

  CImagephoto.delete img;

  pix

##else

(* create pixmap from an existing image *)

let get photo =

  match photo with

  | `Photo s -> {

      pixmap_width = Imagephoto.width photo;

      pixmap_height = Imagephoto.height photo;

      pixmap_data = rawget s;

    }

(* copy a full pixmap into an image *)

let set photo pix =

  match photo with

  | `Photo s -> rawset s pix.pixmap_data 0 0 pix.pixmap_width pix.pixmap_height

(* general blit of pixmap into image *)

let blit photo pix x y w h =

  if x < 0 || y < 0 || w < 0 || h < 0 then invalid_arg "negative argument"

  else match photo with

  | `Photo s -> rawset s pix.pixmap_data x y w h

(* get from a file *)

let from_file filename =

  let img = Imagephoto.create ~file: filename () in

  let pix = get img in

  Imagephoto.delete img;

  pix

##endif