Module:       gtk-duim
Synopsis:     GTK mirror implementation
Author:       Andy Armstrong, Scott McKay
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
              All rights reserved.
License:      Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND

/// GTK panes

define open abstract class <gtk-pane-mixin>
    (<standard-input-mixin>,
     <mirrored-sheet-mixin>)
end class <gtk-pane-mixin>;

// Returns #t, meaning that the port will take care of repainting
define method port-handles-repaint?
    (_port :: <gtk-port>, sheet :: <mirrored-sheet-mixin>)
 => (true? :: <boolean>)
  #t
end method port-handles-repaint?;


/// GTK mirrors

define open abstract class <gtk-mirror> (<mirror>)
  sealed slot mirror-sheet :: <sheet>,
    required-init-keyword: sheet:;
end class <gtk-mirror>;

define method initialize
    (mirror :: <gtk-mirror>, #key) => ()
  next-method();
  sheet-direct-mirror(mirror-sheet(mirror)) := mirror;
end method initialize;

define protocol <<gtk-mirror-protocol>> ()
  function make-gtk-mirror
    (sheet :: <abstract-sheet>) => (mirror :: <gtk-mirror>);
  function install-event-handlers
    (sheet :: <abstract-sheet>, mirror :: <gtk-mirror>) => ();
  function update-mirror-attributes
    (sheet :: <abstract-sheet>, mirror :: <gtk-mirror>) => ();
  function set-mirror-parent
    (mirror :: <gtk-mirror>, parent :: <gtk-mirror>) => ();
  function move-mirror
    (parent :: <gtk-mirror>, mirror :: <gtk-mirror>, 
     x :: <integer>, y :: <integer>)
 => ();
  function size-mirror
    (parent :: <gtk-mirror>, mirror :: <gtk-mirror>, 
     width :: <integer>, height :: <integer>)
 => ();
end protocol <<gtk-mirror-protocol>>;

define constant $mirror-widget-table :: <object-table> = make(<table>);

define sealed method do-make-mirror
    (_port :: <gtk-port>, sheet :: <sheet>)
 => (mirror :: <gtk-mirror>)
  let parent = sheet-device-parent(sheet);
  let mirror = make-gtk-mirror(sheet);
  install-event-handlers(sheet, mirror);
  update-mirror-attributes(sheet, mirror);
  set-mirror-parent(mirror, sheet-direct-mirror(parent));
  mirror
end method do-make-mirror;

define sealed method widget-mirror
    (widget :: <C-pointer>) => (mirror :: false-or(<gtk-mirror>))
  element($mirror-widget-table, pointer-address(widget), default: #f)
end method widget-mirror;

define sealed method widget-mirror-setter
    (mirror :: <gtk-mirror>, widget :: <C-pointer>)
 => (mirror :: <gtk-mirror>)
  element($mirror-widget-table, pointer-address(widget)) := mirror
end method widget-mirror-setter;

define sealed method widget-mirror-setter
    (mirror :: singleton(#f), widget :: <C-pointer>)
 => (mirror :: singleton(#f))
  remove-key!($mirror-widget-table, pointer-address(widget));
  #f
end method widget-mirror-setter;


/// Empty methods on non-window mirrors

define sealed method mirror-edges
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <gtk-mirror>)
 => (left :: <integer>, top :: <integer>, right :: <integer>, bottom :: <integer>)
  values(0, 0, 100, 100)	//--- kludge city
end method mirror-edges;

// The real methods are on more specific classes, such as <widget-mirror>
define sealed method set-mirror-edges
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <gtk-mirror>,
     left  :: <integer>, top    :: <integer>,
     right :: <integer>, bottom :: <integer>) => ()
  #f
end method set-mirror-edges;

// Ditto...
define sealed method map-mirror
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <gtk-mirror>) => ()
  #f
end method map-mirror;

// Ditto...
define sealed method unmap-mirror
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <gtk-mirror>) => ()
  #f
end method unmap-mirror;

// Ditto...
define sealed method destroy-mirror 
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <gtk-mirror>) => ()
  sheet-direct-mirror(sheet) := #f
end method destroy-mirror;

// Ditto...
define method install-event-handlers
    (sheet :: <sheet>, mirror :: <gtk-mirror>) => ()
  #f
end method install-event-handlers;

// Ditto...
define method update-mirror-attributes
    (sheet :: <sheet>, mirror :: <gtk-mirror>) => ()
  #f
end method update-mirror-attributes;


/// Mirror creation and destruction

define abstract class <widget-mirror> (<gtk-mirror>)
  sealed slot mirror-widget = #f,
    init-keyword: widget:;
  sealed slot %region :: <bounding-box>,
    required-init-keyword: region:;
end class <widget-mirror>;

define sealed domain make (singleton(<widget-mirror>));
define sealed domain initialize (<widget-mirror>);

define sealed inline method make
    (mirror :: subclass(<widget-mirror>), #rest args, #key sheet)
 => (mirror :: <widget-mirror>)
  let (left, top, right, bottom) = sheet-native-edges(sheet);
  apply(next-method, mirror,
	region: make-bounding-box(left, top, right, bottom),
	args)
end method make;

define method initialize
    (mirror :: <widget-mirror>, #key) => ()
  next-method();
  let widget = mirror-widget(mirror);
  when (widget)
    widget-mirror(widget) := mirror
  end
end method initialize;

define sealed method destroy-mirror 
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <widget-mirror>) => ()
  let widget = mirror-widget(mirror);
  mirror-widget(mirror) := #f;
  ignoring("destroy-mirror")
end method destroy-mirror;

//---*** WHAT ABOUT THIS?  WHO IS SUPPOSED TO CALL IT?
// Called by main WM_DESTROY handler
define sealed method note-mirror-destroyed
    (sheet :: <sheet>, mirror :: <widget-mirror>) => ()
  ignoring("note-mirror-destroyed")
  // let handle :: <HWND> = window-handle(mirror);
  // window-mirror(handle) := #f;
  // window-handle(mirror) := $NULL-HWND
end method note-mirror-destroyed;


/// Mirror manipulation

// For non-top-level sheets, we just show the window
define sealed method map-mirror
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <widget-mirror>) => ()
  let widget = mirror-widget(mirror);
  duim-debug-message("Showing %=", sheet);
  gtk-widget-show(widget)
end method map-mirror;

define sealed method unmap-mirror
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <widget-mirror>) => ()
  let widget = mirror-widget(mirror);
  gtk-widget-hide(widget)
