From: Stephen Adams Date: Thu, 21 Mar 1996 16:44:57 +0000 (+0000) Subject: Added new global variables WIN32/DEFINE-COLOR and WIN32/FIND-COLOR. X-Git-Tag: 20090517-FFI~5641 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=43f83f8d9e4af9679769ece21414bd5240399ee7;p=mit-scheme.git Added new global variables WIN32/DEFINE-COLOR and WIN32/FIND-COLOR. Adjusted graphics code to work with them. Added new API `cover' procedure GET-WINDOW-RECT. --- diff --git a/v7/src/win32/graphics.scm b/v7/src/win32/graphics.scm index fe20137be..738b83fc2 100644 --- a/v7/src/win32/graphics.scm +++ b/v7/src/win32/graphics.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: graphics.scm,v 1.9 1995/09/25 20:54:10 adams Exp $ +$Id: graphics.scm,v 1.10 1996/03/21 16:44:27 adams Exp $ -Copyright (c) 1993-95 Massachusetts Institute of Technology +Copyright (c) 1993-96 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -671,42 +671,58 @@ MIT in each case. |# ;; ;; Colors ;; +;; WIN32/FIND-COLOR returns a BGR encoded integer. +;; ->COLOR returns a PALETTERGB encoded color. All color uses internal to this +;; file should use ->COLOR. -(define-integrable (rgb r g b) - (+ #x02000000 r (* g 256) (* b 65536))) +(define color-table) -(define (->color spec) +(define (win32/define-color name spec) + (set! color-table (cons (cons name (win32/find-color spec)) color-table))) + +(define (win32/find-color spec) + (define (rgb r g b) + (+ r (* g 256) (* b 65536))) + (define (rgb-hex spec width) + (let* ((pos1 (fix:+ 1 width)) + (pos2 (fix:+ pos1 width)) + (pos3 (fix:+ pos2 width))) + (rgb (string->number (substring spec 1 pos1) 16) + (string->number (substring spec pos1 pos2) 16) + (string->number (substring spec pos2 pos3) 16)))) (cond ((integer? spec) - (if (< spec #x02000000) - (+ spec #x02000000) - spec)) + spec) ((and (vector? spec) (= (vector-length spec) 3)) - (rgb (vector-ref spec 0) (vector-ref spec 1) (vector-ref spec 2))) + (rgb (vector-ref spec 0) (vector-ref spec 1) (vector-ref spec 2))) ((and (list? spec) (= (length spec) 3)) - (rgb (list-ref spec 0) (list-ref spec 1) (list-ref spec 2))) - ((and (string? spec) (> (string-length spec) 1) + (rgb (list-ref spec 0) (list-ref spec 1) (list-ref spec 2))) + ((and (string? spec) (= (string-length spec) 7) (char=? (string-ref spec 0) #\#)) - (graphics-error "Cant do #rrggbb colors yet:" spec)) + (rgb-hex spec 2)) ((string? spec) - (let ((pair (list-search-positive - color-table - (lambda (pair) (string-ci=? (car pair) spec))))) - (if pair - (cdr pair) - (graphics-error "Unknown color name:" spec)))) + (let ((pair + (list-search-positive color-table + (lambda (pair) (string-ci=? (car pair) spec))))) + (if pair + (cdr pair) + (graphics-error "Unknown color name:" spec)))) (else - (graphics-error "Illegal color" spec)))) - -(define color-table) + (graphics-error "Illegal color" spec)))) (define (win32-graphics/define-color device name spec) device - (set! color-table (cons (cons name (->color spec)) color-table))) + (win32/define-color name spec)) (define (win32-graphics/find-color device spec) device (->color spec)) +(define (->color spec) + (let ((rgb (win32/find-color spec))) + (if (< rgb #x02000000) + (+ rgb #x02000000) ; force palette RGB + spec))) + (define initial-color-definitions `(("red" 255 0 0) ("green" 0 255 0) @@ -733,7 +749,7 @@ MIT in each case. |# (let* ((window (graphics-device/descriptor device)) (hdc (win32-device/hdc window)) (rgb (->color color))) - (set-win32-device/fg-color! window (->color color)) + (set-win32-device/fg-color! window rgb) (set-win32-device/pen-valid?! window #f) (set-text-color hdc rgb)) unspecific) @@ -930,7 +946,7 @@ MIT in each case. |# dib-image-type) (set! color-table '()) (for-each - (lambda (pair) (win32-graphics/define-color #f (car pair) (cdr pair))) + (lambda (pair) (win32/define-color (car pair) (cdr pair))) initial-color-definitions) (register-graphics-window-class) (add-event-receiver! event:after-restore diff --git a/v7/src/win32/wf_user.scm b/v7/src/win32/wf_user.scm index b686c4b60..ddce5b74a 100644 --- a/v7/src/win32/wf_user.scm +++ b/v7/src/win32/wf_user.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: wf_user.scm,v 1.5 1996/02/28 16:32:12 adams Exp $ +$Id: wf_user.scm,v 1.6 1996/03/21 16:44:57 adams Exp $ -Copyright (c) 1993-1996 Massachusetts Institute of Technology +Copyright (c) 1993-96 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -81,6 +81,7 @@ MIT in each case. |# (define get-sub-menu) (define get-system-menu) (define get-system-metrics) +(define get-window-rect) (define get-window-text-length) (define global-alloc) (define global-lock) @@ -296,6 +297,10 @@ MIT in each case. |# (windows-procedure (get-system-metrics (index int)) int user32.dll "GetSystemMetrics")) + (set! get-window-rect + (windows-procedure (get-window-rect (window hwnd) (rect rect)) + bool user32.dll "GetWindowRect")) + (set! get-window-text-length (windows-procedure (get-window-text-length (hdc hdc)) int user32.dll "GetWindowTextLengthA")) diff --git a/v7/src/win32/win32.pkg b/v7/src/win32/win32.pkg index 51298b15e..c7aa4e327 100644 --- a/v7/src/win32/win32.pkg +++ b/v7/src/win32/win32.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: win32.pkg,v 1.7 1996/02/28 16:33:38 adams Exp $ +$Id: win32.pkg,v 1.8 1996/03/21 16:44:43 adams Exp $ -Copyright (c) 1993-95 Massachusetts Institute of Technology +Copyright (c) 1993-96 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -71,6 +71,9 @@ MIT in each case. |# (parent (win32)) ; (export () ; win32-graphics-device-type) + (export () + win32/define-color + win32/find-color) (import (win32 dib) create-dib open-dib