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 fe20137beb375b03d188ba4b3d4d67919c5bd403..738b83fc2c7d2d01fcb40b51bc65b2d5aa515bf1 100644 (file)
--- 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 b686c4b605e9ffe38b64f4da297a44cf5aade026..ddce5b74a724353b00e28e588b57f6e6c6bde314 100644 (file)
--- 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 51298b15e723da6b6329d585d681a4e084bde49b..c7aa4e327d2c35248efffa8a1d44bf217ff4aa8f 100644 (file)
--- 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