[mcclim-cvs] CVS mcclim/Backends/gtkairo - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

23 Apr 2006

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo
In directory clnet:/tmp/cvs-serv4775
Modified Files:
    BUGS cairo-ffi.lisp event.lisp frame-manager.lisp gadgets.lisp 
    gtk-ffi.lisp medium.lisp 
Log Message:
* medium.lisp (TEXT-STYLE-HEIGHT): McCLIM wants height = ascent + descent.
Make it so.
* cairo-ffi.lisp (*CAIRO-ERROR-MODE*, DEF-CAIRO-FUN): New variable and
macro for cairo_status checking.  (CAIRO_*): Use def-cairo-fun for
(nearly) all functions taking a cairo context as an argument.
* gtk-ffi.lisp (gtkscrolltype): New enum.  (gtk_range_set_adjustment,
gtk_adjustment_get_value, gtk_adjustment_set_value): New functions.
* gadgets.lisp (GTK-CHECK-BUTTON, GTK-RADIO-BUTTON, GTK-VSCALE,
GTK-HSCALE, GTK-VSCROLLBAR, GTK-HSCROLLBAR): Subclass the abstract
gadgets directly.  (NATIVE-SLIDER, NATIVE-SCROLLBAR): New class.
(CLIMI::SHOW-VALUE-P, CLIMI::DECIMAL-PLACES, CLIMI::NUMBER-OF-QUANTA):
New accessors.  (HANDLE-REPAINT): Removed.  (MAKE-GADGET-EVENT):
Removed.  (SCROLLBAR-CHANGE-VALUE-EVENT, MAGIC-GADGET-EVENT): New
classes.  (MAKE-SCALE): Set initial adjustment value.  (MAKE-SCROLLBAR):
Compute page size from thumb-size.  Set step and page increments to
zero.  Set initial adjustment value.  (CONNECT-NATIVE-SIGNALS): Replaced
clicked-handler with magic-clicked-handler; collapsed identical methods.
((CONNECT-NATIVE-SIGNALS NATIVE-SCROLLBAR)): Establish change-value
handler.  (HANDLE-EVENT): Replaced gadget-event with magic-gadget-event;
collapsed identical methods.  ((HANDLE-EVENT
SCROLLBAR-CHANGE-VALUE-EVENT)): New method.
(UPDATE-SCROLLBAR-ADJUSTMENT): New function.  ((SETF GADGET-MIN-VALUE),
(SETF GADGET-MAX-VALUE), (SETF GADGET-VALUE), (SETF
CLIMI::SCROLL-BAR-VALUES)): New methods on native-scrollbar.
((REALIZE-NATIVE-WIDGET GTK-CHECK-BUTTON), (REALIZE-NATIVE-WIDGET
GTK-RADIO-BUTTON)): Set initial value.
* event.lisp (DEFINE-SIGNAL): Let callers specify return-type and
arguments.  (CLICKED-HANDLER): Renamed to magic-clicked-handler.  Make
an instance of magic-gadget-event.  (SCROLLBAR-CHANGE-VALUE-HANDLER):
New function.

--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS	2006/04/23 10:42:39	1.3
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS	2006/04/23 17:36:28	1.4
@@ -18,13 +18,13 @@
     Colored buttons (clim-fig) are missing.
5b.
-    the slider is not quite right.
+    the slider needs tick marks
-(WORK IN PROGRESS) 5c.
+(FIXED) 5c.
     Inheriting from the standard gadget panes is bogus anyway, we should
     build them from scratch.
-5d.
+(FIXED) 5d.
     Default gadget values aren't being used.
6.
@@ -76,5 +76,10 @@
 14.
     Climacs doesn't draw itself until the window is resized.
-15.
+(FIXED) 15.
     The text cursor does not show the correct vertical position in climacs.
+
+16.
+    Scroll panes are now native widgets, but don't really behave.  The
+    scroll test works a little, many other examples don't.  See comment
+    in update-scrollbar-adjustment.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp	2006/04/23 10:42:39	1.2
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp	2006/04/23 17:36:28	1.3
@@ -25,6 +25,29 @@
 (in-package :clim-gtkairo)
