#| -*-Scheme-*-
-$Id: os2graph.scm,v 1.4 1995/02/08 01:20:19 cph Exp $
+$Id: os2graph.scm,v 1.5 1995/02/14 00:36:58 cph Exp $
Copyright (c) 1995 Massachusetts Institute of Technology
(define (initialize-package!)
(set! os2-graphics-device-type
(make-graphics-device-type
- `((available? ,os2-graphics/available?)
+ `((activate-window ,os2-graphics/activate-window)
+ (available? ,os2-graphics/available?)
(clear ,os2-graphics/clear)
(close ,os2-graphics/close)
(color? ,os2-graphics/color?)
(coordinate-limits ,os2-graphics/coordinate-limits)
+ (deactivate-window ,os2-graphics/deactivate-window)
(define-color ,os2-graphics/define-color)
(desktop-size ,os2-graphics/desktop-size)
(device-coordinate-limits ,os2-graphics/device-coordinate-limits)
(os2-graphics/define-color #f (car entry) (cdr entry)))
initial-color-definitions)
(add-event-receiver! event:before-exit finalize-pm-state!)
- (add-gc-daemon! close-lost-windows-daemon))
+ (add-gc-daemon! close-lost-objects-daemon))
(define (finalize-pm-state!)
(if event-descriptor
(set! event-descriptor #f)
unspecific)))
-(define (close-lost-windows-daemon)
+(define (close-lost-objects-daemon)
(clean-lost-protected-objects window-list os2win-close))
\f
-(define (os2-graphics/available?)
- (implemented-primitive-procedure? os2win-open))
-
-(define (os2-graphics/open descriptor->device)
- (if (not event-descriptor)
- (let ((descriptor (os2win-open-event-qid)))
- (set! event-previewer-registration (make-event-previewer descriptor))
- (set! event-descriptor descriptor)))
- (let ((wid (os2win-open event-descriptor "Scheme Graphics"))
- (foreground-color #xFFFFFF)
- (background-color #x000000))
- (let ((psid (os2win-ps wid)))
- (os2ps-set-colors psid foreground-color background-color)
- (os2win-show-cursor wid #f)
- (os2win-show wid #t)
- (os2win-set-state wid window-state:deactivate)
- (os2win-set-state wid window-state:top)
- (let ((window
- (let ((w.h (os2win-get-size wid)))
- (make-os2-window wid
- (car w.h)
- (cdr w.h)
- (set-normal-font! psid "4.System VIO")
- foreground-color
- background-color))))
- (compute-window-slopes! window)
- (add-to-protection-list! window-list window wid)
- (descriptor->device window)))))
-
-(define (set-normal-font! psid font)
- (let ((metrics (os2ps-set-font psid 1 font)))
- (if (not metrics)
- (error "Unknown font name:" font))
- metrics))
-
-(define (compute-window-slopes! window)
- (set-os2-window/x-slope! window
- (/ (- (os2-window/pel-width window) 1)
- (- (os2-window/x-right window)
- (os2-window/x-left window))))
- (set-os2-window/y-slope! window
- (/ (- (os2-window/pel-height window) 1)
- (- (os2-window/y-top window)
- (os2-window/y-bottom window)))))
+;;;; Window Abstraction
+
+(define-structure (window
+ (conc-name window/)
+ (constructor %make-window
+ (wid pel-width
+ pel-height
+ backing-store
+ backing-store-bitmap)))
+ wid
+ pel-width
+ pel-height
+ (backing-store #f read-only #t)
+ backing-store-bitmap
+ (changes #f)
+ (x-gcursor 0)
+ (y-gcursor 0)
+ (x-left -1)
+ (y-bottom -1)
+ (x-right 1)
+ (y-top 1)
+ (x-slope (/ (- pel-width 1) 2))
+ (y-slope (/ (- pel-height 1) 2))
+ font-specifier
+ font-metrics
+ (foreground-color #xFFFFFF)
+ (background-color #x000000))
-(define (os2-graphics/close device)
- (without-interrupts
- (lambda ()
- (close-window (graphics-device/descriptor device)))))
+(define (make-window wid)
+ (let ((window
+ (let ((w.h (os2win-get-size wid))
+ (psid (os2ps-create-memory-ps)))
+ (let ((bid (os2ps-create-bitmap psid pel-width pel-height)))
+ (os2ps-set-bitmap psid bid)
+ (%make-window wid (car w.h) (cdr w.h) psid bid)))))
+ (add-to-protection-list! window-list window wid)
+ window))
(define (close-window window)
- (if (os2-window/wid window)
+ (if (window/wid window)
(begin
- (os2win-close (os2-window/wid window))
- (set-os2-window/wid! window #f)
+ (os2ps-destroy-memory-ps (window/backing-store window))
+ (os2win-close (window/wid window))
+ (set-window/wid! window #f)
(remove-from-protection-list! window-list window))))
-\f
-(define (make-event-previewer descriptor)
- (permanently-register-input-thread-event
- descriptor
- (current-thread)
- (lambda ()
- (let ((event (os2win-get-event descriptor #f)))
- (if event
- (process-event event))))))
-(define (process-event event)
- (let ((window
- (search-protection-list window-list
- (let ((wid (event-wid event)))
- (lambda (window)
- (eq? (os2-window/wid window) wid))))))
- (if window
- (let ((handler (vector-ref event-handlers (event-type event))))
- (if handler
- (handler window event))))))
+(define-integrable (os2-graphics-device/wid device)
+ (window/wid (graphics-device/descriptor device)))
-(define event-handlers
- (make-vector number-of-event-types #f))
+(define-integrable (os2-graphics-device/psid device)
+ (window/backing-store (graphics-device/descriptor device)))
-(define-integrable (define-event-handler event-type handler)
- (vector-set! event-handlers event-type handler))
+(define (compute-window-slopes! window)
+ (set-window/x-slope! window
+ (/ (- (window/pel-width window) 1)
+ (- (window/x-right window) (window/x-left window))))
+ (set-window/y-slope! window
+ (/ (- (window/pel-height window) 1)
+ (- (window/y-top window) (window/y-bottom window)))))
+
+(define (set-window-font! window font-specifier)
+ (set-window/font-specifier! window font-specifier)
+ (set-window/font-metrics!
+ window
+ (let ((metrics
+ (os2ps-set-font (window/backing-store window) 1 font-specifier)))
+ (if (not metrics)
+ (error "Unknown font name:" font-specifier))
+ metrics)))
+
+(define (window/x->device window x)
+ (round->exact (* (window/x-slope window) (- x (window/x-left window)))))
+
+(define (window/y->device window y)
+ (round->exact (* (window/y-slope window) (- y (window/y-bottom window)))))
+\f
+;;;; Standard Operations
-(define-event-handler event-type:button
- (lambda (window event)
- (if (and (eq? button-event-type:down (button-event/type event))
- (not (os2win-focus? (os2-window/wid window))))
- (os2win-activate (os2-window/wid window)))))
+(define (os2-graphics/available?)
+ (implemented-primitive-procedure? os2win-open))
-(define-event-handler event-type:close
- (lambda (window event)
- event
- (close-window window)))
+(define (os2-graphics/open descriptor->device)
+ (if (not event-descriptor)
+ (let ((descriptor (os2win-open-event-qid)))
+ (set! event-previewer-registration (make-event-previewer descriptor))
+ (set! event-descriptor descriptor)))
+ (let ((wid (os2win-open event-descriptor "Scheme Graphics")))
+ (os2win-show-cursor wid #f)
+ (os2win-show wid #t)
+ (os2win-set-state wid window-state:deactivate)
+ (os2win-set-state wid window-state:top)
+ (let ((window (make-window wid)))
+ (update-colors window)
+ (set-window-font! window "4.System VIO")
+ (let ((device (descriptor->device window)))
+ (os2-graphics/clear device)
+ device))))
-(define-event-handler event-type:paint
- (lambda (window event)
- event
- (clear-window window)
- (play-segment (os2-window/segment window))))
+(define (os2-graphics/close device)
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (close-window window)))))
-(define-event-handler event-type:resize
- (lambda (window event)
- (set-os2-window/pel-width! window (resize-event/width event))
- (set-os2-window/pel-height! window (resize-event/height event))
- (compute-window-slopes! window)))
-\f
(define (os2-graphics/clear device)
- (reset-segment (os2-graphics-device/segment device))
- (clear-window (graphics-device/descriptor device)))
-
-(define (clear-window window)
- (os2ps-clear (os2-window/psid window)
- 0 (os2-window/pel-width window)
- 0 (os2-window/pel-height window)))
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (let ((width (window/pel-width window))
+ (height (window/pel-height window)))
+ (os2ps-clear (window/backing-store window) 0 width 0 height)
+ (invalidate-rectangle device 0 width 0 height))))))
(define (os2-graphics/coordinate-limits device)
(let ((window (graphics-device/descriptor device)))
(without-interrupts
(lambda ()
- (values (os2-window/x-left window)
- (os2-window/y-bottom window)
- (os2-window/x-right window)
- (os2-window/y-top window))))))
+ (values (window/x-left window)
+ (window/y-bottom window)
+ (window/x-right window)
+ (window/y-top window))))))
(define (os2-graphics/device-coordinate-limits device)
- (without-interrupts
- (lambda ()
- (values 0
- 0
- (- (os2-graphics-device/pel-width device) 1)
- (- (os2-graphics-device/pel-height device) 1)))))
-
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (values 0
+ 0
+ (- (window/pel-width window) 1)
+ (- (window/pel-height window) 1))))))
+\f
(define (os2-graphics/drag-cursor device x y)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (os2ps-line (os2-graphics-device/psid device)
- (os2-graphics-device/x->device device x)
- (os2-graphics-device/y->device device y)))))
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (let ((xs (window/x-gcursor window))
+ (ys (window/y-gcursor window))
+ (xe (window/x->device window x))
+ (ye (window/y->device window y)))
+ (let ((xl (if (fix:< xs xe) xs xe))
+ (yl (if (fix:< ys ye) ys ye))
+ (xh (fix:+ (if (fix:> xs xe) xs xe) 1))
+ (yh (fix:+ (if (fix:> ys ye) ys ye) 1)))
+ (os2ps-line (window/backing-store window) xe ye)
+ (set-window/x-gcursor! window xe)
+ (set-window/y-gcursor! window ye)
+ (invalidate-rectangle device xl yl xh yh)))))))
(define (os2-graphics/draw-line device x-start y-start x-end y-end)
(os2-graphics/move-cursor device x-start y-start)
(os2-graphics/drag-cursor device x-end y-end))
(define (os2-graphics/draw-lines device xv yv)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (os2ps-poly-line-disjoint
- (os2-graphics-device/psid device)
- (vector-map xv (lambda (x) (os2-graphics-device/x->device device x)))
- (vector-map yv
- (lambda (y) (os2-graphics-device/y->device device y)))))))
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (let ((xv (vector-map xv (lambda (x) (window/x->device window x))))
+ (yv (vector-map yv (lambda (y) (window/y->device window y)))))
+ (let ((xl (fix:vector-min xv))
+ (yl (fix:vector-min yv))
+ (xh (fix:+ (fix:vector-max xv) 1))
+ (yh (fix:+ (fix:vector-max yv) 1)))
+ (os2ps-poly-line-disjoint (window/backing-store window) xv yv)
+ (invalidate-rectangle device xl yl xh yh)))))))
(define (os2-graphics/draw-point device x y)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (let ((psid (os2-graphics-device/psid device))
- (x (os2-graphics-device/x->device device x))
- (y (os2-graphics-device/y->device device y))
- (type))
- (dynamic-wind
- (lambda ()
- (set! type (map-line-style (graphics-device/line-style device)))
- (os2ps-set-line-type psid LINETYPE_SOLID))
- (lambda ()
- (os2ps-move-graphics-cursor psid x y)
- (os2ps-line psid x y))
- (lambda ()
- (os2ps-set-line-type psid type)))))))
-\f
-(define (os2-graphics/draw-text device x y string)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (os2ps-write (os2-graphics-device/psid device)
- (os2-graphics-device/x->device device x)
- (fix:+ (os2-graphics-device/y->device device y)
- (os2-graphics-device/char-descender device))
- string
- 0
- (string-length string)))))
+ ;; This sucks. Implement a real point-drawing primitive.
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (let ((x (window/x->device window x))
+ (y (window/y->device window y)))
+ (os2ps-draw-point (window/backing-store window) x y)
+ (invalidate-rectangle device x y (fix:+ x 1) (fix:+ y 1)))))))
+(define (os2-graphics/draw-text device x y string)
+ (let ((window (graphics-device/descriptor device))
+ (length (string-length string)))
+ (without-interrupts
+ (lambda ()
+ (let ((psid (window/backing-store window))
+ (metrics (window/font-metrics window))
+ (x (window/x->device window x))
+ (y (window/y->device window y)))
+ (os2ps-write psid
+ x
+ (fix:+ y (font-metrics/descender metrics))
+ string
+ 0
+ length)
+ (invalidate-rectangle device
+ x
+ y
+ (fix:+ x
+ (os2ps-text-width psid string 0 length))
+ (fix:+ y (font-metrics/height metrics))))))))
+\f
(define (os2-graphics/flush device)
- (flush-segment (os2-graphics-device/segment device)))
-
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (let ((changes (window/changes window)))
+ (if changes
+ (begin
+ (os2win-invalidate (window/wid window)
+ (changes/x-left changes)
+ (changes/x-right changes)
+ (changes/y-bottom changes)
+ (changes/y-top changes))
+ (set-window/changes! window #f))))))))
+
+(define (invalidate-rectangle device x-left x-right y-bottom y-top)
+ (let ((window (graphics-device/descriptor device)))
+ (if (graphics-device/buffer? device)
+ (let ((changes (window/changes window)))
+ (if (not changes)
+ (set-window/changes! window
+ (make-changes x-left
+ x-right
+ y-bottom
+ y-top))
+ (begin
+ (if (fix:< x-left (changes/x-left changes))
+ (set-changes/x-left! changes x-left))
+ (if (fix:> x-right (changes/x-right changes))
+ (set-changes/x-right! changes x-right))
+ (if (fix:< y-bottom (changes/y-bottom changes))
+ (set-changes/y-bottom! changes y-bottom))
+ (if (fix:> y-top (changes/y-top changes))
+ (set-changes/y-top! changes y-top)))))
+ (os2win-invalidate (window/wid window)
+ x-left x-right y-bottom y-top))))
+
+(define-structure (changes (type vector)
+ (conc-name changes/)
+ (constructor make-changes))
+ x-left
+ x-right
+ y-bottom
+ y-top)
+\f
(define (os2-graphics/move-cursor device x y)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (os2ps-move-graphics-cursor (os2-graphics-device/psid device)
- (os2-graphics-device/x->device device x)
- (os2-graphics-device/y->device device y)))))
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (let ((x (window/x->device window x))
+ (y (window/y->device window y)))
+ (os2ps-move-graphics-cursor (window/backing-store window) x y)
+ (set-window/x-gcursor! window x)
+ (set-window/y-gcursor! window y))))))
(define (os2-graphics/reset-clip-rectangle device)
- device
- unspecific)
+ (os2ps-reset-clip-rectangle (os2-graphics-device/psid device)))
(define (os2-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
- device x-left y-bottom x-right y-top
- unspecific)
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (os2ps-set-clip-rectangle (window/backing-store window)
+ (window/x->device window x-left)
+ (window/x->device window x-right)
+ (window/y->device window y-bottom)
+ (window/y->device window y-top))))))
(define (os2-graphics/set-coordinate-limits device
x-left y-bottom x-right y-top)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (let ((window (graphics-device/descriptor device)))
- (set-os2-window/x-left! window x-left)
- (set-os2-window/y-bottom! window y-bottom)
- (set-os2-window/x-right! window x-right)
- (set-os2-window/y-top! window y-top)
- (compute-window-slopes! window)))))
+ (let ((window (graphics-device/descriptor device)))
+ (without-interrupts
+ (lambda ()
+ (set-window/x-left! window x-left)
+ (set-window/y-bottom! window y-bottom)
+ (set-window/x-right! window x-right)
+ (set-window/y-top! window y-top)
+ (compute-window-slopes! window)))))
(define (os2-graphics/set-drawing-mode device mode)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (os2ps-set-mix (os2-graphics-device/psid device)
- (map-drawing-mode mode)))))
+ (os2ps-set-mix (os2-graphics-device/psid device)
+ (map-drawing-mode mode)))
(define (os2-graphics/set-line-style device style)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (os2ps-set-line-type (os2-graphics-device/psid device)
- (map-line-style style)))))
+ (os2ps-set-line-type (os2-graphics-device/psid device)
+ (map-line-style style)))
\f
+;;;; Color Operations
+
(define (os2-graphics/color? device)
(not (= 0 (os2ps-query-capability (os2-graphics-device/psid device)
CAPS_COLOR_TABLE_SUPPORT))))
(->color specification 'FIND-COLOR))
(define (os2-graphics/set-background-color device color)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (set-os2-graphics-device/background-color!
- device
- (->color color 'SET-BACKGROUND-COLOR))
- (update-colors (graphics-device/descriptor device)))))
+ (let ((window (graphics-device/descriptor device))
+ (color (->color color 'SET-BACKGROUND-COLOR)))
+ (without-interrupts
+ (lambda ()
+ (set-window/background-color! window color)
+ (update-colors window)))))
(define (os2-graphics/set-foreground-color device color)
- (drawing-operation (os2-graphics-device/segment device)
- (lambda ()
- (set-os2-graphics-device/foreground-color!
- device
- (->color color 'SET-FOREGROUND-COLOR))
- (update-colors (graphics-device/descriptor device)))))
+ (let ((window (graphics-device/descriptor device))
+ (color (->color color 'SET-FOREGROUND-COLOR)))
+ (without-interrupts
+ (lambda ()
+ (set-window/foreground-color! window color)
+ (update-colors window)))))
(define (update-colors window)
- (os2ps-set-colors (os2-window/psid window)
- (os2-window/foreground-color window)
- (os2-window/background-color window)))
+ (os2ps-set-colors (window/backing-store window)
+ (window/foreground-color window)
+ (window/background-color window)))
\f
+;;;; Window Operations
+
+(define (os2-graphics/window-size device)
+ (let ((w.h (os2win-get-size (os2-graphics-device/wid device))))
+ (values (car w.h)
+ (cdr w.h))))
+
+(define (os2-graphics/set-window-size device width height)
+ (os2win-set-size (os2-graphics-device/wid device) width height))
+
+(define (os2-graphics/window-frame-size device)
+ (let ((w.h (os2win-get-size (os2-graphics-device/wid device))))
+ (values (car w.h)
+ (cdr w.h))))
+
+(define (os2-graphics/display-size device)
+ device
+ (values (os2win-desktop-width) (os2win-desktop-height)))
+
+(define (os2-graphics/window-position device)
+ (let ((x.y (os2win-get-pos (os2-graphics-device/wid device))))
+ (values (car x.y)
+ (cdr x.y))))
+
+(define (os2-graphics/set-window-position device x y)
+ (os2win-set-pos (os2-graphics-device/wid device) x y))
+
+(define (os2-graphics/set-window-title device title)
+ (os2win-set-title (os2-graphics-device/wid device) title))
+
+(define (os2-graphics/set-font device font-specifier)
+ (set-window-font! (graphics-device/descriptor device) font-specifier))
+
+(define (os2-graphics/hide-window device)
+ (os2win-set-state (os2-graphics-device/wid device) window-state:hide))
+
+(define (os2-graphics/minimize-window device)
+ (os2win-set-state (os2-graphics-device/wid device) window-state:minimize))
+
+(define (os2-graphics/maximize-window device)
+ (os2win-set-state (os2-graphics-device/wid device) window-state:maximize))
+
+(define (os2-graphics/restore-window device)
+ (os2win-set-state (os2-graphics-device/wid device) window-state:restore))
+
+(define (os2-graphics/raise-window device)
+ (os2win-set-state (os2-graphics-device/wid device) window-state:top))
+
+(define (os2-graphics/lower-window device)
+ (os2win-set-state (os2-graphics-device/wid device) window-state:bottom))
+
+(define (os2-graphics/activate-window device)
+ (os2win-set-state (os2-graphics-device/wid device) window-state:activate))
+
+(define (os2-graphics/deactivate-window device)
+ (os2win-set-state (os2-graphics-device/wid device) window-state:deactivate))
+
+(define (os2-graphics/desktop-size device)
+ device
+ (values (os2win-desktop-width) (os2win-desktop-height)))
+\f
+;;;; Color Support
+
(define (->color specification procedure)
(cond ((color? specification)
specification)
("dark green" 0 127 0)
("brown" 127 63 0)))
\f
+;;;; Miscellaneous Support
+
+(define (fix:vector-min v)
+ (let ((length (vector-length v))
+ (min (vector-ref v 0)))
+ (do ((index 1 (fix:+ index 1)))
+ ((fix:= index length))
+ (if (fix:< (vector-ref v index) min)
+ (set! min (vector-ref v index))))
+ min))
+
+(define (fix:vector-max v)
+ (let ((length (vector-length v))
+ (max (vector-ref v 0)))
+ (do ((index 1 (fix:+ index 1)))
+ ((fix:= index length))
+ (if (fix:> (vector-ref v index) max)
+ (set! max (vector-ref v index))))
+ max))
+
(define map-drawing-mode
(let ((modes
(vector FM_ZERO
'MAP-LINE-STYLE))
(vector-ref styles style))))
\f
-(define-structure (os2-window
- (conc-name os2-window/)
- (constructor make-os2-window
- (wid
- pel-width
- pel-height
- font-metrics
- foreground-color
- background-color)))
- wid
- pel-width
- pel-height
- font-metrics
- foreground-color
- background-color
- (x-left -1)
- (y-bottom -1)
- (x-right 1)
- (y-top 1)
- x-slope
- y-slope
- (segment (make-segment) read-only #t))
-
-(define-integrable (os2-window/psid window)
- (os2win-ps (os2-window/wid window)))
-
-(define-integrable (os2-graphics-device/wid device)
- (os2-window/wid (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/psid device)
- (os2-window/psid (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/pel-width device)
- (os2-window/pel-width (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/pel-height device)
- (os2-window/pel-height (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/char-descender device)
- (font-metrics/descender
- (os2-window/font-metrics (graphics-device/descriptor device))))
-
-(define-integrable (os2-graphics-device/x-left device)
- (os2-window/x-left (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/y-bottom device)
- (os2-window/y-bottom (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/x-right device)
- (os2-window/x-right (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/y-top device)
- (os2-window/y-top (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/x-slope device)
- (os2-window/x-slope (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/y-slope device)
- (os2-window/y-slope (graphics-device/descriptor device)))
-
-(define-integrable (os2-graphics-device/segment device)
- (os2-window/segment (graphics-device/descriptor device)))
-
-(define (os2-graphics-device/x->device device x)
- (round->exact (* (os2-graphics-device/x-slope device)
- (- x (os2-graphics-device/x-left device)))))
-
-(define (os2-graphics-device/y->device device y)
- (round->exact (* (os2-graphics-device/y-slope device)
- (- y (os2-graphics-device/y-bottom device)))))
-
-(define-integrable (os2-graphics-device/foreground-color device)
- (os2-window/foreground-color (graphics-device/descriptor device)))
-
-(define-integrable (set-os2-graphics-device/foreground-color! device color)
- (set-os2-window/foreground-color! (graphics-device/descriptor device) color))
-
-(define-integrable (os2-graphics-device/background-color device)
- (os2-window/background-color (graphics-device/descriptor device)))
-
-(define-integrable (set-os2-graphics-device/background-color! device color)
- (set-os2-window/background-color! (graphics-device/descriptor device) color))
-\f
-(define (os2-graphics/window-size device)
- (let ((w.h (os2win-get-size (os2-graphics-device/wid device))))
- (values (car w.h)
- (cdr w.h))))
-
-(define (os2-graphics/set-window-size device width height)
- (os2win-set-size (os2-graphics-device/wid device) width height))
-
-(define (os2-graphics/window-position device)
- (let ((x.y (os2win-get-pos (os2-graphics-device/wid device))))
- (values (car x.y)
- (cdr x.y))))
+;;;; Events
-(define (os2-graphics/set-window-position device x y)
- (os2win-set-pos (os2-graphics-device/wid device) x y))
-
-(define (os2-graphics/set-window-title device title)
- (os2win-set-title (os2-graphics-device/wid device) title))
-
-(define (os2-graphics/set-font device font)
- (let ((window (graphics-device/descriptor device)))
- (set-os2-window/font-metrics! window
- (set-normal-font! (os2-window/psid window)
- font))))
+(define (make-event-previewer descriptor)
+ (permanently-register-input-thread-event
+ descriptor
+ (current-thread)
+ (lambda ()
+ (let ((event (os2win-get-event descriptor #f)))
+ (if event
+ (process-event event))))))
-(define (os2-graphics/hide-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:hide))
+(define (process-event event)
+ (let ((window
+ (search-protection-list window-list
+ (let ((wid (event-wid event)))
+ (lambda (window)
+ (eq? (window/wid window) wid))))))
+ (if window
+ (let ((handler (vector-ref event-handlers (event-type event))))
+ (if handler
+ (handler window event))))))
-(define (os2-graphics/minimize-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:minimize))
+(define event-handlers
+ (make-vector number-of-event-types #f))
-(define (os2-graphics/maximize-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:maximize))
+(define-integrable (define-event-handler event-type handler)
+ (vector-set! event-handlers event-type handler))
-(define (os2-graphics/restore-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:restore))
+(define-event-handler event-type:button
+ (lambda (window event)
+ (if (and (eq? button-event-type:down (button-event/type event))
+ (not (os2win-focus? (window/wid window))))
+ (os2win-activate (window/wid window)))))
-(define (os2-graphics/raise-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:top))
+(define-event-handler event-type:close
+ (lambda (window event)
+ event
+ (close-window window)))
-(define (os2-graphics/lower-window device)
- (os2win-set-state (os2-graphics-device/wid device) window-state:bottom))
+(define-event-handler event-type:paint
+ (lambda (window event)
+ (os2ps-bitblt (os2win-ps (window/wid window))
+ (window/backing-store window)
+ (let ((xl (paint-event/xl event)))
+ (vector xl (paint-event/xh event) xl))
+ (let ((yl (paint-event/yl event)))
+ (vector yl (paint-event/yh event) yl))
+ ROP_SRCCOPY
+ BBO_OR)))
-(define (os2-graphics/desktop-size device)
- device
- (values (os2win-desktop-width) (os2win-desktop-height)))
+(define-event-handler event-type:resize
+ (lambda (window event)
+ (let ((width (resize-event/width event))
+ (height (resize-event/height event)))
+ (let ((old (window/backing-store window)))
+ (let ((bitmap (os2ps-create-bitmap old width height)))
+ (let ((new (os2ps-create-memory-ps)))
+ (os2ps-set-bitmap new bitmap)
+ ;; I'm worried that this will fail because the new memory PS
+ ;; doesn't have the correct attributes. Maybe this will
+ ;; only cause trouble once we start hacking color maps.
+ (os2ps-bitblt new
+ old
+ (vector 0 width 0 (window/pel-width window))
+ (vector 0 height 0 (window/pel-height window))
+ ROP_SRCCOPY
+ BBO_IGNORE)
+ (os2ps-set-bitmap new #f)
+ (os2ps-destroy-memory-ps new))
+ (os2ps-destroy-bitmap (os2ps-set-bitmap old bitmap))
+ (set-window/backing-store-bitmap! window bitmap)))
+ (set-window/pel-width! window width)
+ (set-window/pel-height! window height)
+ (compute-window-slopes! window)
+ (os2win-invalidate (window/wid window) 0 width 0 height)
+ (set-window/changes! window #f))))
\f
;;;; Protection lists
(cons (weak-car (car associations))
(loop (cdr associations))))
(else
- (loop (cdr associations))))))))
-\f
-;;;; Drawing Segments
-
-(define (make-segment)
- (cons (cons '() '())
- (cons '() '())))
-
-(define (reset-segment segment)
- (without-interrupts
- (lambda ()
- (set-car! (car segment) '())
- (set-cdr! (car segment) '())
- (set-car! (cdr segment) '())
- (set-cdr! (cdr segment) '()))))
-
-(define (flush-segment segment)
- (%play-segment
- (without-interrupts
- (lambda ()
- (let ((new-head (caar segment))
- (new-tail (cdar segment)))
- (%enqueue-segment (cdr segment) new-head new-tail)
- (set-car! (car segment) '())
- (set-cdr! (car segment) '())
- new-head)))))
-
-(define (drawing-operation segment thunk)
- (without-interrupts
- (lambda ()
- (let ((new (list thunk)))
- (%enqueue-segment (car segment) new new)))))
-
-(define (play-segment segment)
- (%play-segment (cadr segment)))
-
-(define (%enqueue-segment h.t new-head new-tail)
- (let ((old (cdr h.t)))
- (set-cdr! h.t new-tail)
- (if (null? old)
- (set-car! h.t new-head)
- (set-cdr! old new-head))))
-
-(define (%play-segment thunks)
- (do ((thunks thunks (cdr thunks)))
- ((null? thunks))
- ((car thunks))))
\ No newline at end of file
+ (loop (cdr associations))))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff