Install new X11 gray-map code that understands about high-color

displays.

diff --git a/v7/src/6001/pic-imag.scm b/v7/src/6001/pic-imag.scm
index 37a0ae482af87e6e01f98b5b8acd174b7b5d6254..5b53eb94a2ffd924f327bd2eb43a34c67cf85568 100644 (file)
--- a/v7/src/6001/pic-imag.scm
+++ b/v7/src/6001/pic-imag.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: pic-imag.scm,v 1.7 1995/02/24 00:37:57 cph Exp $
+$Id: pic-imag.scm,v 1.8 1997/12/30 05:43:34 cph Exp $
 
-Copyright (c) 1991-95 Massachusetts Institute of Technology
+Copyright (c) 1991-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -45,27 +45,22 @@ MIT in each case. |#
         (pic-data (picture-data pic))
         (image-width (fix:* h-sf pic-width)) ;x
         (image-height (fix:* v-sf pic-height)) ;iy
+        (image-depth (graphics-operation window 'IMAGE-DEPTH))
         (image (image/create window image-width image-height))
-        (byte-string (make-string (fix:* image-width image-height)))
+        (pixels
+         (if (<= image-depth 8)
+             (make-string (fix:* image-width image-height))
+             (make-vector (fix:* image-width image-height))))
+        (write-pixel
+         (if (<= image-depth 8)
+             vector-8b-set!
+             vector-set!))
         (py-max (- pic-height 1))
         (rect-index-height (fix:* v-sf image-width))
-        (range (flo:- pic-max pic-min))
-        (index-range (string-length gray-map))
-        (mul (if (flo:< range 1e-12)
-                 0.
-                 (/ index-range
-                    (flo:* (flo:+ 1. 7.142e-8) ; 1+epsilon
-                           range))))
+        (binner (cutoff-binner .01 pic-min pic-max (vector-length gray-map)))
         (gray-pixel
          (lambda (pixel-value)
-           (vector-8b-ref
-            gray-map
-            (let ((pixel
-                   (flo:floor->exact
-                    (flo:* mul (flo:- pixel-value pic-min)))))
-              (cond ((fix:< pixel 0) 0)
-                    ((fix:< pixel index-range) pixel)
-                    (else (fix:- index-range 1))))))))
+           (vector-ref gray-map (binner pixel-value)))))
 
     (cond ((and (fix:= 1 h-sf) (fix:= 1 v-sf))
           (let y-loop ((py py-max) (iy-index 0))
@@ -75,10 +70,10 @@ MIT in each case. |#
                     (let x-loop ((px 0))
                       (if (fix:< px pic-width)
                           (begin
-                            (vector-8b-set!
-                             byte-string
+                            (write-pixel
+                             pixels
                              (fix:+ px iy-index)
-                             (gray-pixel (floating-vector-ref pic-row px)))
+                             (gray-pixel (flo:vector-ref pic-row px)))
                             (x-loop (fix:+ px 1))))))
                   (y-loop (fix:- py 1) (fix:+ iy-index rect-index-height))))))
 
@@ -90,13 +85,11 @@ MIT in each case. |#
                     (if (fix:< px pic-width)
                         (let* ((n-is-0 (fix:+ ix iy-index))
                                (n-is-1 (fix:+ n-is-0 image-width))
-                               (v
-                                (gray-pixel
-                                 (floating-vector-ref pic-row px))))
-                          (vector-8b-set! byte-string n-is-0 v)
-                          (vector-8b-set! byte-string (fix:+ n-is-0 1) v)
-                          (vector-8b-set! byte-string n-is-1 v)
-                          (vector-8b-set! byte-string (fix:+ n-is-1 1) v)
+                               (v (gray-pixel (flo:vector-ref pic-row px))))
+                          (write-pixel pixels n-is-0 v)
+                          (write-pixel pixels (fix:+ n-is-0 1) v)
+                          (write-pixel pixels n-is-1 v)
+                          (write-pixel pixels (fix:+ n-is-1 1) v)
                           (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
                         (y-loop (fix:- py 1) 
                                 (fix:+ iy-index rect-index-height))))))))
