From: Stephen Adams <edu/mit/csail/zurich/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