+(defvar *cairo-error-mode* :warn
+  "NIL, :WARN, or :BREAK.")
+
+(defmacro def-cairo-fun (name rtype &rest args)
+  (let* ((str (string-upcase name))
+	 (actual (intern (concatenate 'string "%-" str) :clim-gtkairo))
+	 (wrapper (intern str :clim-gtkairo))
+	 (argnames (mapcar #'car args)))
+    `(progn
+       (cffi:defcfun (,name ,actual)
+	   ,rtype
+	 ,@args)
+       (defun ,wrapper ,argnames
+	 (multiple-value-prog1
+	     (,actual ,@argnames)
+	   (when *cairo-error-mode*
+	     (let ((status (cairo_status ,(car argnames))))
+	       (unless (eq status :success)
+		 (warn "~A returned with status ~A" ,name status))
+	       (when (eq *cairo-error-mode* :break)
+		 (break)))))))))
+
+
 ;; user-visible structures
(cffi:defcstruct cairo_text_extents
@@ -125,11 +148,11 @@
     :void
   (cr :pointer))
-(defcfun "cairo_save"
+(def-cairo-fun "cairo_save"
     :void
   (cr :pointer))
-(defcfun "cairo_restore"
+(def-cairo-fun "cairo_restore"
     :void
   (cr :pointer))
@@ -156,21 +179,21 @@
 ;;;  (height :int)
 ;;;  (stride :int))
-(defcfun "cairo_set_operator"
+(def-cairo-fun "cairo_set_operator"
     :void
   (cr :pointer)
   (op cairo_operator))
;;; Colors
-(defcfun "cairo_set_source_rgb"
+(def-cairo-fun "cairo_set_source_rgb"
     :void
   (cr :pointer)
   (red :double)
   (green :double)
   (blue :double))
-(defcfun "cairo_set_source_rgba"
+(def-cairo-fun "cairo_set_source_rgba"
     :void
   (cr :pointer)
   (red :double)
@@ -178,73 +201,73 @@
   (blue :double)
   (alpha :double))
-(defcfun "cairo_set_source"
+(def-cairo-fun "cairo_set_source"
     :void
   (cr :pointer)
   (pattern :pointer))
-(defcfun "cairo_set_tolerance"
+(def-cairo-fun "cairo_set_tolerance"
     :void
   (cr :pointer)
   (tolerance :double))
-(defcfun "cairo_set_fill_rule"
+(def-cairo-fun "cairo_set_fill_rule"
     :void
   (cr :pointer)
   (fill_rule cairo_fill_rule))
-(defcfun "cairo_set_line_width"
+(def-cairo-fun "cairo_set_line_width"
     :void
   (cr :pointer)
   (w :double))
-(defcfun "cairo_set_line_cap"
+(def-cairo-fun "cairo_set_line_cap"
     :void
   (cr :pointer)
   (line_cap cairo_line_cap))
-(defcfun "cairo_set_line_join"
+(def-cairo-fun "cairo_set_line_join"
     :void
   (cr :pointer)
   (line_join cairo_line_join))
-(defcfun "cairo_set_dash"
+(def-cairo-fun "cairo_set_dash"
     :void
   (cr :pointer)
   (dashes :pointer)			;*double
   (ndash :int)
   (offset :double))
-(defcfun "cairo_set_miter_limit"
+(def-cairo-fun "cairo_set_miter_limit"
     :int
   (cr :pointer)
   (limit :double))
;;; Transformations
-(defcfun "cairo_translate"
+(def-cairo-fun "cairo_translate"
     :void
   (cr :pointer)
   (tx :double)
   (ty :double))
-(defcfun "cairo_scale"
+(def-cairo-fun "cairo_scale"
     :void
   (cr :pointer)
   (sx :double)
   (sy :double))
-(defcfun "cairo_rotate"
+(def-cairo-fun "cairo_rotate"
     :void
   (cr :pointer)
   (angle :double))
-(defcfun "cairo_set_matrix"
+(def-cairo-fun "cairo_set_matrix"
     :void
   (cr :pointer)
   (matrix :pointer))
-(defcfun "cairo_identity_matrix"
+(def-cairo-fun "cairo_identity_matrix"
     :void
   (cr :pointer))
@@ -278,23 +301,23 @@
;;; Path creation functions
-(defcfun "cairo_new_path"
+(def-cairo-fun "cairo_new_path"
     :void
   (cr :pointer))
-(defcfun "cairo_move_to"
+(def-cairo-fun "cairo_move_to"
     :void
   (cr :pointer)
   (x :double)
   (y :double))
-(defcfun "cairo_line_to"
+(def-cairo-fun "cairo_line_to"
     :void
   (cr :pointer)
   (x :double)
   (y :double))
-(defcfun "cairo_curve_to"
+(def-cairo-fun "cairo_curve_to"
     :void
   (cr :pointer)
   (x1 :double)
@@ -304,7 +327,7 @@
   (x3 :double)
   (y3 :double))
-(defcfun "cairo_arc"
+(def-cairo-fun "cairo_arc"
     :void
   (cr :pointer)
   (xc :double)
@@ -313,7 +336,7 @@
   (angle1 :double)
   (angle2 :double))
-(defcfun "cairo_arc_negative"
+(def-cairo-fun "cairo_arc_negative"
     :void
   (cr :pointer)
   (xc :double)
@@ -322,19 +345,19 @@
   (angle1 :double)
   (angle2 :double))
-(defcfun "cairo_rel_move_to"
+(def-cairo-fun "cairo_rel_move_to"
     :void
   (cr :pointer)
   (dx :double)
   (dy :double))
-(defcfun "cairo_rel_line_to"
+(def-cairo-fun "cairo_rel_line_to"
     :void
   (cr :pointer)
   (dx :double)
   (dy :double))
-(defcfun "cairo_rel_curve_to"
+(def-cairo-fun "cairo_rel_curve_to"
     :void
   (cr :pointer)
   (dx1 :double)
@@ -344,7 +367,7 @@
   (dx3 :double)
   (dy3 :double))
-(defcfun "cairo_rectangle"
+(def-cairo-fun "cairo_rectangle"
     :void
   (cr :pointer)
   (x :double)
@@ -352,35 +375,35 @@
   (w :double)
   (h :double))
-(defcfun "cairo_close_path"
+(def-cairo-fun "cairo_close_path"
     :void
   (cr :pointer))
-(defcfun "cairo_stroke"
+(def-cairo-fun "cairo_stroke"
     :void
   (cr :pointer))
-(defcfun "cairo_fill"
+(def-cairo-fun "cairo_fill"
     :void
   (cr :pointer))
-(defcfun "cairo_copy_page"
+(def-cairo-fun "cairo_copy_page"
     :void
   (cr :pointer))
-(defcfun "cairo_show_page"
+(def-cairo-fun "cairo_show_page"
     :void
   (cr :pointer))
;;; Insideness testing
-(defcfun "cairo_in_stroke"
+(def-cairo-fun "cairo_in_stroke"
     :int
   (cr :pointer)
   (x :double)
   (y :double))
-(defcfun "cairo_in_fill"
+(def-cairo-fun "cairo_in_fill"
     :int
   (cr :pointer)
   (x :double)
@@ -388,7 +411,7 @@
;;; Rectangular extents
-(defcfun "cairo_stroke_extents"
+(def-cairo-fun "cairo_stroke_extents"
     :void
   (cr :pointer)
   (x1 :pointer)				;*double
@@ -397,7 +420,7 @@
   (y2 :pointer)				;*double
   )
-(defcfun "cairo_fill_extents"
+(def-cairo-fun "cairo_fill_extents"
     :void
   (cr :pointer)
   (x1 :pointer)				;*double
@@ -406,12 +429,12 @@
   (y2 :pointer)				;*double
   )
-(defcfun "cairo_reset_clip"
+(def-cairo-fun "cairo_reset_clip"
     :void
   (cr :pointer))
;; Note: cairo_clip does not consume the current path
-(defcfun "cairo_clip"
+(def-cairo-fun "cairo_clip"
     :void
   (cr :pointer))
@@ -421,14 +444,14 @@
 ;; This interface is for dealing with text as text, not caring about the
 ;; font object inside the the cairo_t.
-(defcfun "cairo_select_font_face"
+(def-cairo-fun "cairo_select_font_face"
     :void
     (cr :pointer)
     (family :string)
     (slant cairo_font_slant)
     (weight cairo_font_weight))
-(defcfun "cairo_set_font_size"
+(def-cairo-fun "cairo_set_font_size"
     :void
   (cr :pointer)
   (size :double))
@@ -438,50 +461,50 @@
 ;;;  (cr :pointer)
 ;;;  (matrix :pointer))
-(defcfun "cairo_show_text"
+(def-cairo-fun "cairo_show_text"
     :void
   (cr :pointer)
   (string :string))
-(defcfun "cairo_show_glyphs"
+(def-cairo-fun "cairo_show_glyphs"
     :void
   (cr :pointer)
   (glyphs :pointer)
   (num_glyphs :int))
-;;;(defcfun "cairo_current_font"
+;;;(def-cairo-fun "cairo_current_font"
 ;;;    :pointer
 ;;;  (cr :pointer))
 ;;;
-(defcfun "cairo_font_extents"
+(def-cairo-fun "cairo_font_extents"
     :void
   (cr :pointer)
   (extents :pointer))
-;;;(defcfun "cairo_set_font"
+;;;(def-cairo-fun "cairo_set_font"
 ;;;    :void
 ;;;  (cr :pointer)
 ;;;  (font :pointer))
-(defcfun "cairo_text_extents"
+(def-cairo-fun "cairo_text_extents"
     :void
   (cr :pointer)
   (string :string)			;### utf_8
   (extents :pointer))
-(defcfun "cairo_glyph_extents"
+(def-cairo-fun "cairo_glyph_extents"
     :void
   (cr :pointer)
   (glyphs :pointer)
   (num_glyphs :int)
   (extents :pointer))
-(defcfun "cairo_text_path"
+(def-cairo-fun "cairo_text_path"
     :void
   (cr :pointer)
   (string :string))			;### utf_8
-(defcfun "cairo_glyph_path"
+(def-cairo-fun "cairo_glyph_path"
     :void
   (cr :pointer)
   (glyphs :pointer)
@@ -500,7 +523,7 @@
;;; Image functions
-;;;(defcfun "cairo_show_surface"
+;;;(def-cairo-fun "cairo_show_surface"
 ;;;    :void
 ;;;  (cr :pointer)
 ;;;  (surface :pointer)
@@ -509,11 +532,11 @@
[112 lines skipped]
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp	2006/04/23 10:18:45	1.3
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp	2006/04/23 17:36:28	1.4
@@ -106,16 +106,24 @@
       (gtk-main-iteration port #-(and sbcl (not win32)) t)
       (dequeue port))))
-(defmacro define-signal (name (widget event) &body body)
-  (let ((impl (intern (concatenate 'string (symbol-name name) "-IMPL"))))
-    ;; jump through a trampoline so that C-M-x works without having to restart:
-    `(progn
-       (defun ,impl (,widget ,event)
-	 ,@body)
-       (cffi:defcallback ,name :void
-	 ((widget :pointer) (event :pointer) (data :pointer))
-	 data
-	 (,impl widget event)))))
+(defmacro define-signal (name+options (widget event &rest args) &body body)
+  (destructuring-bind (name &key (return-type :void))
+      (if (listp name+options)
+	  name+options
+	  (list name+options))
+    (let ((impl (intern (concatenate 'string (symbol-name name) "-IMPL")))
+	  (args (if (symbolp event)
+		    `((,event :pointer) ,@args)
+		    (cons event args))))
+      ;; jump through a trampoline so that C-M-x works without having to
+      ;; restart:
+      `(progn
+	 (defun ,impl (,widget ,@(mapcar #'car args))
+	   ,@body)
+	 (cffi:defcallback ,name ,return-type
+	   ((widget :pointer) ,@args (data :pointer))
+	   data
+	   (,impl widget ,@(mapcar #'car args)))))))
(define-signal noop-handler (widget event))
@@ -298,7 +306,30 @@
    (make-instance 'climi::window-destroy-event
      :sheet (widget->sheet widget *port*))))
-(define-signal clicked-handler (widget event)
+;; native widget handlers:
+
+(define-signal magic-clicked-handler (widget event)
   (declare (ignore event))
   (when (boundp '*port*)		;hack alert
-    (enqueue (make-gadget-event (widget->sheet widget *port*)))))
+    (enqueue
+     (make-instance 'magic-gadget-event
+       :sheet (widget->sheet widget *port*)))))
+
+#-sbcl
+(define-signal (scrollbar-change-value-handler :return-type :int)
+    (widget (scroll gtkscrolltype) (value :double))
+  (enqueue (make-instance 'scrollbar-change-value-event
+	     :scroll-type scroll
+	     :value value
+	     :sheet (widget->sheet widget *port*)))
+  1)
+
+#+sbcl
+;; :double in callbacks doesn't work:
+(define-signal (scrollbar-change-value-handler :return-type :int)
+    (widget (scroll gtkscrolltype) (lo :unsigned-int) (hi :int))
+  (enqueue (make-instance 'scrollbar-change-value-event
+	     :scroll-type scroll
+	     :value (sb-kernel:make-double-float hi lo)
+	     :sheet (widget->sheet widget *port*)))
+  1)
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp	2006/04/17 18:40:27	1.1
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp	2006/04/23 17:36:28	1.2
@@ -65,9 +65,6 @@
 (defmethod make-pane-2 ((type (eql 'clim:scroll-bar-pane))
    		&rest initargs
    		&key orientation)
-  ;; doesn't really work yet
-  (call-next-method)
-  #+(or)
   (apply #'make-instance
     (if (eq orientation :vertical)
         'gtk-vscrollbar
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp	2006/04/23 10:18:45	1.2
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp	2006/04/23 17:36:28	1.3
@@ -20,26 +20,37 @@
 (in-package :clim-gtkairo)
(defclass gadget-event (window-event) ())
+(defclass magic-gadget-event (gadget-event) ())
-(defun make-gadget-event (sheet)
-  (make-instance 'gadget-event :sheet sheet))
+(defclass scrollbar-change-value-event (gadget-event)
+    ((scroll-type :initarg :scroll-type :accessor event-scroll-type)
+     (value :initarg :value :accessor event-value)))
;;;; Classes
-;; FIXME: Hier implementieren wir die Widgets nicht vollstaendig selbst,
-;; sondern erben von den Standard-Widgets.  Damit das gut geht, muessen
-;; wir unten deren Redisplay-Methoden unterdruecken...  Besser waere es
-;; vielleicht, von TOGGLE-BUTTON statt TOGGLE-BUTTON-PANE zu erben und
-;; alles selbst zu machen.  Mindestens COMPOSE-SPACE muesste man dann
-;; hier implementieren.
 (defclass gtk-button (native-widget-mixin push-button) ())
-(defclass gtk-check-button (native-widget-mixin toggle-button-pane) ())
-(defclass gtk-radio-button (native-widget-mixin toggle-button-pane) ())
-(defclass gtk-vscale (native-widget-mixin slider-pane) ())
-(defclass gtk-hscale (native-widget-mixin slider-pane) ())
-(defclass gtk-vscrollbar (native-widget-mixin scroll-bar-pane) ())
-(defclass gtk-hscrollbar (native-widget-mixin scroll-bar-pane) ())
+
+(defclass gtk-check-button (native-widget-mixin toggle-button) ())
+(defclass gtk-radio-button (native-widget-mixin toggle-button) ())
+
+(defclass native-slider (native-widget-mixin climi::slider-gadget)
+    ((climi::show-value-p :type boolean
+			  :initform nil
+			  :initarg :show-value-p
+			  :accessor climi::gadget-show-value-p)
+     (climi::decimal-places :initform 0
+			    :initarg :decimal-places
+			    :reader climi::slider-decimal-places)
+     (climi::number-of-quanta :initform nil
+			      :initarg :number-of-quanta
+			      :reader climi::slider-number-of-quanta)))
+(defclass gtk-vscale (native-slider) ())
+(defclass gtk-hscale (native-slider) ())
+
+(defclass native-scrollbar (native-widget-mixin scroll-bar) ())
+(defclass gtk-vscrollbar (native-scrollbar) ())
+(defclass gtk-hscrollbar (native-scrollbar) ())
;;;; Constructors
@@ -51,7 +62,9 @@
     button))
(defmethod realize-native-widget ((sheet gtk-check-button))
-  (gtk_check_button_new_with_label (climi::gadget-label sheet)))
+  (let ((widget (gtk_check_button_new_with_label (climi::gadget-label sheet))))
+    (gtk_toggle_button_set_active widget (if (gadget-value sheet) 1 0))
+    widget))
(defun make-scale (fn sheet)
   (let* ((min (df (gadget-min-value sheet)))
@@ -61,6 +74,8 @@
     (gtk_scale_set_digits widget (climi::slider-decimal-places sheet))
     (gtk_scale_set_draw_value widget
    		      (if (climi::gadget-show-value-p sheet) 1 0))
+    (gtk_adjustment_set_value (gtk_range_get_adjustment widget)
+			      (df (gadget-value sheet)))
     widget))
(defmethod realize-native-widget ((sheet gtk-vscale))
@@ -72,10 +87,9 @@
 (defun make-scrollbar (fn sheet)
   (let* ((min (df (gadget-min-value sheet)))
     (max (df (gadget-max-value sheet)))
-	 (l (- max min))
-	 (adjustment
-	  ;; FIXME!
-	  (gtk_adjustment_new 0.0d0 min max (/ l 100) (/ l 10) l)))
+	 (page-size (df (climi::scroll-bar-thumb-size sheet)))
+	 (adjustment (gtk_adjustment_new 0.0d0 min max 0.0d0 0.0d0 page-size)))
+    (gtk_adjustment_set_value adjustment (df (gadget-value sheet)))
     (funcall fn adjustment)))
(defmethod realize-native-widget ((sheet gtk-vscrollbar))
@@ -89,74 +103,108 @@
      (some #'sheet-direct-mirror (sheet-children (gadget-client sheet))))
     (group (if first
    	    (gtk_radio_button_get_group (mirror-widget first))
-		    (cffi:null-pointer))))
-    (gtk_radio_button_new_with_label group (climi::gadget-label sheet))))
+		    (cffi:null-pointer)))
+	 (result
+	  (gtk_radio_button_new_with_label group (climi::gadget-label sheet))))
+    (gtk_toggle_button_set_active
+     result
+     (if (eq sheet (gadget-value (gadget-client sheet))) 1 0))
+    result))
;;;; Event definition
(defmethod connect-native-signals ((sheet native-widget-mixin) widget)
-  (connect-signal widget "clicked" 'clicked-handler))
+  (connect-signal widget "clicked" 'magic-clicked-handler))
-(defmethod connect-native-signals ((sheet gtk-vscale) widget)
-  (connect-signal widget "value-changed" 'clicked-handler))
+(defmethod connect-native-signals ((sheet native-slider) widget)
+  (connect-signal widget "value-changed" 'magic-clicked-handler))
-(defmethod connect-native-signals ((sheet gtk-hscale) widget)
-  (connect-signal widget "value-changed" 'clicked-handler))
-
-(defmethod connect-native-signals ((sheet gtk-vscrollbar) widget)
-  (connect-signal widget "value-changed" 'clicked-handler))
-
-(defmethod connect-native-signals ((sheet gtk-hscrollbar) widget)
-  (connect-signal widget "value-changed" 'clicked-handler))
+(defmethod connect-native-signals ((sheet native-scrollbar) widget)
+  ;; (connect-signal widget "value-changed" 'magic-clicked-handler)
+  (connect-signal widget "change-value" 'scrollbar-change-value-handler))
;;;; Event handling
-(defmethod handle-event ((pane gtk-button) (event gadget-event))
+(defmethod handle-event ((pane gtk-button) (event magic-gadget-event))
   (activate-callback pane (gadget-client pane) (gadget-id pane)))
-(defmethod handle-event ((pane gtk-check-button) (event gadget-event))
+(defmethod handle-event ((pane gtk-check-button) (event magic-gadget-event))
   (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane))))
-(defmethod handle-event ((pane gtk-radio-button) (event gadget-event))
+(defmethod handle-event ((pane gtk-radio-button) (event magic-gadget-event))
   (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane))))
-(defmethod handle-event ((pane gtk-vscale) (event gadget-event))
-  (setf (gadget-value pane :invoke-callback t)
-	(gtk_range_get_value (mirror-widget (sheet-direct-mirror pane)))))
-
-(defmethod handle-event ((pane gtk-hscale) (event gadget-event))
+(defmethod handle-event ((pane native-slider) (event magic-gadget-event))
   (setf (gadget-value pane :invoke-callback t)
    (gtk_range_get_value (mirror-widget (sheet-direct-mirror pane)))))
-(defmethod handle-event ((pane gtk-vscrollbar) (event gadget-event))
+(defmethod handle-event ((pane native-scrollbar) (event magic-gadget-event))
   (setf (gadget-value pane :invoke-callback t)
    (gtk_range_get_value (mirror-widget (sheet-direct-mirror pane)))))
-(defmethod handle-event ((pane gtk-hscrollbar) (event gadget-event))
-  (setf (gadget-value pane :invoke-callback t)
-	(gtk_range_get_value (mirror-widget (sheet-direct-mirror pane)))))
+(defun clamp (low x hi)
+  (min (max low x) hi))
+(defmethod handle-event
+    ((pane native-scrollbar) (event scrollbar-change-value-event))
+  (case (event-scroll-type event)
+    (:jump
+      (let ((value
+	     (clamp (gadget-min-value pane)
+		    (event-value event)
+		    (gadget-max-value pane))))
+	(setf (gadget-value pane :invoke-callback nil) value)
+	(drag-callback pane (gadget-client pane) (gadget-id pane) value)))
+    (:step_backward
+      (scroll-up-line-callback pane (gadget-client pane) (gadget-id pane)))
+    (:step_forward
+      (scroll-down-line-callback pane (gadget-client pane) (gadget-id pane)))
+    (:page_backward
+      (scroll-up-page-callback pane (gadget-client pane) (gadget-id pane)))
+    (:page_forward
+      (scroll-down-page-callback pane (gadget-client pane) (gadget-id pane)))))
-;;; Workarounds
+;;; COMPOSE-SPACE
-(defmethod handle-repaint ((pane native-widget-mixin) region)
-  (declare (ignore region))
-  ;; siehe oben
-  )
+;; KLUDGE: this is getting called before the sheet has been realized.
+(defmethod compose-space ((gadget native-widget-mixin) &key width height)
+  (declare (ignore width height))
+  (let* ((widget (native-widget gadget))
+	 (widgetp widget))
+    (unless widgetp
+      (setf widget (realize-native-widget gadget)))
+    (prog1
+	(cffi:with-foreign-object (r 'gtkrequisition)
+	  (gtk_widget_size_request widget r)
+	  (cffi:with-foreign-slots ((width height) r gtkrequisition)
+	    (make-space-requirement :width width :height height)))
+      (unless widgetp
+	(gtk_widget_destroy widget)))))
;;; Vermischtes
(defmethod (setf gadget-value) :after
+    (value (gadget native-slider) &key invoke-callback)
+  (declare (ignore invoke-callback))
+  (with-gtk ()
+    (let ((mirror (sheet-direct-mirror gadget)))
+      (when mirror
+	;; see hack in magic-clicked-handler
+	(gtk_adjustment_set_value
+	 (gtk_range_get_adjustment (mirror-widget mirror))
+	 (df value))))))
+
+(defmethod (setf gadget-value) :after
     (value (gadget gtk-radio-button) &key invoke-callback)
   (declare (ignore invoke-callback))
   (with-gtk ()
     (let ((mirror (sheet-direct-mirror gadget)))
       (when mirror
-	;; see hack in clicked-handler
+	;; see hack in magic-clicked-handler
    (gtk_toggle_button_set_active (mirror-widget mirror)
    			      (if value 1 0))))))
@@ -166,21 +214,47 @@
   (with-gtk ()
     (let ((mirror (sheet-direct-mirror gadget)))
       (when mirror
-	;; see hack in clicked-handler
+	;; see hack in magic-clicked-handler
    (gtk_toggle_button_set_active (mirror-widget mirror)
    			      (if value 1 0))))))
-;; KLUDGE: this is getting called before the sheet has been realized.
-(defmethod compose-space ((gadget native-widget-mixin) &key width height)
-  (declare (ignore width height))
-  (let* ((widget (native-widget gadget))
-	 (widgetp widget))
-    (unless widgetp
-      (setf widget (realize-native-widget gadget)))
-    (prog1
-	(cffi:with-foreign-object (r 'gtkrequisition)
-	  (gtk_widget_size_request widget r)
-	  (cffi:with-foreign-slots ((width height) r gtkrequisition)
-	    (make-space-requirement :width width :height height)))
-      (unless widgetp
-	(gtk_widget_destroy widget)))))
+
+;;; Scroll bars.
+
+;; This is all totally broken.  Why does thumb-size default to 1/4 when it's
+;; not a ratio but given in value units?  Why is min==max all the time?
+;; And why doesn't this work! :-(
+(defun update-scrollbar-adjustment (sheet)
+  (with-gtk ()
+    (let* ((min (df (gadget-min-value sheet)))
+	   (max (df (gadget-max-value sheet)))
+	   (value (df (gadget-value sheet)))
+	   (page-size (df (climi::scroll-bar-thumb-size sheet))))
+      (gtk_range_set_adjustment
+       (mirror-widget (sheet-direct-mirror sheet))
+       (gtk_adjustment_new value min max 0.0d0 0.0d0 page-size)))))
+
+(defmethod (setf gadget-min-value) :after (new-value (pane native-scrollbar))
+  (declare (ignore new-value))
+  (update-scrollbar-adjustment pane))
+
+(defmethod (setf gadget-max-value) :after (new-value (pane native-scrollbar))
+  (declare (ignore new-value))
+  (update-scrollbar-adjustment pane))
+
+(defmethod (setf gadget-value)
+    :after (new-value (pane native-scrollbar) &key invoke-callback)
+  (declare (ignore new-value invoke-callback))
+  (update-scrollbar-adjustment pane))
+
+(climi::defmethod* (setf climi::scroll-bar-values)
+    (min-value max-value thumb-size value (scroll-bar native-scrollbar))
+  (setf (slot-value scroll-bar 'climi::min-value) min-value
+	(slot-value scroll-bar 'climi::max-value) max-value
+	(slot-value scroll-bar 'climi::thumb-size) thumb-size
+	(slot-value scroll-bar 'climi::value) value)
+  (update-scrollbar-adjustment scroll-bar))
+
+(defmethod port-set-mirror-region :after
+    ((port gtkairo-port) (mirror native-scrollbar) mirror-region)
+  (update-scrollbar-adjustment (widget->sheet (mirror-widget mirror) port)))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp	2006/04/23 10:18:45	1.3
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp	2006/04/23 17:36:28	1.4
@@ -261,6 +261,11 @@
     :copy :invert :xor :clear :and :and_reverse :and_invert :noop :or :equiv
     :or_reverse :copy_invert :or_invert :nand :nor :set)
+(cffi:defcenum gtkscrolltype
+    :none :jump :step_backward :step_forward :page_backward :page_forward
+    :step_up :step_down :page_up :page_down :step_left :step_right :page_left
+    :page_right :start :end)
+
;;; GTK functions
@@ -633,10 +638,20 @@
     :pointer
   (range :pointer))
+(defcfun "gtk_range_set_adjustment"
+    :void
+  (range :pointer)
+  (adjustment :pointer))
+
 (defcfun "gtk_adjustment_get_value"
     :double
   (range :pointer))
+(defcfun "gtk_adjustment_set_value"
+    :void
+  (adjustment :pointer)
+  (value :double))
+
 (defcfun "gtk_adjustment_new"
     :pointer
   (value :double)
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp	2006/04/23 10:42:39	1.4
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp	2006/04/23 17:36:28	1.5
@@ -708,22 +708,25 @@
   (text-style-height text-style (metrik-medium (port medium))))
(defmethod text-style-height (text-style (medium metrik-medium))
-  (with-cairo-medium (medium)
-    (ceiling
-     (with-slots (cr) medium
-       (sync-sheet medium)
-       (cairo_identity_matrix cr)
-       (sync-text-style medium text-style t)
-       (cffi:with-foreign-object (res 'cairo_font_extents)
-	 (cairo_font_extents cr res)
-	 ;; ### let's hope that cairo respects
-	 ;; height = ascent + descent.
-	 ;;
-	 ;; No, it expressly doesn't.  Cairo documentation states that
-	 ;; height includes additional space that is meant to give more
-	 ;; aesthetic line spacing than ascent+descent would.  Is that a
-	 ;; problem for us? --DFL
-	 (slot res 'cairo_font_extents 'height))))))
+;;;  (with-cairo-medium (medium)
+;;;    (ceiling
+;;;     (with-slots (cr) medium
+;;;       (sync-sheet medium)
+;;;       (cairo_identity_matrix cr)
+;;;       (sync-text-style medium text-style t)
+;;;       (cffi:with-foreign-object (res 'cairo_font_extents)
+;;;	 (cairo_font_extents cr res)
+;;;	 ;; ### let's hope that cairo respects
+;;;	 ;; height = ascent + descent.
+;;;	 ;;
+;;;	 ;; No, it expressly doesn't.  Cairo documentation states that
+;;;	 ;; height includes additional space that is meant to give more
+;;;	 ;; aesthetic line spacing than ascent+descent would.  Is that a
+;;;	 ;; problem for us? --DFL
+;;;	 (slot res 'cairo_font_extents 'height)))))
+  ;; OK, so it _does_ matter (see bug 15).
+  (+ (text-style-ascent text-style medium)
+     (text-style-descent text-style medium)))
;;; TEXT-STYLE-WIDTH

    