@@ -110,18 +103,16 @@ MIT in each case. |#
                         (let* ((row0 (fix:+ ix iy-index))
                                (row1 (fix:+ row0 image-width))
                                (row2 (fix:+ row1 image-width))
-                               (v
-                                (gray-pixel
-                                 (floating-vector-ref pic-row px))))
-                          (vector-8b-set! byte-string row0 v)
-                          (vector-8b-set! byte-string (fix:+ row0 1) v)
-                          (vector-8b-set! byte-string (fix:+ row0 2) v)
-                          (vector-8b-set! byte-string row1 v)
-                          (vector-8b-set! byte-string (fix:+ row1 1) v)
-                          (vector-8b-set! byte-string (fix:+ row1 2) v)
-                          (vector-8b-set! byte-string row2 v)
-                          (vector-8b-set! byte-string (fix:+ row2 1) v)
-                          (vector-8b-set! byte-string (fix:+ row2 2) v)
+                               (v (gray-pixel (flo:vector-ref pic-row px))))
+                          (write-pixel pixels row0 v)
+                          (write-pixel pixels (fix:+ row0 1) v)
+                          (write-pixel pixels (fix:+ row0 2) v)
+                          (write-pixel pixels row1 v)
+                          (write-pixel pixels (fix:+ row1 1) v)
+                          (write-pixel pixels (fix:+ row1 2) v)
+                          (write-pixel pixels row2 v)
+                          (write-pixel pixels (fix:+ row2 1) v)
+                          (write-pixel pixels (fix:+ row2 2) v)
                           (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
                         (y-loop (fix:- py 1) 
                                 (fix:+ iy-index rect-index-height))))))))
@@ -136,25 +127,23 @@ MIT in each case. |#
                                (row1 (fix:+ row0 image-width))
                                (row2 (fix:+ row1 image-width))
                                (row3 (fix:+ row2 image-width))
-                               (v
-                                (gray-pixel
-                                 (floating-vector-ref pic-row px))))
-                          (vector-8b-set! byte-string row0 v)
-                          (vector-8b-set! byte-string (fix:+ row0 1) v)
-                          (vector-8b-set! byte-string (fix:+ row0 2) v)
-                          (vector-8b-set! byte-string (fix:+ row0 3) v)
-                          (vector-8b-set! byte-string row1 v)
-                          (vector-8b-set! byte-string (fix:+ row1 1) v)
-                          (vector-8b-set! byte-string (fix:+ row1 2) v)
-                          (vector-8b-set! byte-string (fix:+ row1 3) v)
-                          (vector-8b-set! byte-string row2 v)
-                          (vector-8b-set! byte-string (fix:+ row2 1) v)
-                          (vector-8b-set! byte-string (fix:+ row2 2) v)
-                          (vector-8b-set! byte-string (fix:+ row2 3) v)
-                          (vector-8b-set! byte-string row3 v)
-                          (vector-8b-set! byte-string (fix:+ row3 1) v)
-                          (vector-8b-set! byte-string (fix:+ row3 2) v)
-                          (vector-8b-set! byte-string (fix:+ row3 3) v)
+                               (v (gray-pixel (flo:vector-ref pic-row px))))
+                          (write-pixel pixels row0 v)
+                          (write-pixel pixels (fix:+ row0 1) v)
+                          (write-pixel pixels (fix:+ row0 2) v)
+                          (write-pixel pixels (fix:+ row0 3) v)
+                          (write-pixel pixels row1 v)
+                          (write-pixel pixels (fix:+ row1 1) v)
+                          (write-pixel pixels (fix:+ row1 2) v)
+                          (write-pixel pixels (fix:+ row1 3) v)
+                          (write-pixel pixels row2 v)
+                          (write-pixel pixels (fix:+ row2 1) v)
+                          (write-pixel pixels (fix:+ row2 2) v)
+                          (write-pixel pixels (fix:+ row2 3) v)
+                          (write-pixel pixels row3 v)
+                          (write-pixel pixels (fix:+ row3 1) v)
+                          (write-pixel pixels (fix:+ row3 2) v)
+                          (write-pixel pixels (fix:+ row3 3) v)
                           (x-loop (fix:+ px 1) (fix:+ ix h-sf)))
                         (y-loop (fix:- py 1) 
                                 (fix:+ iy-index rect-index-height))))))))
