suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gtk cursors

Browse Source 
original commit: 436eb512f84e8357759278f4f94a50f8e608db81
This commit is contained in:
Matthew Flatt 2010-08-17 12:31:40 -06:00
parent 35aaa3a0fb
commit 7eecbf2f30
6 changed files with 190 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/mred/private/wx/cocoa/cursor.rkt
View File

@ -2,9 +2,9 @@
(require ffi/unsafe
ffi/unsafe/objc
racket/class
racket/draw
"image.rkt"
"types.rkt"
"../common/cursor-draw.rkt"
"../common/local.rkt")
(provide cursor-driver%
@ -26,11 +26,7 @@
id)))
(define (make-image-cursor draw-proc)
(let* ([bm (make-object bitmap% 16 16 #f #t)]
[dc (make-object bitmap-dc% bm)])
(send dc set-smoothing 'aligned)
(draw-proc dc 16 16)
(send dc set-bitmap #f)
(let* ([bm (make-cursor-image draw-proc)])
(let ([image (bitmap->image bm)])
(tell (tell NSCursor alloc)
initWithImage: image
@ -38,15 +34,7 @@
(define arrow-cursor-handle (tell NSCursor arrowCursor))
(define (get-wait-cursor-handle)
(image-cursor wait
(lambda (dc w h)
(send dc set-brush "black" 'solid)
(send dc draw-rectangle 5 0 6 4)
(send dc draw-rectangle 5 12 6 4)
(send dc set-brush "white" 'solid)
(send dc draw-ellipse 3 3 10 10)
(send dc draw-line 7 5 7 8)
(send dc draw-line 7 8 9 8))))
(image-cursor wait draw-watch))
(define cursor-driver%
(class object%
@ -67,31 +55,13 @@
[(size-e/w)
(set! handle (tell NSCursor resizeLeftRightCursor))]
[(size-nw/se)
(set! handle
(image-cursor size-nw/se (lambda (dc w h)
(send dc draw-line 0 16 16 0)
(send dc draw-line 0 0 16 16)
(send dc draw-line 0 3 0 0)
(send dc draw-line 0 0 3 0)
(send dc draw-line 12 15 15 15)
(send dc draw-line 15 15 15 12))))]
(set! handle (image-cursor size-nw/se draw-nw/se))]
[(size-ne/sw)
(set! handle
(image-cursor size-ne/sw (lambda (dc w h)
(send dc draw-line 0 16 16 0)
(send dc draw-line 0 0 16 16)
(send dc draw-line 12 0 15 0)
(send dc draw-line 15 0 15 3)
(send dc draw-line 0 12 0 15)
(send dc draw-line 0 15 3 15))))]
(set! handle (image-cursor size-ne/sw draw-ne/sw))]
[(watch)
(set! handle (get-wait-cursor-handle))]
[(bullseye)
(set! handle
(image-cursor bullseye (lambda (dc w h)
(send dc draw-ellipse 1 1 (- w 2) (- h 2))
(send dc draw-ellipse 4 4 (- w 8) (- h 8))
(send dc draw-ellipse 7 7 2 2))))]
(set! handle (image-cursor bullseye draw-bullseye))]
[(blank)
(set! handle (image-cursor blank void))]))

61
collects/mred/private/wx/common/cursor-draw.rkt Normal file
View File

@ -0,0 +1,61 @@
#lang racket/base
(require racket/class
racket/draw)
(provide make-cursor-image
draw-watch
draw-nw/se
draw-ne/sw
draw-bullseye)
(define (make-cursor-image draw-proc)
(let* ([bm (make-object bitmap% 16 16 #f #t)]
[dc (make-object bitmap-dc% bm)])
(send dc set-smoothing 'aligned)
(draw-proc dc 16 16)
(send dc set-bitmap #f)
bm))
(define (draw-watch dc w h)
(send dc set-brush "black" 'solid)
(send dc draw-rectangle 5 0 6 4)
(send dc draw-rectangle 5 12 6 4)
(send dc set-brush "white" 'solid)
(send dc draw-ellipse 3 3 10 10)
(send dc draw-line 7 5 7 8)
(send dc draw-line 7 8 9 8))
(define (draw-nw/se dc w h)
(bolden
dc
(lambda ()
(send dc set-smoothing 'unsmoothed)
(send dc draw-line 0 16 16 0)
(send dc draw-line 0 0 16 16)
(send dc draw-line 1 4 1 1)
(send dc draw-line 1 1 4 1)
(send dc draw-line 12 15 15 15)
(send dc draw-line 15 15 15 12))))
(define (draw-ne/sw dc w h)
(bolden
dc
(lambda ()
(send dc set-smoothing 'unsmoothed)
(send dc draw-line 0 16 16 0)
(send dc draw-line 0 0 16 16)
(send dc draw-line 12 1 15 1)
(send dc draw-line 15 1 15 4)
(send dc draw-line 1 12 1 15)
(send dc draw-line 1 15 4 15))))
(define (draw-bullseye dc w h)
(send dc draw-ellipse 1 1 (- w 2) (- h 2))
(send dc draw-ellipse 4 4 (- w 8) (- h 8))
(send dc draw-ellipse 7 7 2 2))
(define (bolden dc draw)
(send dc set-pen "white" 4 'solid)
(draw)
(send dc set-pen "black" 2 'solid)
(draw))

81
collects/mred/private/wx/gtk/cursor.rkt
View File

@ -1,10 +1,81 @@
#lang scheme/base
(require scheme/class
#lang racket/base
(require ffi/unsafe
racket/class
"utils.rkt"
"types.rkt"
"pixbuf.rkt"
"../common/cursor-draw.rkt"
"../../syntax.rkt")
(provide cursor-driver%)
(provide cursor-driver%
get-arrow-cursor-handle
get-watch-cursor-handle)
(define GDK_ARROW 2) ; ugly!
(define GDK_CROSSHAIR 34)
(define GDK_HAND2 60)
(define GDK_SB_H_DOUBLE_ARROW 108)
(define GDK_SB_V_DOUBLE_ARROW 116)
(define GDK_XTERM 152)
(define GDK_TARGET 128)
(define GDK_WATCH 150)
(define gdk-cursors
(make-hasheq (list
(cons 'arrow GDK_ARROW)
(cons 'cross GDK_CROSSHAIR)
(cons 'ibeam GDK_XTERM)
(cons 'bullseye GDK_TARGET)
(cons 'watch 150)
(cons 'size-e/w GDK_SB_H_DOUBLE_ARROW)
(cons 'size-n/s GDK_SB_V_DOUBLE_ARROW)
(cons 'size-ne/sw draw-ne/sw)
(cons 'size-nw/se draw-nw/se)
(cons 'blank void)
(cons 'hand GDK_HAND2))))
(define _GdkCursor (_cpointer 'GdkCursor))
(define-gdk gdk_cursor_new (_fun _int -> _GdkCursor))
(define _GdkDisplay (_cpointer 'GdkDisplay))
(define-gdk gdk_display_get_default (_fun -> _GdkDisplay))
(define-gdk gdk_cursor_new_from_pixbuf (_fun _GdkDisplay _GdkPixbuf _int _int -> _GdkCursor))
(define (get-arrow-cursor-handle)
(hash-ref gdk-cursors 'arrow #f))
(define (get-watch-cursor-handle)
(let ([v (hash-ref gdk-cursors 'watch #f)])
(if (number? v)
(begin
(send (new cursor-driver%) set-standard 'watch)
(get-watch-cursor-handle))
v)))
(defclass cursor-driver% object%
(def/public-unimplemented ok?)
(define/public (set-standard sym) (void))
(define handle #f)
(define/public (ok?) (and handle #t))
(define/public (set-standard sym)
(let ([v (hash-ref gdk-cursors sym #f)])
(cond
[(not v) (void)]
[(number? v)
(let ([c (gdk_cursor_new v)])
(hash-set! gdk-cursors sym c)
(set! handle c))]
[(procedure? v)
(let ([bm (make-cursor-image v)])
(let ([c (gdk_cursor_new_from_pixbuf
(gdk_display_get_default)
(bitmap->pixbuf bm)
8
8)])
(hash-set! gdk-cursors sym c)
(set! handle c)))]
[else (set! handle v)])))
(define/public (get-handle) handle)
(super-new))

26
collects/mred/private/wx/gtk/frame.rkt
View File

@ -10,6 +10,7 @@
"client-window.rkt"
"widget.rkt"
"procs.rkt"
"cursor.rkt"
"../common/queue.rkt")
(unsafe!)
@ -39,6 +40,8 @@
(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))
(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
(define-cstruct _GdkGeometry ([min_width _int]
[min_height _int]
[max_width _int]
@ -289,9 +292,30 @@
(define/public (set-status-text s) (void))
(def/public-unimplemented status-line-exists?)
(define waiting-cursor? #f)
(define/public (set-wait-cursor-mode on?)
(void))
(set! waiting-cursor? on?)
(send in-window enter-window))
(define current-cursor-handle #f)
(define in-window #f)
(define/override (set-parent-window-cursor in-win c)
(set! in-window in-win)
(let ([c (if waiting-cursor?
(get-watch-cursor-handle)
c)])
(unless (eq? c current-cursor-handle)
(atomically
(set! current-cursor-handle c)
(gdk_window_set_cursor (widget-window (get-gtk)) (if (eq? c (get-arrow-cursor-handle))
#f
c))))))
(define/override (enter-window) (void))
(define/override (leave-window) (void))
(define/override (check-window-cursor win)
(send in-window enter-window))
(define maximized? #f)
(define/public (is-maximized?)

2
collects/mred/private/wx/gtk/panel.rkt
View File

@ -62,6 +62,8 @@
(define gtk (get-gtk))
(connect-key-and-mouse gtk)
(define/override (set-child-size child-gtk x y w h)
(gtk_fixed_move gtk child-gtk x y)
(gtk_widget_set_size_request child-gtk w h))))

21
collects/mred/private/wx/gtk/window.rkt
View File

@ -7,6 +7,7 @@
"../common/event.rkt"
"../common/freeze.rkt"
"../common/queue.rkt"
"../common/local.rkt"
"keycode.rkt"
"queue.rkt"
"utils.rkt"
@ -160,11 +161,13 @@
(define-signal-handler connect-enter "enter-notify-event"
(_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)]) (when wx (send wx enter-window)))
(do-button-event gtk event #f #t)))
(define-signal-handler connect-leave "leave-notify-event"
(_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean)
(lambda (gtk event)
(let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window)))
(do-button-event gtk event #f #t)))
(define (connect-key-and-mouse gtk [skip-press? #f])
@ -441,8 +444,24 @@
(define/public (set-focus)
(gtk_widget_grab_focus (get-client-gtk)))
(define cursor-handle #f)
(define/public (set-cursor v)
(void))
(set! cursor-handle (and v
(send (send v get-driver) get-handle)))
(check-window-cursor this))
(define/public (enter-window)
(set-window-cursor this #f))
(define/public (leave-window)
(when parent
(send parent enter-window)))
(define/public (set-window-cursor in-win c)
(set-parent-window-cursor in-win (or c cursor-handle)))
(define/public (set-parent-window-cursor in-win c)
(when parent
(send parent set-window-cursor in-win c)))
(define/public (check-window-cursor win)
(when parent
(send parent check-window-cursor win)))
(define/public (on-set-focus) (void))
(define/public (on-kill-focus) (void))