From: Matt Birkholz Date: Fri, 23 Sep 2011 01:06:32 +0000 (-0700) Subject: Added set-fix-widget-enter/leave-notify-handler!, -pointer-shape!. X-Git-Tag: mit-scheme-pucked-9.2.12~610 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=32424c9ec52abcfab87e1d92615c71d059915bc8;p=mit-scheme.git Added set-fix-widget-enter/leave-notify-handler!, -pointer-shape!. New: set-fix-widget-enter-notify-handler! set-fix-widget-leave-notify-handler! set-fix-widget-pointer-shape! Updated: gdk_cursor_unref (gdk_cursor_destroy is deprecated), gtk_widget_set_state (new for fix-resizer's enter/leave handlers). Consistency nits: prefering symbol-name over symbol->string, tracing entry to specialized methods AFTER call-next-method. Exercised pointer shape setting in demo. --- diff --git a/src/gtk/Includes/gdkcursor.cdecl b/src/gtk/Includes/gdkcursor.cdecl index ed2f60634..ba6f7fe45 100644 --- a/src/gtk/Includes/gdkcursor.cdecl +++ b/src/gtk/Includes/gdkcursor.cdecl @@ -95,5 +95,5 @@ gtk-2.0/gdk/gdkcursor.h |# (extern (* GdkCursor) gdk_cursor_new (cursor_type GdkCursorType)) -(extern void gdk_cursor_destroy +(extern void gdk_cursor_unref (cursor (* GdkCursor))) \ No newline at end of file diff --git a/src/gtk/Includes/gdkwindow.cdecl b/src/gtk/Includes/gdkwindow.cdecl index cda3da972..8481d22fb 100644 --- a/src/gtk/Includes/gdkwindow.cdecl +++ b/src/gtk/Includes/gdkwindow.cdecl @@ -212,6 +212,10 @@ gtk-2.0/gdk/gdkwindow.h |# (dx gint) (dy gint)) +(extern void gdk_window_set_cursor + (window (* GdkWindow)) + (cursor (* GdkCursor))) + (extern void gdk_window_invalidate_rect (window (* GdkWindow)) diff --git a/src/gtk/Includes/gtkwidget.cdecl b/src/gtk/Includes/gtkwidget.cdecl index c94a05054..3ad38ebf5 100644 --- a/src/gtk/Includes/gtkwidget.cdecl +++ b/src/gtk/Includes/gtkwidget.cdecl @@ -315,6 +315,10 @@ gtk-2.0/gtk/gtkwidget.h |# (extern void gtk_widget_grab_focus (widget (* GtkWidget))) +(extern void gtk_widget_set_state + (widget (* GtkWidget)) + (state GtkStateType)) + (extern void gtk_widget_set_has_window (widget (* GtkWidget)) (has_window gboolean)) diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index 1176b85a8..2049eb9c6 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -35,8 +35,8 @@ ("pango" ,@base) ("gtk-object" ,@base) ("scm-widget" ,@base) - ("fix-layout" "pango" ,@base) - ("keys" ,@base) + ("fix-layout" "pango" ,@base ,@c-types) + ("keys" ,@base ,@c-types) ("main" ,@base) ("thread" "main" ,@user) ("gtk-ev" ,@base) diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index ec49c7d93..3e615c368 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -37,7 +37,6 @@ USA. (resizer (make-fix-resizer -1 10))) (gtk-window-set-opacity window 0.90) (gtk-window-set-title window "fix-layout-demo") - ;;(gtk-window-set-default-size window 200 400) (set-gtk-window-delete-event-callback! window (lambda (w) (%trace ";closed "w"\n") 0)) (gtk-container-set-border-width window 10) @@ -83,7 +82,8 @@ USA. (define-method fix-widget-realize-callback ((widget )) (call-next-method widget) - (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget))) + (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget)) + (set-fix-widget-pointer-shape! widget 'crosshair)) (define (make-demo-drawing widget) (let ((drawing (%make-demo-drawing))) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index db31dee14..199094017 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -205,6 +205,38 @@ USA. (C-array-loc! alien "GdkColor" (C-enum "GTK_STATE_NORMAL")) ;; The GdkColor was allocated by the GtkStyle. (C-call "gdk_window_set_background" (fix-widget-window widget) alien)))) + +(define-syntax pointer-shapes + (sc-macro-transformer + (lambda (form usage-env) + + (define (simplify name) + ;; |GDK_BASED_ARROW_DOWN| => based-arrow-down + (let ((string (symbol-name name))) + (if (string-prefix? "GDK_" string) + (intern (string-replace (string-tail string 4) #\_ #\-)) + (begin + (warn "Unexpected GdkCursorType name:" name) + name)))) + + (list 'quote + (map (lambda (name.value) + (cons (simplify (car name.value)) + (cdr name.value))) + (c-enum-constant-values '|GdkCursorType| form + (find-c-includes usage-env))))))) + +(define set-fix-widget-pointer-shape! + (let ((alist (pointer-shapes))) + (named-lambda (set-fix-widget-pointer-shape! widget name) + (let ((name.value (or (assq name alist) + (error "Not a pointer shape:" name + (map car alist)))) + (alien (make-alien '|GdkCursor|))) + ;; Not GC-protecting alien? + (C-call "gdk_cursor_new" alien (cdr name.value)) + (C-call "gdk_window_set_cursor" (fix-widget-window widget) alien) + (C-call "gdk_cursor_unref" alien))))) (define (event-callback widget GdkEvent) (%trace2 ";event-callback "widget) @@ -255,6 +287,24 @@ USA. (declare (ignore GdkEvent)) (handler widget)))) +(define (set-fix-widget-enter-notify-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-enter-notify-handler!) + (guarantee-procedure-of-arity handler 1 'set-fix-widget-enter-notify-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_ENTER_NOTIFY") + (named-lambda (fix-widget-enter-notify-handler widget GdkEvent) + (declare (ignore GdkEvent)) + (handler widget)))) + +(define (set-fix-widget-leave-notify-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-leave-notify-handler!) + (guarantee-procedure-of-arity handler 1 'set-fix-widget-leave-notify-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_LEAVE_NOTIFY") + (named-lambda (fix-widget-leave-notify-handler widget GdkEvent) + (declare (ignore GdkEvent)) + (handler widget)))) + (define (set-fix-widget-focus-change-handler! widget handler) (guarantee-fix-widget widget 'set-fix-widget-focus-change-handler!) (guarantee-procedure-of-arity handler 2 'set-fix-widget-focus-change-handler!) @@ -400,7 +450,6 @@ USA. (define-guarantee fix-layout "a ") (define-method initialize-instance ((widget ) width height) - (call-next-method widget width height) (%trace "; (initialize-instance ) "widget" "width" "height"\n") (set-fix-widget-expose-handler! widget layout-expose-handler) @@ -670,11 +719,21 @@ USA. (define-class ( (constructor () (width height))) ()) -(define-method initialize-instance ((widget ) width height) - (call-next-method widget width height) - (set-fix-widget-expose-handler! widget resizer-expose-handler)) +(define-method fix-widget-realize-callback ((widget )) + (call-next-method widget) + (%trace "; (fix-widget-realize-callback ) "widget"\n") + (let ((geom (fix-widget-geometry widget))) + (set-fix-widget-pointer-shape! + widget (if (fix:< (fix-rect-width geom) + (fix-rect-height geom)) + 'sb-h-double-arrow + 'sb-v-double-arrow))) + (set-fix-widget-expose-handler! widget resizer-expose-handler) + (set-fix-widget-enter-notify-handler! widget resizer-enter-handler) + (set-fix-widget-leave-notify-handler! widget resizer-leave-handler)) (define (resizer-expose-handler resizer x y width height) + (declare (ignore x y width height)) (let ((alien (gobject-alien resizer))) (let ((style (C-> alien "GtkWidget style")) (window (fix-widget-window resizer)) @@ -694,6 +753,16 @@ USA. (fix-rect-width geom) (fix-rect-height geom) orientation) #t)))) + +(define (resizer-enter-handler resizer) + (outf-error ";resizer-enter-handler\n") + (C-call "gtk_widget_set_state" + (gobject-alien resizer) (C-enum "GTK_STATE_PRELIGHT"))) + +(define (resizer-leave-handler resizer) + (outf-error ";resizer-leave-handler\n") + (C-call "gtk_widget_set_state" + (gobject-alien resizer) (C-enum "GTK_STATE_NORMAL"))) (define-class ( (constructor () no-init)) () @@ -1636,8 +1705,8 @@ USA. (loader define standard initializer make-pixbuf-loader)) (define-method initialize-instance ((ink )) - (%trace ";(initialize-instance ) "ink"\n") (call-next-method ink) + (%trace ";(initialize-instance ) "ink"\n") (let ((loader (image-ink-loader ink))) (set-pixbuf-loader-size-hook! loader (image-ink-size-prepared ink)) (set-pixbuf-loader-pixbuf-hook! loader (image-ink-pixbuf-prepared ink)) diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm index 9f2fe8b2e..6c0624113 100644 --- a/src/gtk/gtk-ev.scm +++ b/src/gtk/gtk-ev.scm @@ -119,7 +119,7 @@ USA. (error-if-null event-GdkWindow "Could not create event window:" widget) (C-call "gdk_window_set_user_data" event-GdkWindow alien) (C-call "gdk_window_show" event-GdkWindow) - (C-call "gdk_cursor_destroy" GdkCursor) + (C-call "gdk_cursor_unref" GdkCursor) ;; Style (C-call "gtk_style_attach" GtkStyle diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 0ae076707..682cd352f 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -211,7 +211,10 @@ USA. (define-package (gtk fix-layout) (parent (gtk)) (files "fix-layout") - ;;(depends-on "pango" "gtk.bin" "gtk" "../runtime/ffi") + ;;(depends-on "pango" "gtk.bin" gtk" "../runtime/ffi" "gtk-const.bin") + (import (ffi) + find-c-includes + c-enum-constant-values) (import (gtk pango) make-pango-layout pango-rectangle pangos->pixels pixels->pangos) (import (gtk gtk-object) @@ -222,9 +225,12 @@ USA. fix-widget? fix-widget-new-geometry-callback fix-widget-realize-callback set-fix-widget-size! + set-fix-widget-pointer-shape! set-fix-widget-expose-handler! set-fix-widget-map-handler! set-fix-widget-unmap-handler! + set-fix-widget-enter-notify-handler! + set-fix-widget-leave-notify-handler! set-fix-widget-focus-change-handler! set-fix-widget-visibility-notify-handler! set-fix-widget-key-press-handler! @@ -290,7 +296,7 @@ USA. (define-package (gtk keys) (parent (gtk)) (files "keys") - ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi") + ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi" "gtk-const.bin") (export (gtk) gdk-key-state->char-bits gdk-keyval->name) diff --git a/src/gtk/keys.scm b/src/gtk/keys.scm index b24ffbf34..7bcaf7260 100644 --- a/src/gtk/keys.scm +++ b/src/gtk/keys.scm @@ -53,7 +53,7 @@ USA. (lambda (gdk-name.keyval) (let* ((keyval (cdr gdk-name.keyval)) (gdk-name (car gdk-name.keyval)) - (string (symbol->string gdk-name)) + (string (symbol-name gdk-name)) (name (cond ((assv keyval overrides) => cdr) ((string-prefix? "GDK_" string) (intern (string-replace