REF: Screen Hardcopy under program control

[Chris Wood <Chris@SHRIKE.AUSTIN.LOCKHEED.COM>]

Screen Hardcopy under program control?

Alright, Richard,

Here is a little hack to give this little capability to everyone that is
interested.  This builds a Symbolics command:
     Hardcopy Window Under Mouse

It even scrolls and prints really wide or tall windows.  It is nice enough to
grab the mouse while it works (interesting little hack). This was originally
developed under KEE, but I have tried to remove all KEE dependencies. 

WARNING!  It is possible to spawn processes which do the print spooling in the
background, but it has been my experience that this is almost guaranteed to
screw up the printer queue if you try to zing them out too fast.  This way may
be slow, but it almost never breaks.

Some enterprising soul might want to put a delay keyword in to allow the user
to flip to another screen and hardcopy a window where there is no visible lisp
listener.  Let me know!

Chris Wood
chris@austin.lockheed.com

--------------------------------------------------------------------------------

;;; -*- Syntax: Common-Lisp; Package: user; Base: 10; Mode: Lisp; Default-character-style: (:FIX :BOLD :NORMAL) -*-

(defvar busy-string
	(list "@@@@@@@@@@@@@@@." 
	      "@.............@." 
	      "@@@.........@@@." 
	      ".@@@.......@@@.." 
	      "..@@@@...@@@@..." 
	      "...@@@@@@@@@...." 
	      "....@@@@@@@....." 
	      ".....@@@@@......"
	      "....@@.@.@@....."
	      "...@@..@..@@...."
	      "..@@..@@@..@@..."
	      ".@@..@@@@@..@@.."
	      "@@..@@@@@@@..@@."
	      "@..@@@@@@@@@..@."
	      "@@@@@@@@@@@@@@@."
	      "................"
	      "@...@..@@..@.@@@"
	      "@...@.@..@.@..@."
	      "@.@.@.@@@@.@..@."
	      "@.@.@.@..@.@..@."
	      "@@@@@.@..@.@..@."))

(defun string-to-bitmap (string-var name)
  "Converts string variable to a bitmap"
  (let* ((row 0)
	 (width (length (car string-var)))
	 (bit-array 
	   (tv:with-output-to-bitmap ()
	     (dolist (line string-var)
	       (dotimes (col width)
		 (if (equal #\@ (elt line col))
		     (graphics:draw-point col row)))
	       (incf row))))
	 (bitmap
	   (cw:make-bitmap :width width :height row :bits-per-pixel 1 :name name)))
    (setf (CW:BITMAP-BIT-ARRAY bitmap) bit-array)
    bitmap
    ))

(defvar busy-cursor 
	(cw:make-mouse-cursor
	  :bitmap (string-to-bitmap busy-string 'hourglass)))

(defun hardcopy-wide-window (&optional (window (tv:window-under-mouse)))
  (cw:with-mouse-grabbed busy-cursor
    (let* ((width (cw::window-stream-inner-width window))
	   (scroll-amt (floor (* width .9)))
	   (current-offset (scl:send window :x-offset))	;remember current window position
	   )
      (scl:send window :pan-to 0 :absolute)	;left justify window
      (hci::hardcopy-window window)		;print first frame
      (loop:loop 
	while (scl:send window :scroll-more-to-right)		;if more to right
	do (scl:send window :pan-to scroll-amt :relative)	;scroll
	do (hci::hardcopy-window window)			;and print next frame
	)
      (scl:send window :pan-to 0 :absolute)	;scroll to edge
      (scl:send window :pan-to current-offset :relative)	;restore position
      )))

(defun hardcopy-tall-window (&optional (window (tv:window-under-mouse)))
  (cw:with-mouse-grabbed busy-cursor
    (let* ((height (cw::window-stream-inner-height window))
	   (extent-height (scl:send window :extent-height))
	   (scroll-amt (floor (* height .9)))
						;remember current window position
	   (current-offset (- (scl:send window :y-offset)))	
	   )
      (scl:send window :scroll-to 0 :absolute)	;top justify window
      (hci::hardcopy-window window)		;print first frame
      (loop:loop 
	while (scl:send window :scroll-more-below)		;if more below
	do (scl:send window :scroll-to scroll-amt :relative)	;scroll
	do (hci::hardcopy-window window)			;and print next frame
	)
						;Yeah, I know this is backwards.
						;but positive offsetting from 0 didn't work
      (scl:send window :scroll-to extent-height :absolute)	;scroll to bottom
      (scl:send window :scroll-to current-offset :relative)	;restore position
      )))
;;;
;;; Add a Symbolics-specific Command Interface for Hardcopy Window Under Mouse

#+Symbolics
(cp:define-command
  (com-hardcopy-window-under-mouse :command-table "Global")
    ((scroll '(member :no :wide :tall)
	     :default :no
	     :prompt "Scroll and Print Oversized Window?"
	     :documentation "Print a single frame :none or multiple frames :wide or :tall")
     )
   (print scroll)
   (case scroll
     (:wide
       (let ((window (tv:window-under-mouse)))
	 (format t "~%Hardcopying (Wide) window currently under mouse: ~S ..." window)
	 (hardcopy-wide-window window)
	 (format t " Done~%")))
     (:tall 
       (let ((window (tv:window-under-mouse)))
	 (format t "~%Hardcopying (Tall) window currently under mouse: ~S ..." window)
	 (hardcopy-tall-window window)
	 (format t " Done~%")))
     (:no
       (let ((window (tv:window-under-mouse)))
	 (cw:with-mouse-grabbed busy-cursor
	   (format t "~%Hardcopying window currently under mouse: ~S ..." window)
	   (hci::hardcopy-window window)
	   (format t " Done~%")))
       ))
   )