lablGL/glPix.ml

   1 (* $Id: glPix.ml,v 1.10 2005-10-14 13:35:32 garrigue Exp $ *)
   2
   3 open Gl
   4
   5 type ('a,'b) t = { format: 'a ; width: int ; height:int ; raw: 'b Raw.t }
   6
   7 let create k ~format ~width ~height =
   8   let size = format_size format * width * height in
   9   let len = match k with `bitmap -> (size-1)/8+1 | #Gl.real_kind -> size in
  10   let raw = Raw.create k ~len in
  11   { format = format; width = width; height = height; raw = raw }
  12
  13 let of_raw raw ~format ~width ~height =
  14   let size = format_size format * width * height
  15   and len = Raw.length raw in
  16   let len =
  17     match Raw.kind raw with `bitmap -> len * 8 | #Gl.real_kind -> len in
  18   if size > len then invalid_arg "GlPix.of_raw";
  19   { format = format; width = width; height = height; raw = raw }
  20
  21 let to_raw img = img.raw
  22 let format img = img.format
  23 let width img = img.width
  24 let height img = img.height
  25
  26 let raw_pos img =
  27   let width =
  28     match Raw.kind img.raw with `bitmap -> (img.width-1)/8+1
  29     | #Gl.real_kind -> img.width
  30   in
  31   let stride = format_size img.format in
  32   let line = stride * width in
  33   fun ~x ~y -> x * stride + y * line
  34
  35 external bitmap :
  36     width:int -> height:int -> orig:point2 -> move:point2 ->
  37     [`bitmap] Raw.t -> unit
  38     = "ml_glBitmap"
  39 type bitmap = ([`color_index], [`bitmap]) t
  40 let bitmap (img : bitmap) =
  41   bitmap ~width:img.width ~height:img.height img.raw
  42
  43 external copy :
  44     x:int -> y:int -> width:int -> height:int ->
  45     buffer:[`color|`depth|`stencil] -> unit
  46     = "ml_glCopyPixels"
  47
  48 external draw :
  49     width:int -> height:int -> format:[< format] -> [< Gl.kind] Raw.t -> unit
  50     = "ml_glDrawPixels"
  51 let draw img =
  52   draw img.raw ~width:img.width ~height:img.height ~format:img.format
  53
  54 type map =
  55     [`i_to_i|`i_to_r|`i_to_g|`i_to_b|`i_to_a
  56     |`s_to_s|`r_to_r|`g_to_g|`b_to_b|`a_to_a]
  57 external map : map -> [`float] Raw.t -> unit
  58     = "ml_glPixelMapfv"
  59
  60 type store_param = [
  61     `pack_swap_bytes of bool
  62   | `pack_lsb_first of bool
  63   | `pack_row_length of int
  64   | `pack_skip_pixels of int
  65   | `pack_skip_rows of int
  66   | `pack_alignment of int
  67   | `unpack_swap_bytes of bool
  68   | `unpack_lsb_first of bool
  69   | `unpack_row_length of int
  70   | `unpack_skip_pixels of int
  71   | `unpack_skip_rows of int
  72   | `unpack_alignment of int
  73 ]
  74 external store : store_param -> unit = "ml_glPixelStorei"
  75
  76 type transfer_param = [
  77     `map_color of bool
  78   | `map_stencil of bool
  79   | `index_shift of int
  80   | `index_offset of int
  81   | `red_scale of float
  82   | `red_bias of float
  83   | `green_scale of float
  84   | `green_bias of float
  85   | `blue_scale of float
  86   | `blue_bias of float
  87   | `alpha_scale of float
  88   | `alpha_bias of float
  89   | `depth_scale of float
  90   | `depth_bias of float
  91 ]
  92 external transfer : transfer_param -> unit = "ml_glPixelTransfer"
  93
  94 external zoom : x:float -> y:float -> unit = "ml_glPixelZoom"
  95
  96 external raster_pos :
  97     x:float -> y:float -> ?z:float -> ?w:float -> unit -> unit
  98     = "ml_glRasterPos"
  99
 100 external read :
 101     x:int -> y:int -> width:int -> height:int ->
 102     format:[< format] -> [< Gl.kind] Raw.t -> unit
 103     = "ml_glReadPixels_bc" "ml_glReadPixels"
 104 let read ~x ~y ~width ~height ~format ~kind =
 105   let raw = Raw.create kind ~len:(width * height * format_size format) in
 106   read ~x ~y ~width ~height ~format raw;
 107   { raw = raw; width = width; height = height; format = format }