1 files changed, 142 insertions, 0 deletions
diff --git a/ocaml-binary-annot/otherlibs/labltk/builtin/rawimg.ml b/ocaml-binary-annot/otherlibs/labltk/builtin/rawimg.ml
new file mode 100644
index 0000000000..6bd0ad2838
--- /dev/null
+++ b/ocaml-binary-annot/otherlibs/labltk/builtin/rawimg.ml
@@ -0,0 +1,142 @@
+external rawget : string -> string
+    = "camltk_getimgdata"
+external rawset : string -> string -> 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: string
+}
+
+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 String.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 = String.create (w * h * 3);
+  }
+
+(*
+ * operations on pixmaps
+ *)
+let unsafe_copy pix_from pix_to =
+  String.unsafe_blit pix_from.pixmap_data 0
+                     pix_to.pixmap_data 0
+                     (String.length pix_from.pixmap_data)
+
+(* We check only the length. w,h might be different... *)
+let copy pix_from pix_to =
+  let l = String.length pix_from.pixmap_data in
+  if l <> String.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
+  let r = String.create 3 in
+  String.unsafe_blit pixmap.pixmap_data pos r 0 3;
+  r
+
+let unsafe_set_pixel pixmap x y pixel =
+  let pos = (y * pixmap.pixmap_width + x) * 3 in
+  String.unsafe_blit 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 = String.create 3 in
+  s.[0] <- Char.chr r;
+  s.[1] <- Char.chr g;
+  s.[2] <- Char.chr b;
+  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