l4/pkg/ocaml/ocaml/contrib/otherlibs/labltk/tkanim/tkanim.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16 open Camltk
  17 open Widget
  18 open Support
  19 open Protocol
  20 open Tkintf
  21
  22 external init : unit -> unit = "tkanim_init"
  23
  24 type gifFrame = {
  25   imagephoto : imagePhoto;
  26   frameWidth : int;
  27   frameHeight : int;
  28   left : int;
  29   top : int;
  30   delay : int
  31  }
  32
  33 type animatedGif = {
  34   frames : gifFrame list;
  35   animWidth : int;
  36   animHeight : int;
  37   loop : int
  38 }
  39
  40 type imageType =
  41   | Still of Tk.options
  42   | Animated of animatedGif
  43
  44 let debug = ref false
  45
  46 let cTKtoCAMLgifFrame s =
  47   match splitlist s with
  48   | [photo; width; height; left; top; delay] ->
  49       {imagephoto = cTKtoCAMLimagePhoto photo;
  50        frameWidth = int_of_string width;
  51        frameHeight = int_of_string height;
  52        left = int_of_string left;
  53        top = int_of_string top;
  54        delay = int_of_string delay}
  55   | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s))
  56
  57 let cTKtoCAMLanimatedGif s =
  58   match splitlist s with
  59   | [width; height; frames; loop] ->
  60       {frames = List.map cTKtoCAMLgifFrame (splitlist frames);
  61        animWidth = int_of_string width;
  62        animHeight = int_of_string height;
  63        loop = int_of_string loop}
  64   | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s))
  65
  66 (* check Tkanim package is in the interpreter *)
  67 let available () =
  68   let packages =
  69     splitlist (Protocol.tkEval [| TkToken "package";
  70                                   TkToken "names" |])
  71   in
  72   List.mem "Tkanim" packages
  73
  74 let create file =
  75   let s =
  76     Protocol.tkEval [| TkToken "animation";
  77                        TkToken "create";
  78                        TkToken file |]
  79   in
  80   let anmgif = cTKtoCAMLanimatedGif s in
  81   match anmgif.frames with
  82   | [] -> raise (TkError "Null frame in a gif ?")
  83   | [x] -> Still (ImagePhoto x.imagephoto)
  84   | _ -> Animated anmgif
  85
  86 let delete anim =
  87   List.iter (fun {imagephoto = i} -> Imagephoto.delete i) anim.frames
  88
  89 let width anm = anm.animWidth
  90 let height anm = anm.animHeight
  91 let images anm = List.map (fun x -> x.imagephoto) anm.frames
  92
  93 let image_existence_check img =
  94   (* I found there is a bug in Tk (even v8.0a2).                        *)
  95   (* We can copy from deleted images, Tk never says "it doesn't exist", *)
  96   (* But just do some operation. And sometimes it causes Seg-fault.     *)
  97   (* So, before using Imagephoto.copy, I should check the source image  *)
  98   (* really exists. *)
  99   try ignore (Imagephoto.height img) with
 100     TkError s -> prerr_endline ("tkanim: " ^ s); raise (TkError s)
 101
 102 let imagephoto_copy dst src opts =
 103   image_existence_check src;
 104   Imagephoto.copy dst src opts
 105
 106 let animate_gen w i anim =
 107   let length = List.length anim.frames in
 108   let frames = Array.of_list anim.frames in
 109   let current = ref 0 in
 110   let loop = ref anim.loop in
 111   let f = frames.(!current) in
 112     imagephoto_copy i f.imagephoto
 113       [ImgTo (f.left, f.top, f.left + f.frameWidth,
 114                              f.top + f.frameHeight)];
 115   let visible = ref true in
 116   let animated = ref false in
 117   let timer = ref None in
 118   (* Loop *)
 119   let display_current () =
 120     let f = frames.(!current) in
 121       imagephoto_copy i f.imagephoto
 122         [ImgTo (f.left, f.top,
 123                 f.left + f.frameWidth, f.top + f.frameHeight)]
 124   in
 125   let rec tick () =
 126     if not (Winfo.exists w && Winfo.viewable w) then begin
 127       (* the widget is invisible. stop animation for efficiency *)
 128       if !debug then prerr_endline "Stopped (Visibility)";
 129       visible := false;
 130     end else
 131       begin
 132         display_current ();
 133         let t =
 134           Timer.add (if f.delay = 0 then 100 else f.delay * 10)
 135             (fun () ->
 136                incr current;
 137                if !current = length then begin
 138                  current := 0;
 139                  (* loop check *)
 140                  if !loop > 1 then begin
 141                    decr loop;
 142                    if !loop = 0 then begin
 143                      if !debug then prerr_endline "Loop end";
 144                      (* stop *)
 145                      loop := anim.loop;
 146                      timer := None
 147                    end
 148                  end
 149                end;
 150                tick ())
 151         in
 152           timer := Some t
 153       end
 154   in
 155   let start () =
 156     animated := true;
 157     tick ()
 158   in
 159   let stop () =
 160     match !timer with
 161     | Some t ->
 162         Timer.remove t;
 163         timer := None;
 164         animated := false
 165     | None -> ()
 166   in
 167   let next () =
 168     if !timer = None then begin
 169       incr current;
 170       if !current = length then current := 0;
 171       display_current ()
 172     end
 173   in
 174     (* We shouldn't delete the animation here. *)
 175 (*
 176     bind w [[], Destroy]
 177       (BindSet ([], (fun _ -> Imagephoto.delete i)));
 178 *)
 179     bind w [[], Visibility]
 180       (BindSet ([], (fun _ ->
 181         if not !visible then begin
 182           visible := true;
 183           if !animated then start ()
 184         end)));
 185     (function
 186      | false ->
 187          if !animated then stop () else start ()
 188      | true -> next ())
 189
 190 let animate label anim =
 191   (*  prerr_endline "animate"; *)
 192   let i = Imagephoto.create [Width (Pixels anim.animWidth);
 193                              Height (Pixels anim.animHeight)]
 194   in
 195     bind label [[], Destroy] (BindExtend ([], (fun _ ->
 196       Imagephoto.delete i)));
 197     Label.configure label [ImagePhoto i];
 198     animate_gen label i anim
 199
 200 let animate_canvas_item canvas tag anim =
 201 (*  prerr_endline "animate"; *)
 202   let i = Imagephoto.create [Width (Pixels anim.animWidth);
 203                              Height (Pixels anim.animHeight)]
 204   in
 205     bind canvas [[], Destroy] (BindExtend ([], (fun _ ->
 206       Imagephoto.delete i)));
 207     Canvas.configure_image canvas tag [ImagePhoto i];
 208     animate_gen canvas i anim
 209
 210 let gifdata s =
 211   let tmp_dir = ref Filename.temp_dir_name in
 212   let mktemp =
 213     let cnter = ref 0
 214     and pid = Unix.getpid() in
 215       (function prefx ->
 216                incr cnter;
 217                (Filename.concat !tmp_dir
 218                (prefx ^ string_of_int pid ^ "." ^ string_of_int !cnter)))
 219   in
 220     let fname = mktemp "gifdata" in
 221     let oc = open_out_bin fname in
 222       try
 223         output_string oc s;
 224         close_out oc;
 225         let anim = create fname in
 226           Unix.unlink fname;
 227           anim
 228       with
 229         e -> begin Unix.unlink fname; raise e end
 230