From: Chris Hanson Date: Tue, 14 Feb 1995 00:36:58 +0000 (+0000) Subject: Complete redesign uses bitmaps as backing store and transfers the X-Git-Tag: 20090517-FFI~6645 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4637f50f77a16e4b8f8e5e833a4550a8b5cf33ae;p=mit-scheme.git Complete redesign uses bitmaps as backing store and transfers the appropriate part of the backing store to the screen using GpiBitBlt whenever the PM says it needs to be updated. --- diff --git a/v7/src/runtime/os2graph.scm b/v7/src/runtime/os2graph.scm index de745d2c1..4790ccf8b 100644 --- a/v7/src/runtime/os2graph.scm +++ b/v7/src/runtime/os2graph.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -48,11 +48,13 @@ MIT in each case. |# (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) @@ -93,7 +95,7 @@ MIT in each case. |# (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 @@ -107,230 +109,294 @@ MIT in each case. |# (set! event-descriptor #f) unspecific))) -(define (close-lost-windows-daemon) +(define (close-lost-objects-daemon) (clean-lost-protected-objects window-list os2win-close)) -(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)))) - -(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))))) + +;;;; 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))) - (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)))))) + (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))))))) - -(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)))))))) + (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) + (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))) +;;;; Color Operations + (define (os2-graphics/color? device) (not (= 0 (os2ps-query-capability (os2-graphics-device/psid device) CAPS_COLOR_TABLE_SUPPORT)))) @@ -353,26 +419,89 @@ MIT in each case. |# (->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))) +;;;; 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))) + +;;;; Color Support + (define (->color specification procedure) (cond ((color? specification) specification) @@ -443,6 +572,26 @@ MIT in each case. |# ("dark green" 0 127 0) ("brown" 127 63 0))) +;;;; 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 @@ -483,135 +632,82 @@ MIT in each case. |# 'MAP-LINE-STYLE)) (vector-ref styles style)))) -(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)) - -(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)))) ;;;; Protection lists @@ -670,50 +766,4 @@ MIT in each case. |# (cons (weak-car (car associations)) (loop (cdr associations)))) (else - (loop (cdr associations)))))))) - -;;;; 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