@@ -165,8 +154,7 @@ MIT in each case. |#
                 (let ((pic-row (vector-ref pic-data py)))
                   (let x-loop ((px 0) (ix 0))
                     (if (fix:< px pic-width)
-                        (let* ((v
-                                (gray-pixel (floating-vector-ref pic-row px)))
+                        (let* ((v (gray-pixel (flo:vector-ref pic-row px)))
                                (n-start (fix:+ ix iy-index))
                                (n-end (fix:+ n-start rect-index-height)))
                           (let n-loop ((n n-start))
@@ -175,17 +163,17 @@ MIT in each case. |#
                                   (let m-loop ((m n))
                                     (if (fix:< m m-end)
                                         (begin
-                                          (vector-8b-set! byte-string m v)
+                                          (write-pixel pixels m v)
                                           (m-loop (fix:+ m 1)))
                                         (n-loop (fix:+ n image-width)))))
                                 (x-loop (fix:+ px 1) (fix:+ ix h-sf)))))
                         (y-loop (fix:- py 1) 
                                 (fix:+ iy-index rect-index-height)))))))))
     ;; Kludge: IMAGE/FILL-FROM-BYTE-VECTOR should take an argument
-    ;; that specifies what color a given byte in BYTE-STRING maps to.
+    ;; that specifies what color a given byte in PIXELS maps to.
     ;; OS/2 requires this information, so we supply it here.
     (if (eq? 'OS/2 microcode-id/operating-system)
-       (os2-image/set-colormap image os2-image-colormap:gray-256))
-    (image/fill-from-byte-vector image byte-string)
-    (1d-table/put! (graphics-device/properties window) image #t)
+       (os2-image/set-colormap image (os2-image-colormap)))
+    (image/fill-from-byte-vector image pixels)
+    (1d-table/put! (graphics-device/properties window) image (cons h-sf v-sf))
     image))
\ No newline at end of file

diff --git a/v7/src/6001/picture.scm b/v7/src/6001/picture.scm
index ef9ab368af187be9573673c4db5f28d80fe5ec6f..0b88223d80604e4ae4c793bf2daca013e2ad6a9d 100644 (file)
--- a/v7/src/6001/picture.scm
+++ b/v7/src/6001/picture.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: picture.scm,v 1.25 1997/12/30 01:57:13 cph Exp $
+$Id: picture.scm,v 1.26 1997/12/30 05:42:53 cph Exp $
 
-Copyright (c) 1991-95 Massachusetts Institute of Technology
+Copyright (c) 1991-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -304,6 +304,20 @@ MIT in each case. |#
              ((>= bin n-bins) (- n-bins 1))
              (else bin))))))
 
+(define (cutoff-binner cut-fraction min-value max-value n-bins)
+  ;; Bin values with distinguished zero bin.  If the value would have
+  ;; fallen in the low CUT-FRACTION of the zero bin for a linear
+  ;; binning, then it goes in the zero bin here.  Otherwise, the value
+  ;; is binned in the top N-1 bins.
+  (let ((cut-value
+        (exact->inexact
+         (+ min-value (* cut-fraction (/ (- max-value min-value) n-bins)))))
+       (binner (linear-binner min-value max-value (- n-bins 1))))
+    (lambda (value)
+      (if (flo:< value cut-value)
+         0
+         (fix:+ 1 (binner value))))))
+
 (define-integrable visual-class:static-gray 0)
 (define-integrable visual-class:gray-scale 1)
 (define-integrable visual-class:static-color 2)