NetNews Usenet Archive 1992 #27/NN_1992_27.iso/spool/comp/lang/lisp/mcl/1610

Text File | 1992-11-17 | 5.3 KB | 108 lines

Path: sparky!uunet!charon.amdahl.com!pacbell.com!sgiblab!darwin.sura.net!wupost!usc!elroy.jpl.nasa.gov!ames!data.nas.nasa.gov!taligent!apple!cambridge.apple.com![e-mail]
From: [e-mail] (Richard D Ferrante)
Newsgroups: comp.lang.lisp.mcl
Subject: displaying data & faq
Message-ID: <[e-mail]>
Date: 17 Nov 92 12:48:23 GMT
Sender: [e-mail]
Lines: 97
Approved: [e-mail].C0M

From a few weeks ago I noticed some questions about displaying data
and determining monitor settings I've been on vaction so didn't
respond. Since this a recurring question I'd thought I'd post the
following code which was developed with the help of others on the net.

Note the code is a hack designed for my own specific needs, it is not
general purpose specifically it expects an 8-bit grayscale monitor and
positive fixnum scale factors.  All zooming is simple pixel replication.


(defun first-monitor-depth-and-colorp ()
  (let ((first-monitor (#_GetDeviceList))
        (thePixMapHdl nil)
        (Depth 0)
        colorp)
    (with-dereferenced-handles ((aGDevicePtr first-monitor))
      (setf thePixMapHdl (rref first-monitor GDevice.gdPMap))
      (setf Depth (rref thePixMapHdl PixMap.pixelSize))
      (setq colorp (#_testdeviceattribute first-monitor 0)))
    (values Depth colorp)))

(defmethod to-pixmap ((im image) (w window) &optional (preset-scale nil))

  (let ((pixmap (rref (wptr w) CGrafPort.portPixMap))
        top left right bottom
        (screen-width *screen-width*)
        scale-factor
        (required-depth 8)
        (required-colorp nil)
        colorp depth
        )
    (multiple-value-setq (depth colorp) (first-monitor-depth-and-colorp))
    (cond
     ((or (/= depth required-depth) (nequal required-colorp colorp))
      (#_sysbeep 5)
      (format t "~% Wrong monitor attributes depth ~a must be ~a" depth required-depth)
      (format t "~%                          color ~a must be ~a" colorp required-colorp))
     (t
      (multiple-value-bind (upper-left bottom-right) (view-corners w)
        (declare (ignore upper-left))
        (multiple-value-bind (position) (view-position w)
          (setq top (point-v position))
          (setq left (point-h position))
          (setq right (+ left (point-h bottom-right)))
          (setq bottom (+ top (point-v bottom-right)))))
      (with-slots (max-i max-j data-array) im
        (cond (preset-scale
               (setq scale-factor (truncate preset-scale)))
              (t (setq scale-factor (min (truncate (- right left) max-i) (truncate (- bottom top) max-j))))
              )
        (cond ((= scale-factor 1)
               (loop for i fixnum from 0 below max-i
                     for row-count fixnum from top
                     do
                     (loop for j fixnum from 0 below max-j
                           for col-count fixnum from left
                           do
                           (%put-byte pixmap (aref data-array i j)  (+ (* row-count screen-width) col-count)))))
              ((> scale-factor 1) ;empirically determined value for which the copy-bits overhead is worth it, probably varies by machine


               (with-macptrs ((view-bm (rref (wptr w) :grafport.portBits)))
                 (loop for i fixnum from 0 below max-i
                       for row-count fixnum from (+ top (* (- scale-factor 1) max-i))
                       do
                       (loop for j fixnum from 0 below max-j
                             for col-count fixnum from (+ left (* (- scale-factor 1) max-j));left
                             do
                             (%put-byte pixmap (aref data-array i j)  (+ (* row-count screen-width) col-count))))
                 (rlet ((r1 :rect
                            :topleft (make-point (* (- scale-factor 1) max-i) (* (- scale-factor 1) max-j))
                            :bottomright (make-point (- (* scale-factor  max-i) 1) (- (* scale-factor max-j ) 1)))
                        (r2 :rect
                            :topleft (make-point 0 0)
                            :bottomright (make-point (- (* scale-factor  max-i) 1) (- (* scale-factor max-j ) 1))
                            ))
                   (copy-bits view-bm view-bm r1 r2)
)))
              (t
               (loop for i fixnum from 0 below max-i
                     for row-count fixnum from top by scale-factor
                     with value
                     do
                     (loop for j fixnum from 0 below max-j
                           for col-count fixnum from left by scale-factor
                           do
                           (setq value (aref data-array i j))
                           (loop for window-offset from (+ (* row-count screen-width) col-count) by screen-width
                                 for window-row from 0 below scale-factor
                                 do
                                 (loop for window-col from 0 below scale-factor
                                       do
                                       (%put-byte pixmap value (+ window-offset window-col))
                                       )))))))
      (when (typep w 'image-display-window)
        (setf (slot-value w 'image-being-displayed) im)
        (setf (slot-value w 'image-scale-factor) scale-factor))))))