end method unmap-mirror;

define sealed method raise-mirror 
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <widget-mirror>,
     #key activate? = #t)
 => ()
  if (activate?)
    ignoring("activate? keyword to raise-mirror")
  end;
  let widget = mirror-widget(mirror);
  gdk-window-raise(widget.GtkWidget-window)
end method raise-mirror;

define sealed method lower-mirror
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <widget-mirror>) => ()
  let widget = mirror-widget(mirror);
  gdk-window-lower(widget.GtkWidget-window)
end method lower-mirror;

define sealed method mirror-visible? 
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <widget-mirror>)
 => (visible? :: <boolean>)
  let widget = mirror-widget(mirror);
  gdk-window-is-visible(widget.GtkWidget-window) == $false
end method mirror-visible?;


/// Window mirrors

define sealed method mirror-edges
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <widget-mirror>)
 => (left :: <integer>, top :: <integer>, right :: <integer>, bottom :: <integer>)
  box-edges(mirror.%region)
end method mirror-edges;

define sealed method set-mirror-edges
    (_port :: <gtk-port>, sheet :: <sheet>, mirror :: <widget-mirror>,
     left  :: <integer>, top    :: <integer>,
     right :: <integer>, bottom :: <integer>)
 => ()
  let parent = sheet-device-parent(sheet);
  let parent-mirror = sheet-direct-mirror(parent);
  let width  = right - left;
  let height = bottom - top;
  let old-region = mirror.%region;
  let (old-left, old-top)     = box-position(old-region);
  let (old-width, old-height) = box-size(old-region);
  mirror.%region := set-box-edges(mirror.%region, left, top, right, bottom);
  if (left ~== old-left | top ~== old-top)
    move-mirror(parent-mirror, mirror, left, top)
  end;
  if (width ~== old-width | height ~== old-height)
    size-mirror(parent-mirror, mirror, width, height)
  end
end method set-mirror-edges;


// Returns the position of the sheet in "absolute" (screen) coordinates
define sealed method sheet-screen-position
    (_port :: <gtk-port>, sheet :: <sheet>)
 => (x :: <integer>, y :: <integer>)
  let ancestor  = sheet-device-parent(sheet);
  let transform = sheet-delta-transform(sheet, ancestor);
  // Get the position of the sheet in its mirrored parent's coordinates
  let (x, y) = transform-position(transform, 0, 0);
  let mirror = sheet-direct-mirror(ancestor);
  client-to-screen-position(mirror, x, y)
end method sheet-screen-position;

// Given a position (x, y) within a mirror, convert it to a position on the screen
define sealed method client-to-screen-position
    (mirror :: <widget-mirror>, x :: <integer>, y :: <integer>)
 => (screen-x :: <integer>, screen-y :: <integer>)
  ignoring("client-to-screen-position");
  values(x, y)
end method client-to-screen-position;


/// Fixed container mirrors
///
/// The class of mirror that can contain other mirrors

define class <fixed-container-mirror> (<widget-mirror>)
end class <fixed-container-mirror>;

define class <drawing-area-mirror> (<widget-mirror>)
end class <drawing-area-mirror>;

