1305 lines
42 KiB
Racket
1305 lines
42 KiB
Racket
; graphics.ss
|
|
; Simple graphics routines for GRacket
|
|
; Originally written by Johnathan Franklin
|
|
|
|
(module graphics-posn-less-unit mzscheme
|
|
(require mzlib/unit
|
|
mred/mred-sig
|
|
mred
|
|
mzlib/class
|
|
mzlib/class100
|
|
mzlib/etc
|
|
"graphics-sig.ss")
|
|
(provide graphics-posn-less@)
|
|
|
|
(define-syntax define-do-pixel
|
|
(syntax-rules ()
|
|
[(_ name do-it v-name make-do-pixel)
|
|
(define (name viewport)
|
|
(let ([f ((make-do-pixel do-it) viewport)])
|
|
;; Give a nicer name to f:
|
|
(let ([v-name
|
|
(case-lambda
|
|
[(posn) (f posn)]
|
|
[(posn color) (f posn color)])])
|
|
v-name)))]))
|
|
|
|
(define-syntax define-string
|
|
(syntax-rules ()
|
|
[(_ name what v-name string-functions)
|
|
(define name
|
|
(let ([finish (lambda (f)
|
|
;; Give a nicer name to f:
|
|
(let ([v-name
|
|
(case-lambda
|
|
[(posn text) (f posn text)]
|
|
[(posn text color) (f posn text color)])])
|
|
v-name))])
|
|
(case-lambda
|
|
[(viewport font)
|
|
(finish ((string-functions 'what) viewport font))]
|
|
[(viewport)
|
|
(finish ((string-functions 'what) viewport))])))]))
|
|
|
|
(define-unit graphics-posn-less@
|
|
(import (prefix mred: mred^)
|
|
graphics:posn^)
|
|
(export graphics^)
|
|
(init-depend mred^)
|
|
|
|
(define send/proc
|
|
(lambda (class method . args)
|
|
(send-generic class (make-generic mred:dc<%> method) . args)))
|
|
|
|
(define send/proc2
|
|
(lambda (class method . args)
|
|
(send-generic class (make-generic sixlib-canvas% method) . args)))
|
|
|
|
|
|
(define-struct viewport (label canvas))
|
|
(define-struct sixmouse (x y left? middle? right?))
|
|
(define-struct sixkey (value))
|
|
(define graphics-flag #f)
|
|
(define global-viewport-list '())
|
|
(define global-color-vector (make-vector 300 #f))
|
|
(define global-pen-vector (make-vector 300 #f))
|
|
(define global-brush-vector (make-vector 300 #f))
|
|
(define default-font (make-object mred:font% 12 'roman 'normal 'normal #f 'unsmoothed))
|
|
(define black-color (make-object mred:color% "BLACK"))
|
|
|
|
(define sixlib-canvas%
|
|
(class100-asi mred:canvas%
|
|
(inherit get-parent
|
|
min-client-width min-client-height
|
|
stretchable-width stretchable-height)
|
|
(private-field
|
|
[current-mouse-posn (make-posn 0 0)]
|
|
[queue%
|
|
(class100 object% ()
|
|
(private-field
|
|
[queue '()]
|
|
[last #f]
|
|
[lock (make-semaphore 1)]
|
|
[ready (make-semaphore)])
|
|
(public
|
|
[flush
|
|
(lambda ()
|
|
(semaphore-wait lock)
|
|
(set! queue '())
|
|
(set! last #f)
|
|
(set! ready (make-semaphore))
|
|
(semaphore-post lock))]
|
|
[add
|
|
(lambda (v)
|
|
(semaphore-wait lock)
|
|
(if last
|
|
(begin
|
|
(set-mcdr! last (mcons v '()))
|
|
(set! last (mcdr last)))
|
|
(begin
|
|
(set! queue (mcons v '()))
|
|
(set! last queue)))
|
|
(semaphore-post ready)
|
|
(semaphore-post lock))]
|
|
[remove
|
|
(lambda ()
|
|
(semaphore-wait lock)
|
|
(begin0
|
|
(if (null? queue)
|
|
#f
|
|
(begin0
|
|
(mcar queue)
|
|
(semaphore-wait ready)
|
|
(set! queue (mcdr queue))
|
|
(if (null? queue)
|
|
(set! last #f))))
|
|
(semaphore-post lock)))]
|
|
[remove/wait
|
|
(lambda ()
|
|
(semaphore-wait ready)
|
|
(semaphore-post ready)
|
|
(remove))])
|
|
(sequence
|
|
(super-init)))]
|
|
[click-queue (make-object queue%)]
|
|
[release-queue (make-object queue%)]
|
|
[press-queue (make-object queue%)])
|
|
(private
|
|
[reset-size
|
|
(lambda ()
|
|
(min-client-width width)
|
|
(min-client-height height)
|
|
(stretchable-width #f)
|
|
(stretchable-height #f)
|
|
(set! bitmap (make-object mred:bitmap% width height))
|
|
(unless (send bitmap ok?)
|
|
(error "cannot allocate viewport"))
|
|
(send buffer-dc set-bitmap bitmap)
|
|
(send buffer-dc set-brush (send dc get-brush))
|
|
(send buffer-dc set-pen (send dc get-pen))
|
|
(let ([f (send dc get-font)])
|
|
(when f
|
|
(send buffer-dc set-font f)))
|
|
(send buffer-dc clear)
|
|
(send dc clear))])
|
|
|
|
(private-field ; were public
|
|
viewport
|
|
[height 0]
|
|
[width 0]
|
|
[label 0]
|
|
[current-pen 'uninitialized-pen]
|
|
[current-brush 'uninitialized-brush]
|
|
[bitmap 'uninitalized-bitmap]
|
|
[dc 'uninitialized-dc]
|
|
[buffer-dc 'uninitialized-buffer-dc])
|
|
|
|
(public
|
|
[get-viewport (lambda () viewport)]
|
|
[set-viewport (lambda (x) (set! viewport x))]
|
|
[get-sixlib-height (lambda () height)]
|
|
[get-sixlib-width (lambda () width)]
|
|
[get-current-pen (lambda () current-pen)]
|
|
[get-current-brush (lambda () current-brush)]
|
|
[get-bitmap (lambda () bitmap)]
|
|
[get-sixlib-dc (lambda () dc)]
|
|
[get-buffer-dc (lambda () buffer-dc)]
|
|
[remember-pen (lambda (pen) (set! current-pen pen))]
|
|
[remember-brush (lambda (brush) (set! current-brush brush))])
|
|
|
|
(override
|
|
[on-paint
|
|
(lambda ()
|
|
(let ([bm (send buffer-dc get-bitmap)])
|
|
(send dc draw-bitmap bm 0 0)))]
|
|
|
|
[on-event
|
|
(lambda (mouse-event)
|
|
;; this does deal with mouse events
|
|
;; so let's try and put hooks in here
|
|
;; after I know that it is a "good" sixm mouseclick
|
|
(let* ([x (send mouse-event get-x)]
|
|
[y (send mouse-event get-y)]
|
|
[left? (send mouse-event button-down? 'left)]
|
|
[middle? (send mouse-event button-down? 'middle)]
|
|
[right? (send mouse-event button-down? 'right)]
|
|
[sixm (make-sixmouse x y left? middle? right?)])
|
|
(set! current-mouse-posn (make-posn x y))
|
|
(cond
|
|
[(send mouse-event button-down?)
|
|
(send click-queue add sixm)]
|
|
[(send mouse-event button-up?)
|
|
(send release-queue add sixm)]
|
|
[else (void)])))]
|
|
|
|
[on-char
|
|
(lambda (key-event)
|
|
(let ([the-event (make-sixkey (send key-event get-key-code))])
|
|
;; --- timing stuff : MF 4/4/2004
|
|
(if (procedure? on-char-proc)
|
|
(on-char-proc the-event)
|
|
(send press-queue add the-event))))])
|
|
|
|
;; --- timing stuff : MF 4/4/2004
|
|
(private-field
|
|
[the-world #f]
|
|
;; KeyEvent World -> Void
|
|
[on-char-proc #f]
|
|
[the-time
|
|
(new timer% [notify-callback (lambda () (timer-callback))])]
|
|
[timer-callback
|
|
(lambda ()
|
|
(set! the-world
|
|
(with-handlers ([exn:break? break-handler]
|
|
[exn? exn-handler])
|
|
(on-tick-proc the-world))))]
|
|
;; World -> World
|
|
[on-tick-proc void]
|
|
[exn-handler
|
|
(lambda (e)
|
|
(send the-time stop)
|
|
(set! on-char-proc #f)
|
|
(raise e))]
|
|
[break-handler
|
|
(lambda _
|
|
(printf "animation stopped")
|
|
(send the-time stop)
|
|
(set! on-char-proc #f)
|
|
the-world)])
|
|
(public
|
|
[set-on-char-proc
|
|
(lambda (f)
|
|
(let ([esp (current-eventspace)])
|
|
(if (procedure? on-char-proc)
|
|
(error 'on-event "the event action has been set already")
|
|
(set! on-char-proc
|
|
(lambda (e)
|
|
(parameterize ([current-eventspace esp])
|
|
(queue-callback
|
|
(lambda ()
|
|
(set! the-world
|
|
(with-handlers ([exn:break? break-handler]
|
|
[exn? exn-handler])
|
|
(f e the-world))))
|
|
#t)))))))]
|
|
[set-on-tick-proc ;; Number [seconds] (World -> World) -> Void
|
|
(lambda (delta f)
|
|
(if (eq? on-tick-proc void)
|
|
(set! on-tick-proc f)
|
|
(error 'on-tick "the timing action has been set already"))
|
|
(send the-time start delta))]
|
|
[stop-tick
|
|
(lambda ()
|
|
(send the-time stop)
|
|
(set! on-char-proc #f)
|
|
the-world)]
|
|
[init-world (lambda (w) (set! the-world w))])
|
|
;; --- end timing stuff
|
|
|
|
(public
|
|
[get-click
|
|
(lambda ()
|
|
(send click-queue remove))]
|
|
[get-click-now
|
|
(lambda ()
|
|
(send click-queue remove/wait))]
|
|
|
|
[get-release
|
|
(lambda ()
|
|
(send release-queue remove))]
|
|
[get-release-noew
|
|
(lambda ()
|
|
(send release-queue remove/wait))]
|
|
|
|
[get-press
|
|
(lambda ()
|
|
(send press-queue remove))]
|
|
[get-press-now
|
|
(lambda ()
|
|
(send press-queue remove/wait))]
|
|
|
|
[get-posn (lambda () current-mouse-posn)]
|
|
[set-dc (lambda (new-dc) (set! dc new-dc))]
|
|
[set-buffer-dc (lambda (new-buffer-dc) (set! buffer-dc
|
|
new-buffer-dc))]
|
|
|
|
[set-geometry
|
|
(lambda (new-width new-height)
|
|
(set! height new-height)
|
|
(set! width new-width)
|
|
(reset-size))]
|
|
[set-height (lambda (new-height)
|
|
(set! height new-height)
|
|
(reset-size))]
|
|
[set-width (lambda (new-width)
|
|
(set! width new-width)
|
|
(reset-size))]
|
|
|
|
|
|
[viewport-flush-input
|
|
(lambda ()
|
|
(send click-queue flush)
|
|
(send release-queue flush)
|
|
(send press-queue flush))])))
|
|
|
|
(define open-frames-timer (make-object mred:timer%))
|
|
|
|
;; --- timing events --- MF
|
|
[define the-time---old
|
|
(new timer% [notify-callback (lambda () (timer-callback---old))])]
|
|
[define timer-callback---old void]
|
|
;; --- end timing ---
|
|
|
|
(define sixlib-frame%
|
|
(class mred:frame%
|
|
(field [canvas #f])
|
|
(define/public (set-canvas x) (set! canvas x))
|
|
(define/augment (on-close)
|
|
(close-viewport (send canvas get-viewport))
|
|
(send canvas stop-tick)
|
|
(inner (void) on-close))
|
|
(super-instantiate ()
|
|
[stretchable-height #f]
|
|
[stretchable-width #f]
|
|
[style '(no-resize-border)])))
|
|
|
|
(define repaint
|
|
(lambda (viewport)
|
|
(send (viewport-canvas viewport) on-paint)))
|
|
|
|
(define viewport-dc
|
|
(lambda (viewport)
|
|
(send (viewport-canvas viewport) get-sixlib-dc)))
|
|
|
|
(define viewport-buffer-dc
|
|
(lambda (viewport)
|
|
(send (viewport-canvas viewport) get-buffer-dc)))
|
|
|
|
(define viewport-bitmap
|
|
(lambda (viewport)
|
|
(send (viewport-canvas viewport) get-bitmap)))
|
|
|
|
(define viewport-frame
|
|
(lambda (viewport)
|
|
(send (send (viewport-canvas viewport) get-parent) get-parent)))
|
|
|
|
(define viewport-height
|
|
(lambda (viewport)
|
|
(send (viewport-canvas viewport) get-sixlib-height)))
|
|
|
|
(define viewport-width
|
|
(lambda (viewport)
|
|
(send (viewport-canvas viewport) get-sixlib-width)))
|
|
|
|
(define (get-mouse-click viewport)
|
|
(send (viewport-canvas viewport) get-click-now))
|
|
|
|
(define (init-world viewport)
|
|
(lambda (w)
|
|
(send (viewport-canvas viewport) init-world w)))
|
|
|
|
(define (set-on-key-event viewport)
|
|
(lambda (f)
|
|
(send (viewport-canvas viewport) set-on-char-proc f)))
|
|
|
|
(define (set-on-tick-event viewport)
|
|
(lambda (delta f)
|
|
(send (viewport-canvas viewport) set-on-tick-proc delta f)))
|
|
|
|
(define (stop-tick viewport)
|
|
(lambda ()
|
|
(send (viewport-canvas viewport) stop-tick)))
|
|
|
|
(define (get-key-press viewport)
|
|
(send (viewport-canvas viewport) get-press-now))
|
|
|
|
(define (ready-mouse-click viewport)
|
|
(send (viewport-canvas viewport) get-click))
|
|
|
|
(define (ready-mouse-release viewport)
|
|
(send (viewport-canvas viewport) get-release))
|
|
|
|
(define (ready-key-press viewport)
|
|
(send (viewport-canvas viewport) get-press))
|
|
|
|
(define mouse-click-posn
|
|
(lambda (mouse-event)
|
|
(make-posn (sixmouse-x mouse-event) (sixmouse-y mouse-event))))
|
|
|
|
(define query-mouse-posn
|
|
(lambda (viewport) (send (viewport-canvas viewport) get-posn)))
|
|
|
|
(define viewport-flush-input
|
|
(lambda (viewport) (send (viewport-canvas viewport) viewport-flush-input)))
|
|
|
|
(define left-mouse-click?
|
|
(lambda (mouse-event) (sixmouse-left? mouse-event)))
|
|
|
|
(define middle-mouse-click?
|
|
(lambda (mouse-event) (sixmouse-middle? mouse-event)))
|
|
|
|
(define right-mouse-click?
|
|
(lambda (mouse-event) (sixmouse-right? mouse-event)))
|
|
|
|
(define key-value sixkey-value)
|
|
|
|
(define clear-viewport
|
|
(lambda (viewport)
|
|
(let* ([vdc (viewport-dc viewport)]
|
|
[vbdc (viewport-buffer-dc viewport)])
|
|
(lambda ()
|
|
(send vdc clear)
|
|
(send vbdc clear)))))
|
|
|
|
(define draw-viewport
|
|
(lambda (viewport)
|
|
(let* ([dc (viewport-dc viewport)]
|
|
[buffer-dc (viewport-buffer-dc viewport)]
|
|
[w (viewport-width viewport)]
|
|
[h (viewport-height viewport)])
|
|
(rec draw-viewport/color
|
|
(case-lambda
|
|
[(color)
|
|
(let ([new-pen (send mred:the-pen-list find-or-create-pen color 1 'solid)]
|
|
[new-brush (send mred:the-brush-list find-or-create-brush color 'solid)]
|
|
[old-pen (send dc get-pen)]
|
|
[old-brush (send dc get-brush)])
|
|
(send dc set-pen new-pen)
|
|
(send dc set-brush new-brush)
|
|
(send buffer-dc set-pen new-pen)
|
|
(send buffer-dc set-brush new-brush)
|
|
(send dc draw-rectangle 0 0 w h)
|
|
(send buffer-dc draw-rectangle 0 0 w h)
|
|
(send dc set-pen old-pen)
|
|
(send buffer-dc set-pen old-pen)
|
|
(send dc set-brush old-brush)
|
|
(send buffer-dc set-brush old-brush))]
|
|
[() (draw-viewport/color (make-rgb 0 0 0))])))))
|
|
|
|
(define flip-viewport
|
|
(lambda (viewport)
|
|
(let* ([dc (viewport-dc viewport)]
|
|
[dc2 (viewport-buffer-dc viewport)]
|
|
[w (viewport-width viewport)]
|
|
[h (viewport-height viewport)])
|
|
(lambda ()
|
|
(let ([pen (send dc get-pen)]
|
|
[pen2 (send dc2 get-pen)]
|
|
[brush (send dc get-brush)]
|
|
[brush2 (send dc2 get-brush)])
|
|
(send dc set-pen xor-pen)
|
|
(send dc2 set-pen xor-pen)
|
|
(send dc set-brush xor-brush)
|
|
(send dc2 set-brush xor-brush)
|
|
(send dc draw-rectangle 0 0 w h)
|
|
(send dc2 draw-rectangle 0 0 w h)
|
|
(send dc set-pen pen)
|
|
(send dc2 set-pen pen2)
|
|
(send dc set-brush brush)
|
|
(send dc2 set-brush brush2))))))
|
|
|
|
(define close-viewport
|
|
(lambda (viewport)
|
|
(set! global-viewport-list
|
|
(let loop ([l global-viewport-list])
|
|
(cond
|
|
[(null? l) '()]
|
|
[(eq? (car l) viewport) (cdr l)]
|
|
[else (cons (car l) (loop (cdr l)))])))
|
|
(send (viewport-frame viewport) show #f)
|
|
(send (viewport-canvas viewport) show #f)
|
|
(when (null? global-viewport-list)
|
|
(send open-frames-timer stop))))
|
|
|
|
(define open-graphics
|
|
(lambda ()
|
|
(set! graphics-flag #t)))
|
|
|
|
(define close-graphics
|
|
(lambda ()
|
|
(map close-viewport global-viewport-list)
|
|
(set! graphics-flag #f)
|
|
(set! global-viewport-list '())
|
|
(send open-frames-timer stop)))
|
|
|
|
(define graphics-open? (lambda () graphics-flag))
|
|
|
|
(define make-rgb
|
|
(lambda (red green blue)
|
|
(when (or (< red 0.) (< blue 0.) (< green 0.)
|
|
(> red 1.) (> blue 1.) (> green 1.))
|
|
(error 'make-rgb
|
|
"all color indices should be in [0.0, 1.0]; provided ~s"
|
|
(list red green blue)))
|
|
(let* ([convert (lambda (num) (inexact->exact (round (* 255 num))))]
|
|
[nred (convert red)]
|
|
[ngreen (convert green)]
|
|
[nblue (convert blue)])
|
|
(make-object mred:color% nred ngreen nblue))))
|
|
|
|
(define make-color make-rgb)
|
|
|
|
(define (rgb-red rgb) (/ (send rgb red) 255))
|
|
(define (rgb-blue rgb) (/ (send rgb blue) 255))
|
|
(define (rgb-green rgb) (/ (send rgb green) 255))
|
|
|
|
(define rgb? (lambda (object) (is-a? object mred:color%)))
|
|
(define (color? x)
|
|
(or (rgb? x)
|
|
(not (not (send mred:the-color-database find-color x)))))
|
|
|
|
(define change-color
|
|
(lambda (index color)
|
|
(vector-set! global-color-vector index color)
|
|
(vector-set! global-pen-vector index (get-pen color))
|
|
(vector-set! global-brush-vector index (get-brush color))))
|
|
|
|
(define (get-color index)
|
|
(cond
|
|
[(is-a? index mred:color%) index]
|
|
[(string? index) (make-object mred:color% index)]
|
|
[else (vector-ref global-color-vector index)]))
|
|
|
|
(define get-pen
|
|
(lambda (index)
|
|
(cond
|
|
[(is-a? index mred:pen%) index]
|
|
[(or (string? index) (is-a? index mred:color%))
|
|
(send mred:the-pen-list find-or-create-pen index 1 'solid)]
|
|
[else (vector-ref global-pen-vector index)])))
|
|
|
|
(define get-brush
|
|
(lambda (index)
|
|
(cond
|
|
[(is-a? index mred:brush%) index]
|
|
[(or (string? index) (is-a? index mred:color%))
|
|
(send mred:the-brush-list find-or-create-brush index 'solid)]
|
|
[else (vector-ref global-brush-vector index)])))
|
|
|
|
(define pen? (lambda (object) (is-a? object mred:pen%)))
|
|
(define brush? (lambda (object) (is-a? object mred:brush%)))
|
|
|
|
(define display-color-vector
|
|
(lambda ()
|
|
(do
|
|
([index 0 (+ index 1)])
|
|
((eq? index 100))
|
|
(display (list (/ (rgb-red (get-color index)) 255)
|
|
(/ (rgb-green (get-color index)) 255)
|
|
(/ (rgb-blue (get-color index)) 255))))))
|
|
|
|
(define make-font
|
|
(lambda (name)
|
|
(cond
|
|
[(eq? name 'large-deco)
|
|
(make-object mred:font% 40 'decorative 'normal 'normal)]
|
|
[(eq? name 'small-roman)
|
|
(make-object mred:font% 12 'roman 'normal 'normal)]
|
|
[(eq? name 'medium-roman)
|
|
(make-object mred:font% 24 'roman 'normal 'normal)]
|
|
[(eq? name 'large-roman)
|
|
(make-object mred:font% 32 'roman 'normal 'normal)]
|
|
[else "no such font ~a; only 'large-deco, 'small-roman, 'medium-roman, and 'large-roman"
|
|
name])))
|
|
|
|
(define custom-roman
|
|
(lambda (size)
|
|
(make-object mred:font%
|
|
size 'roman 'normal 'normal)))
|
|
|
|
(define custom-deco
|
|
(lambda (size)
|
|
(make-object mred:font% size 'decorative 'normal 'normal)))
|
|
|
|
(define set-viewport-pen
|
|
(lambda (viewport pen)
|
|
(send (viewport-canvas viewport) remember-pen pen)
|
|
(let ([pen (get-pen pen)])
|
|
(send (viewport-dc viewport) set-pen pen)
|
|
(send (viewport-buffer-dc viewport) set-pen pen))))
|
|
|
|
(define set-viewport-brush
|
|
(lambda (viewport brush)
|
|
(send (viewport-canvas viewport) remember-brush brush)
|
|
(let ([brush (get-brush brush)])
|
|
(send (viewport-dc viewport) set-brush brush)
|
|
(send (viewport-buffer-dc viewport) set-brush brush))))
|
|
|
|
(define set-text-foreground
|
|
(lambda (viewport color)
|
|
(let ([color (get-color color)])
|
|
(send (viewport-dc viewport) set-text-foreground color)
|
|
(send (viewport-buffer-dc viewport) set-text-foreground color))))
|
|
|
|
(define set-text-background
|
|
(lambda (viewport color)
|
|
(let ([color (get-color color)])
|
|
(send (viewport-dc viewport) set-text-background color)
|
|
(send (viewport-buffer-dc viewport) set-text-background color))))
|
|
|
|
(define set-viewport-font
|
|
(lambda (viewport font)
|
|
(send (viewport-dc viewport) set-font font)
|
|
(send (viewport-buffer-dc viewport) set-font font)))
|
|
|
|
(define set-viewport-background
|
|
(lambda (viewport color)
|
|
(send (viewport-dc viewport) set-background color)
|
|
(send (viewport-buffer-dc viewport) set-background color)))
|
|
|
|
(define set-viewport-logical-function
|
|
(lambda (viewport logical-function)
|
|
(send (viewport-dc viewport) set-logical-function logical-function)
|
|
(send (viewport-buffer-dc viewport) set-logical-function
|
|
logical-function)))
|
|
|
|
(define white (make-rgb 1 1 1))
|
|
(define black (make-rgb 0 0 0))
|
|
(define red (make-rgb 1 0 0))
|
|
(define green (make-rgb 0 1 0))
|
|
(define blue (make-rgb 0 0 1))
|
|
(define white-pen (get-pen white))
|
|
(define black-pen (get-pen black))
|
|
(define red-pen (get-pen red))
|
|
(define blue-pen (get-pen blue))
|
|
(define green-pen (get-pen green))
|
|
(define white-brush (get-brush white))
|
|
(define black-brush (get-brush black))
|
|
(define red-brush (get-brush red))
|
|
(define green-brush (get-brush green))
|
|
(define blue-brush (get-brush blue))
|
|
|
|
(define invisi-pen (send mred:the-pen-list find-or-create-pen "WHITE" 0 'transparent))
|
|
(define invisi-brush (send mred:the-brush-list find-or-create-brush "WHITE" 'transparent))
|
|
|
|
(define xor-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'xor))
|
|
(define xor-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'xor))
|
|
|
|
(define draw-it (lambda (draw flip clear) (draw)))
|
|
(define flip-it (lambda (draw flip clear) (flip)))
|
|
(define clear-it (lambda (draw flip clear) (clear)))
|
|
|
|
(define make-draw-proc
|
|
(lambda (get-pen-name set-pen-name
|
|
get-current-pen-name set-viewport-pen white-pen)
|
|
(lambda (viewport)
|
|
(let* ([vdc (viewport-dc viewport)]
|
|
[vbdc (viewport-buffer-dc viewport)])
|
|
(lambda (color go)
|
|
(let ([orig (and color
|
|
(begin0
|
|
(send/proc2 (viewport-canvas viewport)
|
|
get-current-pen-name)
|
|
(set-viewport-pen viewport (get-color color))))])
|
|
(go (lambda (draw)
|
|
(let ([pen (send vdc get-pen)]
|
|
[brush (send vdc get-brush)])
|
|
(send vdc set-brush xor-brush)
|
|
(send vbdc set-brush xor-brush)
|
|
(send vdc set-pen xor-pen)
|
|
(send vbdc set-pen xor-pen)
|
|
(draw)
|
|
(send vdc set-brush brush)
|
|
(send vbdc set-brush brush)
|
|
(send vdc set-pen pen)
|
|
(send vbdc set-pen pen)))
|
|
(lambda (draw)
|
|
(let ([pen (send/proc vdc get-pen-name)])
|
|
(send/proc vdc set-pen-name white-pen)
|
|
(send/proc vbdc set-pen-name white-pen)
|
|
(draw)
|
|
(send/proc vdc set-pen-name pen)
|
|
(send/proc vbdc set-pen-name pen))))
|
|
(when orig
|
|
(set-viewport-pen viewport orig))))))))
|
|
|
|
(define make-do-line
|
|
(lambda (go)
|
|
(let ([f (make-draw-proc 'get-pen 'set-pen
|
|
'get-current-pen set-viewport-pen white-pen)])
|
|
(lambda (viewport)
|
|
(let ([f (f viewport)])
|
|
(letrec ([the-function
|
|
(case-lambda
|
|
[(posn1 posn2) (the-function posn1 posn2 #f)]
|
|
[(posn1 posn2 color)
|
|
(f color
|
|
(lambda (flip clear)
|
|
(let* ([x1 (posn-x posn1)]
|
|
[y1 (posn-y posn1)]
|
|
[x2 (posn-x posn2)]
|
|
[y2 (posn-y posn2)]
|
|
[draw (lambda ()
|
|
(send (viewport-dc viewport)
|
|
draw-line
|
|
x1 y1 x2 y2)
|
|
(send (viewport-buffer-dc viewport)
|
|
draw-line
|
|
x1 y1 x2 y2))])
|
|
(go draw
|
|
(lambda () (flip draw))
|
|
(lambda () (clear draw))))))])])
|
|
the-function))))))
|
|
|
|
(define draw-line (make-do-line draw-it))
|
|
(define (clear-line viewport)
|
|
(let ([f ((make-do-line clear-it) viewport)])
|
|
(rec clear-line-viewport
|
|
(lambda (p1 p2)
|
|
(f p1 p2)))))
|
|
(define (flip-line viewport)
|
|
(let ([f ((make-do-line flip-it) viewport)])
|
|
(rec flip-line-viewport
|
|
(lambda (p1 p2)
|
|
(f p1 p2)))))
|
|
|
|
(define (draw/clear/flip ivar)
|
|
(lambda (init-dc viewport p width height)
|
|
(let ([dc (viewport-dc viewport)]
|
|
[buffer-dc (viewport-buffer-dc viewport)])
|
|
(init-dc dc)
|
|
(init-dc buffer-dc)
|
|
(send/proc dc ivar (posn-x p) (posn-y p) width height)
|
|
(send/proc buffer-dc ivar (posn-x p) (posn-y p) width height))))
|
|
|
|
(define draw/clear/flip-rectangle (draw/clear/flip 'draw-rectangle))
|
|
(define draw/clear/flip-ellipse (draw/clear/flip 'draw-ellipse))
|
|
|
|
(define (draw-rectangle viewport)
|
|
(check-viewport 'draw-rectangle viewport)
|
|
(rec draw-rectangle-viewport
|
|
(case-lambda
|
|
[(p width height) (draw-rectangle-viewport p width height (make-rgb 0 0 0))]
|
|
[(p width height color)
|
|
(check 'draw-rectangle
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number"
|
|
(orp color? number?) color "color or index")
|
|
(draw/clear/flip-rectangle
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
|
|
viewport p width height)])))
|
|
|
|
(define (draw-solid-rectangle viewport)
|
|
(check-viewport 'draw-solid-rectangle viewport)
|
|
(rec draw-solid-rectangle-viewport
|
|
(case-lambda
|
|
[(p width height) (draw-solid-rectangle-viewport p width height (make-rgb 0 0 0))]
|
|
[(p width height color)
|
|
(check 'draw-solid-rectangle
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number"
|
|
(orp color? number?) color "color or index")
|
|
(draw/clear/flip-rectangle
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'solid)))
|
|
viewport p width height)])))
|
|
|
|
(define (flip-rectangle viewport)
|
|
(check-viewport 'flip-rectangle viewport)
|
|
(rec flip-rectangle-viewport
|
|
(case-lambda
|
|
[(p width height) (flip-rectangle-viewport p width height (make-rgb 0 0 0))]
|
|
[(p width height color)
|
|
(check 'flip-rectangle
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number"
|
|
(orp color? number?) color "color or index")
|
|
(draw/clear/flip-rectangle
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'xor))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
|
|
viewport p width height)])))
|
|
|
|
(define (flip-solid-rectangle viewport)
|
|
(check-viewport 'flip-solid-rectangle viewport)
|
|
(rec flip-solid-rectangle-viewport
|
|
(case-lambda
|
|
[(p width height) (flip-solid-rectangle-viewport p width height (make-rgb 0 0 0))]
|
|
[(p width height color)
|
|
(check 'flip-solid-rectangle
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number"
|
|
(orp color? number?) color "color or index")
|
|
(draw/clear/flip-rectangle
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'xor)))
|
|
viewport p width height)])))
|
|
|
|
(define (draw-ellipse viewport)
|
|
(check-viewport 'draw-ellipse viewport)
|
|
(rec draw-ellipse-viewport
|
|
(case-lambda
|
|
[(p width height) (draw-ellipse-viewport p width height (make-rgb 0 0 0))]
|
|
[(p width height color)
|
|
(check 'draw-ellipse
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number"
|
|
(orp color? number?) color "color or index")
|
|
(draw/clear/flip-ellipse
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
|
|
viewport p width height)])))
|
|
|
|
(define (draw-solid-ellipse viewport)
|
|
(check-viewport 'draw-solid-ellipse viewport)
|
|
(rec draw-solid-ellipse-viewport
|
|
(case-lambda
|
|
[(p width height) (draw-solid-ellipse-viewport p width height (make-rgb 0 0 0))]
|
|
[(p width height color)
|
|
(check 'draw-solid-ellipse
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number"
|
|
(orp color? number?) color "color or index")
|
|
(draw/clear/flip-ellipse
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'solid))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'solid)))
|
|
viewport p width height)])))
|
|
|
|
(define (flip-ellipse viewport)
|
|
(check-viewport 'flip-ellipse viewport)
|
|
(rec flip-ellipse-viewport
|
|
(case-lambda
|
|
[(p width height) (flip-ellipse-viewport p width height (make-rgb 0 0 0))]
|
|
[(p width height color)
|
|
(check 'flip-ellipse
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number"
|
|
(orp color? number?) color "color or index")
|
|
(draw/clear/flip-ellipse
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen (get-color color) 1 'xor))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
|
|
viewport p width height)])))
|
|
|
|
(define (flip-solid-ellipse viewport)
|
|
(check-viewport 'flip-solid-rectangle viewport)
|
|
(rec flip-solid-ellipse-viewport
|
|
(case-lambda
|
|
[(p width height) (flip-solid-ellipse-viewport p width height (make-rgb 0 0 0))]
|
|
[(p width height color)
|
|
(check 'flip-solid-ellipse
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number"
|
|
(orp color? number?) color "color or index")
|
|
(draw/clear/flip-ellipse
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen "BLACK" 1 'transparent))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush (get-color color) 'xor)))
|
|
viewport p width height)])))
|
|
|
|
(define (clear-rectangle viewport)
|
|
(check-viewport 'clear-rectangle viewport)
|
|
(rec clear-rectangle-viewport
|
|
(lambda (p width height)
|
|
(check 'clear-rectangle
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number")
|
|
(draw/clear/flip-rectangle
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
|
|
viewport p width height))))
|
|
|
|
(define (clear-solid-rectangle viewport)
|
|
(check-viewport 'clear-solid-rectangle viewport)
|
|
(rec clear-solid-rectangle-viewport
|
|
(lambda (p width height)
|
|
(check 'clear-solid-rectangle
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number")
|
|
(draw/clear/flip-rectangle
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush "WHITE" 'solid)))
|
|
viewport p width height))))
|
|
|
|
(define (clear-ellipse viewport)
|
|
(check-viewport 'clear-ellipse viewport)
|
|
(rec clear-ellipse-viewport
|
|
(lambda (p width height)
|
|
(check 'clear-ellipse
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number")
|
|
(draw/clear/flip-ellipse
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush "BLACK" 'transparent)))
|
|
viewport p width height))))
|
|
|
|
(define (clear-solid-ellipse viewport)
|
|
(check-viewport 'clear-solid-ellipse viewport)
|
|
(rec clear-solid-ellipse-viewport
|
|
(lambda (p width height)
|
|
(check 'clear-solid-ellipse
|
|
posn? p "posn"
|
|
number? width "number"
|
|
number? height "number")
|
|
(draw/clear/flip-ellipse
|
|
(lambda (dc)
|
|
(send dc set-pen (send mred:the-pen-list find-or-create-pen "WHITE" 1 'solid))
|
|
(send dc set-brush (send mred:the-brush-list find-or-create-brush "WHITE" 'solid)))
|
|
viewport p width height))))
|
|
|
|
(define make-do-pointlist
|
|
(lambda (go name get-pen-name set-pen-name
|
|
get-current-pen-name set-viewport-pen white-pen
|
|
get-brush-name set-brush-name invisi-brush)
|
|
(let ([f (make-draw-proc get-pen-name set-pen-name
|
|
get-current-pen-name set-viewport-pen white-pen)])
|
|
(lambda (viewport)
|
|
(let ([f (f viewport)]
|
|
[vdc (viewport-dc viewport)]
|
|
[vbdc (viewport-buffer-dc viewport)])
|
|
(letrec ([the-function
|
|
(case-lambda
|
|
[(posns offset) (the-function posns offset #f)]
|
|
[(posns offset color)
|
|
(f color
|
|
(lambda (flip clear)
|
|
(let* ([points (map (lambda (p)
|
|
(make-object mred:point% (posn-x p) (posn-y p)))
|
|
posns)]
|
|
[x (posn-x offset)]
|
|
[y (posn-y offset)]
|
|
[orig (send/proc vdc get-brush-name)]
|
|
[draw (lambda ()
|
|
(send/proc vdc set-brush-name
|
|
invisi-brush)
|
|
(send/proc vbdc set-brush-name
|
|
invisi-brush)
|
|
(send/proc
|
|
(viewport-dc viewport) name
|
|
points x y)
|
|
(send/proc
|
|
(viewport-buffer-dc viewport) name
|
|
points x y)
|
|
(send/proc vdc set-brush-name orig)
|
|
(send/proc vbdc set-brush-name
|
|
orig))])
|
|
(go draw
|
|
(lambda () (flip draw))
|
|
(lambda () (clear draw))))))])])
|
|
the-function))))))
|
|
|
|
(define make-do-polygon
|
|
(lambda (go)
|
|
(make-do-pointlist go 'draw-polygon 'get-pen 'set-pen
|
|
'get-current-pen set-viewport-pen white-pen
|
|
'get-brush 'set-brush invisi-brush)))
|
|
|
|
(define make-do-solid-polygon
|
|
(lambda (go)
|
|
(make-do-pointlist go 'draw-polygon 'get-brush 'set-brush
|
|
'get-current-brush set-viewport-brush white-brush
|
|
'get-pen 'set-pen invisi-pen)))
|
|
|
|
(define draw-polygon (make-do-polygon draw-it))
|
|
(define (clear-polygon viewport)
|
|
(let ([f ((make-do-polygon clear-it) viewport)])
|
|
(rec clear-polygon-viewport
|
|
(lambda (posns offset)
|
|
(f posns offset)))))
|
|
(define (flip-polygon viewport)
|
|
(let ([f ((make-do-polygon flip-it) viewport)])
|
|
(rec flip-polygon-viewport
|
|
(lambda (posns offset)
|
|
(f posns offset)))))
|
|
|
|
(define draw-solid-polygon (make-do-solid-polygon draw-it))
|
|
(define (clear-solid-polygon viewport)
|
|
(let ([f ((make-do-solid-polygon clear-it) viewport)])
|
|
(rec clear-solid-polygon-viewport
|
|
(lambda (posns offset)
|
|
(f posns offset)))))
|
|
(define (flip-solid-polygon viewport)
|
|
(let ([f ((make-do-solid-polygon flip-it) viewport)])
|
|
(rec flip-solid-polygon-viewport
|
|
(lambda (posns offset)
|
|
(f posns offset)))))
|
|
|
|
(define make-do-pixel
|
|
(lambda (go)
|
|
(let ([f (make-draw-proc 'get-pen 'set-pen
|
|
'get-current-pen set-viewport-pen white-pen)])
|
|
(lambda (viewport)
|
|
(let ([f (f viewport)])
|
|
(letrec ([the-function
|
|
(case-lambda
|
|
[(posn) (the-function posn #f)]
|
|
[(posn color)
|
|
(f color
|
|
(lambda (flip clear)
|
|
(let* ([x (posn-x posn)]
|
|
[y (posn-y posn)]
|
|
[draw (lambda ()
|
|
(send
|
|
(viewport-dc viewport) draw-point
|
|
x y)
|
|
(send
|
|
(viewport-buffer-dc viewport)
|
|
draw-point
|
|
x y))])
|
|
(go draw
|
|
(lambda () (flip draw))
|
|
(lambda () (clear draw))))))])])
|
|
the-function))))))
|
|
|
|
(define-do-pixel draw-pixel draw-it draw-pixel-viewport make-do-pixel)
|
|
(define-do-pixel clear-pixel clear-it clear-pixel-viewport make-do-pixel)
|
|
(define-do-pixel flip-pixel flip-it flip-pixel-viewport make-do-pixel)
|
|
|
|
(define string-functions
|
|
(lambda (string-op)
|
|
(letrec ([outer-function
|
|
(case-lambda
|
|
[(viewport) (outer-function viewport default-font)]
|
|
[(viewport font)
|
|
(letrec ([the-function
|
|
(case-lambda
|
|
[(posn text) (the-function posn text #f)]
|
|
[(posn text color)
|
|
(let*-values ([(dc) (viewport-dc viewport)]
|
|
[(x) (posn-x posn)]
|
|
[(w h d a) (send dc get-text-extent "X" font)]
|
|
[(y) (- (posn-y posn) (- h d))]
|
|
[(buffer) (viewport-buffer-dc viewport)]
|
|
[(string-create)
|
|
(lambda ()
|
|
(send dc draw-text text x y)
|
|
(send buffer draw-text text x y))])
|
|
(cond
|
|
[(eq? string-op 'draw)
|
|
(when color
|
|
(set-text-foreground viewport color))
|
|
(set-viewport-font viewport font)
|
|
(send dc draw-text text x y)
|
|
(send buffer draw-text text x y)]
|
|
[(eq? string-op 'flip)
|
|
(when color
|
|
(set-text-foreground viewport color))
|
|
(set-viewport-font viewport font)
|
|
(string-create)]
|
|
[(eq? string-op 'clear)
|
|
(set-text-foreground viewport white)
|
|
(set-viewport-font viewport font)
|
|
(string-create)
|
|
(set-text-foreground viewport black)]))])])
|
|
the-function)])])
|
|
outer-function)))
|
|
|
|
(define-string draw-string draw draw-string-viewport string-functions)
|
|
(define-string clear-string clear clear-string-viewport string-functions)
|
|
(define-string flip-string flip flip-string-viewport string-functions)
|
|
|
|
(define get-string-size
|
|
(case-lambda
|
|
[(viewport) (get-string-size viewport default-font)]
|
|
[(viewport font)
|
|
(lambda (text)
|
|
(let-values ([(w h d a) (send (viewport-dc viewport) get-text-extent text font)])
|
|
(list w h)))]))
|
|
|
|
(define get-color-pixel
|
|
(lambda (viewport)
|
|
(lambda (posn)
|
|
(let ([c (make-object mred:color%)]
|
|
[x (posn-x posn)]
|
|
[y (posn-y posn)])
|
|
(unless (send (viewport-buffer-dc viewport) get-pixel x y c)
|
|
(error 'get-color-pixel "specified point is out-of-range"))
|
|
c))))
|
|
|
|
(define get-pixel
|
|
(lambda (viewport)
|
|
(lambda (posn)
|
|
(let ([c (make-object mred:color%)]
|
|
[x (posn-x posn)]
|
|
[y (posn-y posn)])
|
|
(unless (send (viewport-buffer-dc viewport) get-pixel x y c)
|
|
(error 'get-pixel "specified point is out-of-range"))
|
|
(if (or (< (send c blue) 255)
|
|
(< (send c red) 255)
|
|
(< (send c green) 255))
|
|
1
|
|
0)))))
|
|
|
|
(define (test-pixel viewport)
|
|
(lambda (color)
|
|
(let ([c (make-object mred:color%)])
|
|
(send (viewport-buffer-dc viewport) try-color color c)
|
|
c)))
|
|
|
|
(define draw-pixmap-posn
|
|
(opt-lambda (filename [type 'unknown/mask])
|
|
(check 'draw-pixmap-posn
|
|
(andp path-string? file-exists?) filename "filename"
|
|
(lambda (x) (memq x '(gif xbm xpm bmp pict unknown unknown/mask gif/mask))) type "file type symbol")
|
|
(let* ([bitmap (make-object mred:bitmap% filename type)])
|
|
(lambda (viewport)
|
|
(check 'draw-pixmap-posn
|
|
viewport? viewport "viewport")
|
|
(opt-lambda (posn [color #f])
|
|
(check 'draw-pixmap-posn
|
|
posn? posn "posn"
|
|
(orp not color?) color (format "color or ~e" #f))
|
|
(when color
|
|
(set-viewport-pen viewport (get-color color)))
|
|
(let ([x (posn-x posn)]
|
|
[y (posn-y posn)])
|
|
(send (viewport-dc viewport) draw-bitmap bitmap x y 'solid black-color (send bitmap get-loaded-mask))
|
|
(send (viewport-buffer-dc viewport) draw-bitmap bitmap x y 'solid black-color (send bitmap get-loaded-mask))))))))
|
|
|
|
(define draw-pixmap
|
|
(lambda (viewport)
|
|
(check 'draw-pixmap
|
|
viewport? viewport "viewport")
|
|
(opt-lambda (filename p [color #f])
|
|
(check 'draw-pixmap
|
|
(andp path-string? file-exists?) filename "filename"
|
|
posn? p "posn"
|
|
(orp not color?) color (format "color or ~e" #f))
|
|
(((draw-pixmap-posn filename 'unknown) viewport) p color))))
|
|
|
|
(define copy-viewport
|
|
(lambda (source target)
|
|
(check 'copy-viewport
|
|
viewport? source "viewport"
|
|
viewport? target "viewport")
|
|
(let* ([source-bitmap (viewport-bitmap source)]
|
|
[target-dc (viewport-dc target)]
|
|
[target-buffer-dc (viewport-buffer-dc target)])
|
|
(send target-dc draw-bitmap source-bitmap 0 0)
|
|
(send target-buffer-dc draw-bitmap source-bitmap 0 0))))
|
|
|
|
(define save-pixmap
|
|
(lambda (viewport)
|
|
(check 'save-pixmap
|
|
viewport? viewport "viewport")
|
|
(opt-lambda (filename [kind 'xpm])
|
|
(check 'save-pixmap
|
|
(andp path-string? (orp relative-path? absolute-path?)) filename "filename"
|
|
(lambda (x) (memq x '(xpm xbm bmp pict))) kind "file type symbol")
|
|
(let ([bm (viewport-bitmap viewport)])
|
|
(send bm save-file filename kind)))))
|
|
|
|
(define sixlib-eventspace #f)
|
|
|
|
(define make-open-viewport
|
|
(lambda (name show?)
|
|
(unless sixlib-eventspace
|
|
(set! sixlib-eventspace
|
|
(parameterize ([uncaught-exception-handler
|
|
(lambda (x)
|
|
((error-display-handler)
|
|
(format "internal error in graphics library: ~a"
|
|
(if (exn? x)
|
|
(exn-message x)
|
|
(format "~e" x))))
|
|
((error-escape-handler)))])
|
|
(mred:make-eventspace))))
|
|
(letrec ([open-viewport
|
|
(case-lambda
|
|
[(label point)
|
|
(cond
|
|
[(posn? point) (open-viewport label (posn-x point) (posn-y point))]
|
|
[(and (list? point) (= (length point) 2))
|
|
(open-viewport label (car point) (cadr point))]
|
|
[else (error name "bad argument ~s" point)])]
|
|
[(label width height)
|
|
(cond
|
|
[graphics-flag
|
|
(let*
|
|
([frame
|
|
(parameterize ([mred:current-eventspace sixlib-eventspace])
|
|
(make-object sixlib-frame% label #f width height))]
|
|
[panel (make-object mred:vertical-panel% frame)]
|
|
[canvas (make-object sixlib-canvas% panel)]
|
|
[_ (begin
|
|
(send canvas min-height height)
|
|
(send canvas min-width width))]
|
|
[dc (send canvas get-dc)]
|
|
[buffer-dc (make-object mred:bitmap-dc%)]
|
|
[viewport (make-viewport label canvas)])
|
|
(send panel set-alignment 'center 'center)
|
|
(send frame set-canvas canvas)
|
|
(send canvas set-viewport viewport)
|
|
(send canvas set-dc dc)
|
|
(send canvas set-buffer-dc buffer-dc)
|
|
(send canvas set-geometry width height)
|
|
(when show?
|
|
(send frame show #t)
|
|
(send canvas focus))
|
|
(set-text-foreground viewport black)
|
|
(set-text-background viewport white)
|
|
(set-viewport-background viewport white)
|
|
(set-viewport-pen viewport black-pen)
|
|
(set-viewport-brush viewport black-brush)
|
|
((clear-viewport viewport))
|
|
(when (null? global-viewport-list)
|
|
(send open-frames-timer start 100000000))
|
|
(set! global-viewport-list (cons viewport global-viewport-list))
|
|
viewport)]
|
|
[else (error "graphics not open")])])])
|
|
open-viewport)))
|
|
|
|
(define open-viewport (make-open-viewport 'open-viewport #t))
|
|
(define open-pixmap (make-open-viewport 'open-pixmap #f))
|
|
|
|
(define (default-display-is-color?) (mred:is-color-display?))
|
|
|
|
(define position-display
|
|
(lambda (viewport counter)
|
|
(cond
|
|
[(equal? counter 0) '()]
|
|
[else (begin
|
|
(display (query-mouse-posn viewport))
|
|
(position-display viewport (- counter 1)))])))
|
|
|
|
(define create-cmap
|
|
(lambda ()
|
|
(do ([index 0 (+ 1 index)])
|
|
((> index 20))
|
|
(let* ([r (* 0.05 index)]
|
|
[b (- 1 r)]
|
|
[g (- 1 r)])
|
|
(change-color index (make-rgb r g b))))))
|
|
|
|
(define viewport->snip
|
|
(lambda (viewport)
|
|
(let ([orig-bitmap (send (viewport-canvas viewport) get-bitmap)]
|
|
[orig-dc (viewport-buffer-dc viewport)])
|
|
(let* ([h (send orig-bitmap get-height)]
|
|
[w (send orig-bitmap get-width)]
|
|
[new-bitmap (make-object mred:bitmap% w h)]
|
|
[tmp-mem-dc (make-object mred:bitmap-dc%)])
|
|
(send tmp-mem-dc set-bitmap new-bitmap)
|
|
(send tmp-mem-dc draw-bitmap (send orig-dc get-bitmap) 0 0)
|
|
(send tmp-mem-dc set-bitmap #f)
|
|
(let ([snip (make-object mred:image-snip%)])
|
|
(send snip set-bitmap new-bitmap)
|
|
snip)))))
|
|
|
|
(create-cmap)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; ;;;
|
|
;;; ERROR CHECKING ;;;
|
|
;;; ;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;; check-viewport : symbol TST -> void
|
|
(define (check-viewport f-name obj)
|
|
(unless (viewport? obj)
|
|
(error f-name "expected viewport as first argument, got ~e" obj)))
|
|
|
|
;; (define-type arg/pred/name-list (list* (TST -> bool) TST string arg/pred/name-list))
|
|
;; check : (symbol arg/pred/name-list *-> void)
|
|
(define (check f-name . in-args)
|
|
(let loop ([args in-args]
|
|
[n 0])
|
|
(cond
|
|
[(null? args) (void)]
|
|
[else (let ([pred? (car args)]
|
|
[val (cadr args)]
|
|
[name (caddr args)])
|
|
(unless (pred? val)
|
|
(error f-name "expected ~a as arg ~a, got: ~e, all args: ~a"
|
|
name n val
|
|
(let loop ([args in-args])
|
|
(cond
|
|
[(null? args) ""]
|
|
[else (string-append (format "~e" (cadr args))
|
|
" "
|
|
(loop (cdddr args)))]))))
|
|
(loop (cdddr args)
|
|
(+ n 1)))])))
|
|
|
|
(define (orp . preds)
|
|
(lambda (TST)
|
|
(ormap (lambda (p) (p TST)) preds)))
|
|
|
|
(define (andp . preds)
|
|
(lambda (TST)
|
|
(andmap (lambda (p) (p TST)) preds)))
|
|
)
|
|
)
|