(* Use with lablgtk 2.x *)
(* As usual, simply launch 
   lablgtk2 <this file>
from a console *)
(* ------------------------------------------------------------- *)

(* a test color for checkouts *)
let colorYellow  = `NAME "yellow";;

(* a background pixmap and a moving pixmap *)
let (theRefBkgPixmap:(GDraw.pixmap option ref) ) = ref None;;
let (theRefMovingPixmap:(GDraw.pixmap option ref) ) = ref None;;

(*sizes*)
let (windowWidth,windowHeight) = (300,300);;
let (movingImgWidth,movingImgHeight) = (22,21);;

let stepRefCounter = ref 0;;
let stepXDiff = 10;;
let stepYDiff = 100;;

(* motion axes*)
let (baseX,baseY) = (10,20);;

(* memory of previous position of the moving image, 
 * useful for leaving everything in order when moving away
 *)
let optPastAnimXY = ref None;; 

(*can't see what an exposed area looks like? 
 * set to "true" to mark exposed areas so that you can't miss them :-) 
 *)

let advertiseExposedAreaFlag = false;; 

(* ------------------------------------------------------------- *)
open GMain;;


let window = GWindow.window ~width:windowWidth ~height:windowHeight ();;
let area = GMisc.drawing_area ~packing:window#add ();;

(*realize drawing areas as soon as possible*)
let (w:Gdk.window) = 
  (area#misc#realize (); 
   area#misc#window);;

let (theDrawing:GDraw.drawable) = new GDraw.drawable w;;

theRefBkgPixmap := Some (GDraw.pixmap_from_xpm "bkg.xpm" ());;

theRefMovingPixmap := Some (GDraw.pixmap_from_xpm "fly.xpm" ());;


(* background restoration callback *)
let redraw_on_exposure 
    ?(simulate = false) 
    (aDrawing:GDraw.drawable) 
    aExposedArea =

  match !theRefBkgPixmap with
  | None -> false
  | Some bkgpxm ->
      (   

       let exposedAreaX = (Gdk.Rectangle.x aExposedArea) in
       let exposedAreaY = (Gdk.Rectangle.y aExposedArea) in
       let exposedAreaWidth = (Gdk.Rectangle.width aExposedArea) in
       let exposedAreaHeight = (Gdk.Rectangle.height aExposedArea) in

       (* Hint given by Claude Marché; 
        * book area to redraw with respect to the clipping area 
        * that will be used by the animation function, 
        * otherwise the clipping mask for the moving image would 
        * only take care of the moving image *)
       let () = aDrawing#set_clip_rectangle aExposedArea in

       (*paste exposed areas back from the background pixmap*)
       (*use ~xsrc:0 ~ysrc:0 for checking the behaviour*)
       let () = aDrawing#put_pixmap 
           ~x:exposedAreaX 
           ~y:exposedAreaY 
           ~xsrc:exposedAreaX 
           ~ysrc:exposedAreaY 
           ~width:exposedAreaWidth 
           ~height:exposedAreaHeight 
           bkgpxm#pixmap
       in
       
       let () = 
         if ((advertiseExposedAreaFlag) && (not simulate)) then 
           (
            let () = aDrawing#set_foreground colorYellow in
            let () = aDrawing#set_line_attributes ~width:5 () in
            let () = aDrawing#lines 
                [(exposedAreaX,exposedAreaY);
                 ((exposedAreaX + exposedAreaWidth),(exposedAreaY));
                 ((exposedAreaX + exposedAreaWidth),(exposedAreaY + exposedAreaHeight));
                 ((exposedAreaX),(exposedAreaY + exposedAreaHeight));
                 ((exposedAreaX + exposedAreaWidth),(exposedAreaY));
                 (exposedAreaX,exposedAreaY);
                 ((exposedAreaX + exposedAreaWidth),(exposedAreaY + exposedAreaHeight))] in
            ()
           )
         else ()
       in
       (*
        * in GTK, a callback returning false means: 
        * "Continue until some signal handler returns TRUE, 
        * or until the top-level widget is reached"
        *)
       false 
      );;



(* animation callback *)
let move_on_expose (aDrawing:GDraw.drawable) _ = 
  match (!theRefBkgPixmap,!theRefMovingPixmap) with  
  | (Some bkgpxm, Some movpxm) ->
      (
       (*let's restore the background after passage, 
        * simulating exposure
        *)  
       let () = 
         match !optPastAnimXY with
         | Some (pastX,pastY) ->
             ignore (
             redraw_on_exposure 
               ~simulate:true
               aDrawing 
               (Gdk.Rectangle.create
                  ~x:pastX 
                  ~y:pastY 
                  ~width:movingImgWidth 
                  ~height:movingImgHeight)
            )
         | None -> () 
       in

       let newX = (windowWidth - 
                     ((baseX + 
                         (!stepRefCounter * stepXDiff)) mod 
                      (windowWidth + movingImgWidth))) in
       let newY = ((windowHeight - 50) -
                     (!stepRefCounter mod (windowHeight - baseY)) -  
                     (int_of_float 
                        (50. *. 
                           (sin 
                              (float_of_int 
                                 (!stepRefCounter * stepYDiff)))
                        ))
                  ) in
       
       (*set a mask for transparency; thanks to Claude Marché*)
       let () = 
         match movpxm#mask with 
         | None -> ()
         | Some m -> 
             (aDrawing#set_clip_origin ~x:newX ~y:newY;
              aDrawing#set_clip_mask m)
       in 
       let () = 
         aDrawing#put_pixmap 
           ~x:newX 
           ~y:newY 
           ~xsrc:0 
           ~ysrc:0  
           ~width:movingImgWidth 
           ~height:movingImgHeight 
           movpxm#pixmap
       in
       
       let () = incr stepRefCounter in

       let () = (optPastAnimXY := Some (newX,newY)) in
       
       false
      )
  | _ -> false
;;
        

let gui () =
  let () = ignore (window#connect#destroy ~callback:Main.quit) in 
  let () = ignore 
      (area#event#connect#expose 
         ~callback:
         (fun event -> redraw_on_exposure theDrawing (GdkEvent.Expose.area event))) in   

  (*timeout function from J.Garrigues' lablgtk example lissajous.ml*)
  let timeout_function _ = 
    (move_on_expose theDrawing () ;
     true) in 
  let () = ignore (Timeout.add ~ms:500 ~callback:timeout_function) in

  let () = window#show () in
  
  Main.main ();;

(* ------------------------------------------------------------- *)
(* Go! Now you can try covering and uncovering this window 
 * with others and see the fly keep flying unbothered >:-\ *)
let _ = gui ();;