49 lines
1.3 KiB
Racket
49 lines
1.3 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/draw
|
|
"local.rkt"
|
|
(only-in "../platform.rkt" cursor-driver%)
|
|
"../../syntax.rkt")
|
|
|
|
(provide cursor%)
|
|
|
|
(define standards (make-hash))
|
|
|
|
(define (is-16x16? image)
|
|
(and (not (send image is-color?))
|
|
(= 16 (send image get-width))
|
|
(= 16 (send image get-height))))
|
|
|
|
(defclass cursor% object%
|
|
|
|
(init-rest args)
|
|
(define driver
|
|
(case-args
|
|
args
|
|
[([(symbol-in arrow bullseye cross hand ibeam watch blank
|
|
size-n/s size-e/w size-ne/sw size-nw/se
|
|
arrow+watch)
|
|
sym])
|
|
(or (hash-ref standards sym #f)
|
|
(let ([c (new cursor-driver%)])
|
|
(send c set-standard sym)
|
|
(hash-set! standards sym c)
|
|
c))]
|
|
[([bitmap% image]
|
|
[bitmap% mask]
|
|
[(integer-in 0 15) [hot-spot-x 0]]
|
|
[(integer-in 0 15) [hot-spot-y 0]])
|
|
(unless (is-16x16? image)
|
|
(raise-type-error (init-name 'cursor%) "bitmap (16x16 monochrome)" image))
|
|
(unless (is-16x16? mask)
|
|
(raise-type-error (init-name 'cursor%) "bitmap (16x16 monochrome)" mask))
|
|
(let ([c (new cursor-driver%)])
|
|
(send c set-image image mask hot-spot-x hot-spot-y)
|
|
c)]
|
|
(init-name 'cursor%)))
|
|
|
|
(define/public (get-driver) driver)
|
|
|
|
(def/public (ok?) (send driver ok?))
|
|
(super-new))
|