root/ocaml-remix/trunk/FB.ml

type buffer_raw;;
type buffer = (buffer_raw * int * int);;

external create_raw : int -> int -> buffer_raw = "c_FB_new_buffer";;
external free_raw : buffer_raw -> unit = "c_FB_free_buffer";;
external fill_raw : buffer_raw -> int -> int -> (int -> float) -> unit =
      "c_FB_fill_buffer";;
external fill_from_raw : buffer_raw -> int -> buffer_raw -> int -> int -> unit =
      "c_FB_fill_buffer_from_buffer";;
external add_raw : buffer_raw -> buffer_raw -> int -> buffer_raw =
      "c_FB_add_buffers";;
external mult_raw : buffer_raw -> buffer_raw -> int -> buffer_raw = 
      "c_FB_mult_buffers";;
external at_raw : buffer_raw -> int -> float = "c_FB_at";;
external short_at_raw : buffer_raw -> int -> int = "c_FB_short_at";;
external split_raw : buffer_raw -> buffer_raw array -> int -> unit = 
      "c_FB_split_into_channels";;
external merge_raw : buffer_raw array -> buffer_raw -> int -> unit =
      "c_FB_merge_channels";;
external blit_raw : buffer_raw -> int -> buffer_raw -> int -> int -> unit =
      "c_FB_blit";;
external transparency_raw : buffer_raw -> buffer_raw -> buffer_raw -> int ->
      buffer_raw = "c_FB_transparency";;
external average_raw : buffer_raw array -> int -> buffer_raw = "c_FB_average";;

exception ChannelsMismatch;;
exception BlitOutOfBounds;;

let create l c = (create_raw l c, l, c);;
let free (b,l,c) = free_raw b;;
let fill (b,l,c) f = fill_raw b l c f;;
let fill_from_buffer (b,l,c) (bf,lf,cf) o = 
  if c != cf then raise ChannelsMismatch;
  fill_from_raw b (l*c) bf (lf*cf) (o*c);;
let add (b1,l1,c1) (b2,l2,c2) = 
  if c1 != c2 then raise ChannelsMismatch;
  let l = min l1 l2 in (add_raw b1 b2 (l*c1), l, c1);;
let mult (b1,l1,c1) (b2,l2,c2) = 
  if c1 != c2 then raise ChannelsMismatch;
  let l = min l1 l2 in (mult_raw b1 b2 (l*c1), l, c1);;
let at (b,l,c) p = at_raw b p;;
let short_at (b,l,c) p = short_at_raw b p;;
let split (b,l,c) =
  let raw_arr = Array.init c (fun i -> create_raw l 1) in
  split_raw b raw_arr l;
  Array.init c (fun i -> (raw_arr.(i), l, 1));;
let merge arr = 
  let raw_arr = Array.init (Array.length arr) 
    (fun i -> (match arr.(i) with | (b,_,_) -> b)) in
  let len = (match arr.(0) with | (_,l,_) -> l) in
  let out_arr = create_raw len (Array.length arr) in
  merge_raw raw_arr out_arr len;
  (out_arr, len, (Array.length arr));;
let blit (bs, ls, cs) spos (bd, ld, cd) dpos len =
  if cs != cd then raise ChannelsMismatch;
  if spos < 0 then raise BlitOutOfBounds;
  if dpos < 0 then raise BlitOutOfBounds;
  if (spos + len) > ls then raise BlitOutOfBounds;
  if (dpos + len) > ld then raise BlitOutOfBounds;
  blit_raw bs (spos * cs) bd (dpos * cd) (len * cd);;
let transparency (b1,l1,c1) (b2,l2,c2) (bt,lt,ct) =
  if c1 != c2 then raise ChannelsMismatch;
  if c1 != ct then raise ChannelsMismatch;
  let len = min (min l1 l2) lt in
  (transparency_raw b1 b2 bt (len * c1), len, c1);;
let average arr =
  let raw_arr = Array.init (Array.length arr)
    (fun i -> (match arr.(i) with | (b,_,_) -> b)) in
  let (len,chans) = (match arr.(0) with | (_,l,c) -> (l,c)) in
  (average_raw raw_arr (len * chans), len, chans);;
let length (b,l,c) = l;;
let size (b,l,c) = l * c;;

let fun_cache = ref [];;
let create_with_caching func period length channels offset =
  let b = create length channels in
  (
    try 
      let r = List.assoc (func, channels) (!fun_cache) in
      fill_from_buffer b r offset
    with Not_found -> 
    (
      let cache = create period channels in
      fill cache func;
      fill_from_buffer b cache offset;
      fun_cache := ((func, channels), cache)::(!fun_cache)
    )
  );
  b;;