[mcclim-cvs] CVS mcclim/Backends/gtkairo
dlichteblau
dlichteblau at common-lisp.net
Sun Apr 23 17:36:28 UTC 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
+ , at args)
+ (defun ,wrapper ,argnames
+ (multiple-value-prog1
+ (,actual , at 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)
- , at 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) , at 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))
+ , at body)
+ (cffi:defcallback ,name ,return-type
+ ((widget :pointer) , at 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
More information about the Mcclim-cvs
mailing list