96 lines
2.8 KiB
Racket
96 lines
2.8 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
racket/class
|
|
racket/draw
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"pixbuf.rkt"
|
|
"../common/cursor-draw.rkt"
|
|
"../../syntax.rkt")
|
|
|
|
(provide
|
|
(protect-out 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-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%
|
|
|
|
(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 (set-image image mask hot-spot-x hot-spot-y)
|
|
(let ([bm (make-object bitmap% 16 16 #f #t)])
|
|
(let ([dc (make-object bitmap-dc% bm)])
|
|
(send dc draw-bitmap image 0 0 'solid (send the-color-database find-color "black") mask)
|
|
(send dc set-bitmap #f))
|
|
(let ([pixbuf (bitmap->pixbuf bm)])
|
|
(set! handle
|
|
(gdk_cursor_new_from_pixbuf
|
|
(gdk_display_get_default)
|
|
pixbuf
|
|
hot-spot-x
|
|
hot-spot-y)))))
|
|
|
|
(define/public (get-handle) handle)
|
|
|
|
(super-new))
|