Lablgtk 1.2

(*CUT HERE*)

(* Use with lablgtk 1.2.x *)
(* As usual, simply launch 
   lablgtk <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:[ `window] 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:[ `window] 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:[ `window] 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 ();;
(*CUT HERE*)

Lablgtk 2

(*CUT HERE*)

(* Use with lablgtk 2.x *)
(* As usual, simply launch 
   lablgtk2 
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 ();;
(*CUT HERE*)