From 4637f50f77a16e4b8f8e5e833a4550a8b5cf33ae Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 14 Feb 1995 00:36:58 +0000 Subject: [PATCH] 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. --- v7/src/runtime/os2graph.scm | 778 +++++++++++++++++++----------------- 1 file changed, 414 insertions(+), 364 deletions(-) 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 -- 2.25.1