define method make-gtk-mirror 
    (sheet :: <mirrored-sheet-mixin>)
=> (mirror :: <widget-mirror>)
  do-make-gtk-mirror(sheet)
end method make-gtk-mirror;

define method do-make-gtk-mirror 
    (sheet :: <mirrored-sheet-mixin>)
=> (mirror :: <widget-mirror>)
  let widget = GTK-FIXED(gtk-fixed-new());
  //---*** We really want to switch this off entirely...
  gtk-container-set-resize-mode(widget, $GTK-RESIZE-QUEUE);
  make(<fixed-container-mirror>,
       widget: widget,
       sheet:  sheet)
end method do-make-gtk-mirror;

define method do-make-gtk-mirror
    (sheet :: <standard-repainting-mixin>)
  => (mirror :: <widget-mirror>)
  let widget = GTK-DRAWING-AREA(gtk-drawing-area-new());
//  gtk-drawing-area-size(widget, 200, 200);
  gtk-widget-set-size-request(GTK-WIDGET(widget), 200, 200);
  make(<drawing-area-mirror>,
       widget: widget,
       sheet:  sheet);
end method do-make-gtk-mirror;

define method install-event-handlers
    (sheet :: <mirrored-sheet-mixin>, mirror :: <fixed-container-mirror>) => ()
  next-method();
  install-named-handlers(mirror, #[#"expose_event"])
end method install-event-handlers;

define method install-event-handlers
    (sheet :: <mirrored-sheet-mixin>, mirror :: <drawing-area-mirror>) => ()
  next-method();
  install-named-handlers(mirror, #[#"expose_event", #"button_press_event", #"button_release_event", #"motion_notify_event"])
end method install-event-handlers;

define sealed method handle-gtk-expose-event
    (sheet :: <mirrored-sheet-mixin>, widget :: <GtkWidget*>,
     event :: <GdkEventExpose*>)
 => (handled? :: <boolean>)
  let area   = event.GdkEventExpose-area;
  let x      = area.GdkRectangle-x;
  let y      = area.GdkRectangle-y;
  let width  = area.GdkRectangle-width;
  let height = area.GdkRectangle-height;
  let region = make-bounding-box(x, y, x + width, y + height);
  duim-debug-message("Repainting %=: %d, %d %d x %d",
		     sheet, x, y, width, height);
  // We call 'handle-event' instead of 'distribute-event' because we
  // want the repainting to happen between BeginPaint and EndPaint
  handle-event(sheet,
	       make(<window-repaint-event>,
		    sheet: sheet,
		    region: region))
end method handle-gtk-expose-event;

define method set-mirror-parent
    (child :: <widget-mirror>, parent :: <fixed-container-mirror>)
 => ()
  let (x, y) = sheet-native-edges(mirror-sheet(child));
  gtk-fixed-put(mirror-widget(parent),
		mirror-widget(child),
		x, y)
end method set-mirror-parent;

/*
define method set-mirror-parent
    (child :: <popup-menu-mirror>, parent :: <display-mirror>)
 => ()
   gtk-container-add(GTK-CONTAINER(mirror-widget(parent)),
		    mirror-widget(child))
end;
*/

define method move-mirror
    (parent :: <fixed-container-mirror>, child :: <widget-mirror>,
     x :: <integer>, y :: <integer>)
 => ()
  gtk-fixed-move(mirror-widget(parent),
		 mirror-widget(child),
		 x, y)
end method move-mirror;

define method size-mirror
    (parent :: <fixed-container-mirror>, child :: <widget-mirror>,
     width :: <integer>, height :: <integer>)
 => ()
  ignore(parent);
  set-mirror-size(child, width, height)
end method size-mirror;

define method set-mirror-size
    (mirror :: <widget-mirror>, width :: <integer>, height :: <integer>)
 => ()
  let widget = mirror.mirror-widget;
  let (left, top) = box-position(mirror.%region);
  with-stack-structure (allocation :: <GtkAllocation*>)
    allocation.GdkRectangle-x      := left;
    allocation.GdkRectangle-y      := top;
    allocation.GdkRectangle-width  := width;
    allocation.GdkRectangle-height := height;
    gtk-widget-size-allocate(widget, allocation)
  end
  // ---*** debugging code
//  let (new-width, new-height) = widget-size(widget);
//  if (new-width ~== width | new-height ~== height)
//    duim-debug-message("mirror not resized!: %= wanted: %d x %d, but still: %d x %d", mirror.mirror-sheet, width, height, new-width, new-height);
//  end;
end method set-mirror-size;

define method set-mirror-size
    (mirror :: <drawing-area-mirror>, width :: <integer>, height :: <integer>)
 => ()
//  gtk-drawing-area-size(mirror-widget(mirror), width, height);
  gtk-widget-set-size-request(mirror-widget(mirror), width, height);
end method set-mirror-size;