[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
color screen image
Date: Tue, 2 Jul 91 14:21:05 EDT
From: smith@icat.larc.nasa.gov (Steven L. Smith)
Hi - Is there a way to capture a color screen image? I'm running
Genera 8.0 on a 3650 and XL400 with the standard color system. The
image would have to be in a format recognized by a PS printer.
Thanks
*******************************************************************************
Steve Smith | Internet: smith@icat.larc.nasa.gov
NASA Langley Research Center |
M/S 152 | Voice: (804) 864-2004
Hampton, VA 23665 | FAX : (804) 864-7793
*******************************************************************************
Yes, (I'm assuming you want postscript of your image).
Hardcopy Image (images:hardcopy-image) will work provided:
1) If you hardcopy directly to the printer, it should be
in the namespace as type POSTSCRIPT (not LGP2). It should also have the
newer Adobe ROMs; the older ones will do some but
not all the color commands. If you hardcopy to a file, file will be
POSTSCRIPT.
2) 2 patch files below loaded. First fixes bug in loop limit and
a rounding error (makes the whites really white), second is not necessary
but is helpful for things that read the BoundingBox comment (color or B&W).
This is for 8.0.1. We don't have 8.1 yet. Last I checked this feature
was not officially supported, but it is (almost) all in there.
================================================================================
Liam M. Healy
Code 8242, Naval Research Laboratory, Washington, DC 20375
Telephone: 202-767-2851
Internet: Healy@space50.nrl.navy.mil
Composed on 7/02/91 17:19:10 at SPACE20 (a Symbolics 3620)
================================================================================
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base: 10; Patch-File: T -*-
;;; Patch file for Private version 0.0
;;; Reason: Function LGP::LGP2-SEND-RASTER: loop x from left to (1- right) -- to one less than right
;;; Written by LISPM, 10/09/90 16:53:50
;;; while running on SPACE50 from FEP0:>Genera-8-0-1-from-Genera-8-0.load.1
;;; with Genera 8.0.1, Logical Pathnames Translation Files NEWEST, IP-TCP 422.6,
;;; microcode 3650-MIC 430, FEP 206, fep0:>G206-lisp.flod(23),
;;; fep0:>G206-loaders.flod(23), fep0:>G206-info.flod(21), fep0:>G206-debug.flod(8),
;;; 1067x748 B&W Screen, Machine serial number 30326.
(SYSTEM-INTERNALS:FILES-PATCHED-IN-THIS-PATCH-FILE
"SYS:HARDCOPY;POSTSCRIPT.LISP.1678")
(NOTE-PRIVATE-PATCH "Fix array limit")
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:HARDCOPY;POSTSCRIPT.LISP.1678")
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Syntax: Zetalisp; Mode: LISP; Base: 10; Package: LGP; Lowercase: Yes -*-")
;;; The run-length encoding is simple: 2 bits of opcode, 6 bits of count.
;;; Opcodes: 3 -- repeat next byte n times; 0 -- repeat 0 n times, 1 -- repeat FF n times.
(defun 1lgp2-send-raster0 (stream raster left top right bottom &optional (terpri t) color-map
rle)
(sys:with-data-stack
(let ((depth (sys:array-element-byte-size raster)))
(unless (zerop (mod (* left depth) 8))
(let* ((height (- bottom top))
(width (- right left))
(new-raster (sys:make-stack-array (list height
(graphics::raster-array-correct-width
width (cl:array-element-type raster)))
:type (array-type raster))))
(bitblt tv:alu-seta width height raster left top new-raster 0 0)
(setq raster new-raster
right width
bottom height
left 0 top 0)))
(let* ((buf (sys:make-stack-array 100. :type 'art-string))
(bit-reverse (= depth 1))
(digit-chars "0123456789abcdef")
(reverse-digit-chars "084c2a6e195d3b7f")
(j 0)
(last-byte nil)
(repeat-count 0))
(labels ((force-buf ()
(force-run)
(send stream :string-out buf 0 j)
(setq j 0)
(when terpri
(terpri stream)))
(force-run ()
(when last-byte
(let ((this-byte last-byte))
(setq last-byte nil)
(selector this-byte =
(#x00 (append-digits repeat-count))
(#xFF (append-digits (dpb 1 (byte 2 6) repeat-count)))
(otherwise (append-digits (dpb 3 (byte 2 6) repeat-count))
(append-digits this-byte t))))))
(append-digits (byte &optional obey-bit-reverse)
(if (and obey-bit-reverse bit-reverse)
(let ((hi (ldb (byte 4 0) byte))
(lo (ldb (byte 4 4) byte)))
(setf (aref buf j) (aref reverse-digit-chars hi))
(setf (aref buf (1+ j)) (aref reverse-digit-chars lo)))
(let ((hi (ldb (byte 4 4) byte))
(lo (ldb (byte 4 0) byte)))
(setf (aref buf j) (aref digit-chars hi))
(setf (aref buf (1+ j)) (aref digit-chars lo))))
(incf j 2)
(when ( j 80)
(force-buf)))
(append-byte (byte)
(if (not rle)
(append-digits byte t)
(if (and (eql byte last-byte) (< repeat-count (1- 1_6)))
(incf repeat-count)
(force-run)
(setq last-byte byte
repeat-count 1)))))
(cond (color-map
(loop for y from (1- bottom) downto top do
(loop for x from left to (1- right) do ; LMH 8/24/90 (1- right) instead of right
(multiple-value-bind (r g b)
(if (eq color-map t)
(let ((rgb (raster-aref raster x y)))
(values (load-byte rgb 0 8)
(load-byte rgb 8 8)
(load-byte rgb 16 8)))
(multiple-value-bind (r g b)
(send color-map :read-color-map (raster-aref raster x y))
(values (round (* r 255.75)) ; LMH 11/20/90: 1023/4 255 !!
(round (* g 255.75))
(round (* b 255.75)))))
(append-byte r)
(append-byte g)
(append-byte b)))
(force-buf)))
;; Optimize very common cases
((or (= depth 1) (= depth 8))
(let ((arr (sys:make-stack-array (array-length raster)
:type 'art-8b :displaced-to raster)))
(declare (sys:array-register arr))
(let ((negate (= depth 8))
(bytes-per-row (multiple-value-bind (nil nil span)
(decode-raster-array raster)
(// (* span depth) 8)))
(bytes-per-scan-line (ceiling (* (- right left) depth) 8)))
(let ((toprow (* top bytes-per-row))
(botrow (* bottom bytes-per-row)))
(loop for index downfrom (- botrow bytes-per-row) to toprow
by bytes-per-row
for y from 0
do (loop repeat bytes-per-scan-line
for byte being array-elements of arr from index
do (when negate
;; Genera gray-level 1 is black
(setq byte (- 255 byte)))
(append-byte byte))
(force-buf))))))
((= depth 16)
(loop for y from (1- bottom) downto top do
(loop for x from left to right do
(let ((value (raster-aref raster x y)))
(append-byte (load-byte value 8 8))
(append-byte (load-byte value 0 8))))
(force-buf)))
(t
(let ((byte 0)
(nbits 0)
(negate (1- (ash 1 depth)))
(reverse (cl:ecase depth
(2 #'sys:bit-reverse-2)
(4 #'sys:bit-reverse-4))))
(loop for y from (1- bottom) downto top do
(loop for x from left to right do
(setf (ldb (byte depth (- 8 depth nbits)) byte)
(funcall reverse (- negate (raster-aref raster x y))))
(incf nbits depth)
(when (= nbits 8)
(append-byte byte)
(setq byte 0 nbits 0)))
(when (plusp nbits)
(append-byte byte)
(setq byte 0 nbits 0))
(force-buf)))))
;; Shouldn't happen, but be safe.
(when (> j 0) (force-buf)))))))
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base: 10; Patch-File: T -*-
;;; Patch file for Private version 0.0
;;; Reason: Function (FLAVOR:METHOD :SHOW-BITMAP LGP::LGP2-BITMAP-STREAM):
;;; Because of use of ZL //, need to float the values before calculating.
;;; Written by LISPM, 10/09/90 17:04:33
;;; while running on SPACE50 from FEP0:>Genera-8-0-1-from-Genera-8-0.load.1
;;; with Genera 8.0.1, Logical Pathnames Translation Files NEWEST, IP-TCP 422.6,
;;; microcode 3650-MIC 430, FEP 206, fep0:>G206-lisp.flod(23),
;;; fep0:>G206-loaders.flod(23), fep0:>G206-info.flod(21), fep0:>G206-debug.flod(8),
;;; 1067x748 B&W Screen, Machine serial number 30326.
(SYSTEM-INTERNALS:FILES-PATCHED-IN-THIS-PATCH-FILE
"SYS:HARDCOPY;POSTSCRIPT.LISP.1678")
(NOTE-PRIVATE-PATCH "Float the bounding box dimensions")
;=====================================
(SYSTEM-INTERNALS:BEGIN-PATCH-SECTION)
(SYSTEM-INTERNALS:PATCH-SECTION-SOURCE-FILE "SYS:HARDCOPY;POSTSCRIPT.LISP.1678")
(SYSTEM-INTERNALS:PATCH-SECTION-ATTRIBUTES
"-*- Syntax: Zetalisp; Mode: LISP; Base: 10; Package: LGP; Lowercase: Yes -*-")
(defmethod 1(:show-bitmap lgp2-bitmap-stream)0 (array width height &key (rotate 0) zoom
color-map)
(let ((depth (sys:array-element-byte-size array)))
(when (plusp rotate)
(when (> depth 1)
(error "Cannot rotate deep images"))
(cl:multiple-value-setq (array width height)
(rotate-bitmap array width height rotate)))
(when (null zoom)
(multiple-value-bind (pwidth pheight)
(send self :inside-size :pixel)
(setq zoom (max 1 (min (round pwidth width) (round pheight height))))))
(when (= depth 32)
(setq color-map t
depth 24))
(let ((inch-page-width (// page-width 72))
(inch-page-height (// page-height 72))
(dpi (let ((pixels-per-inch
(send self :convert-from-device-units
(send self :convert-to-device-units 2540.
:micas :horizontal)
:pixel :horizontal)))
(round pixels-per-inch zoom))))
(setq eps-bounding-box (let* ((swidth (// (float width) dpi))
(sheight (// (float height) dpi))
(sleft (// (float (- inch-page-width swidth)) 2))
(sbottom (// (float (- inch-page-height sheight)) 2)))
(list (* 72 sleft) (* 72 sbottom)
(* 72 (+ sleft swidth)) (* 72 (+ sbottom sheight)))))
(send self :send-header-comments)
(write-string-without-postscript-comments *lgp2-screen-copy-prelude* output-stream)
(write-string-without-postscript-comments
(if run-length-encode-images *lgp2-image-prelude-rle* *lgp2-image-prelude-no-rle*)
output-stream)
(write-string-without-postscript-comments *lgp2-image-prelude-2* output-stream)
(send self :send-end-prolog-comment)
(fformat output-stream "~%~D ~D ~D ~D ~D ~D "
width height
(* (if color-map
(* width 3)
(ceiling (* width depth) 8))
height)
inch-page-width inch-page-height dpi)
(cond (color-map
(fformat output-stream "8 {false 3 colorimage}"))
((= depth 1)
(fformat output-stream "true {imagemask}"))
(t
(fformat output-stream "~D {image}" depth)))
(fformat output-stream " ScreenCopy~%")))
(lgp2-send-raster output-stream array 0 0 width height t color-map run-length-encode-images)
(fformat output-stream "~%showpage~%")
(send self :send-trailer-comments))