88 lines
2.5 KiB
Racket
88 lines
2.5 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/objc
|
|
racket/class
|
|
racket/draw
|
|
"image.rkt"
|
|
"types.rkt"
|
|
"utils.rkt"
|
|
"../common/cursor-draw.rkt"
|
|
"../common/local.rkt")
|
|
|
|
(provide
|
|
(protect-out cursor-driver%
|
|
arrow-cursor-handle
|
|
get-wait-cursor-handle))
|
|
|
|
(import-class NSCursor)
|
|
|
|
(define wait #f)
|
|
(define bullseye #f)
|
|
(define blank #f)
|
|
(define size-ne/sw #f)
|
|
(define size-nw/se #f)
|
|
|
|
(define-syntax-rule (image-cursor id draw-proc)
|
|
(or id
|
|
(begin
|
|
(set! id (make-image-cursor draw-proc))
|
|
id)))
|
|
|
|
(define (make-image-cursor draw-proc)
|
|
(let* ([bm (make-cursor-image draw-proc)])
|
|
(let ([image (bitmap->image bm)])
|
|
(tell (tell NSCursor alloc)
|
|
initWithImage: image
|
|
hotSpot: #:type _NSPoint (make-NSPoint 8 8)))))
|
|
|
|
(define arrow-cursor-handle (tell NSCursor arrowCursor))
|
|
(define (get-wait-cursor-handle)
|
|
(image-cursor wait draw-watch))
|
|
|
|
(define cursor-driver%
|
|
(class object%
|
|
(define handle #f)
|
|
|
|
(define/public (set-standard sym)
|
|
(case sym
|
|
[(arrow)
|
|
(set! handle arrow-cursor-handle)]
|
|
[(cross)
|
|
(set! handle (tell NSCursor crosshairCursor))]
|
|
[(hand)
|
|
(set! handle (tell NSCursor openHandCursor))]
|
|
[(ibeam)
|
|
(set! handle (tell NSCursor IBeamCursor))]
|
|
[(size-n/s)
|
|
(set! handle (tell NSCursor resizeUpDownCursor))]
|
|
[(size-e/w)
|
|
(set! handle (tell NSCursor resizeLeftRightCursor))]
|
|
[(size-nw/se)
|
|
(set! handle (image-cursor size-nw/se draw-nw/se))]
|
|
[(size-ne/sw)
|
|
(set! handle (image-cursor size-ne/sw draw-ne/sw))]
|
|
[(watch)
|
|
(set! handle (get-wait-cursor-handle))]
|
|
[(bullseye)
|
|
(set! handle (image-cursor bullseye draw-bullseye))]
|
|
[(blank)
|
|
(set! handle (image-cursor blank void))]))
|
|
|
|
(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 ([image (bitmap->image bm)])
|
|
(set! handle
|
|
(as-objc-allocation
|
|
(tell (tell NSCursor alloc)
|
|
initWithImage: image
|
|
hotSpot: #:type _NSPoint (make-NSPoint hot-spot-x hot-spot-y)))))))
|
|
|
|
(define/public (ok?) (and handle #t))
|
|
|
|
(define/public (get-handle) handle)
|
|
|
|
(super-new)))
|