;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: XIT; Base: 10; -*-
;;;_________________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: HARDCOPY
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hohl, Hubertus
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/utilities/hardcopy.lisp
;;; File Creation Date: 8/20/90 15:59:09
;;; Last Modification Time: 07/24/92 13:43:10
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;________________________________________________________________________________ 


(in-package :xit)

;;;_______________________________________________________
;;;
;;;  Support for hardcopying windows or window portions
;;;  to files in XBM format. 
;;;_______________________________________________________

;;;
;;; Pixel -- Millimeter Conversion
;;;

(defun pixel2mm (pixel &optional (screen *screen*))
  "Converts PIXEL to mm, returning millimeters in x- and y direction."
  (declare (special *screen*))
  (values (* pixel (/ (screen-width-in-millimeters screen)
		      (screen-width screen)))
	  (* pixel (/ (screen-height-in-millimeters screen)
		      (screen-height screen)))))

(defun mm2pixel (mm &optional (screen *screen*))
  "Converts mm to pixels, returning pixels in x- and y direction."
  (declare (special *screen*))
  (values (round (* mm (/ (screen-width screen)
			  (screen-width-in-millimeters screen))))
	  (round (* mm (/ (screen-height screen)
			  (screen-height-in-millimeters screen))))))


;;; 
;;; the basic hardcopy function
;;;

(defparameter *default-hardcopy-pathname* (user-homedir-pathname))

(defparameter *hardcopy-announcement* :beep-flash
  "one of nil, :flash, :beep or :beep-flash.")

(defvar *hardcopy-counter* 0)
 
(defun hardcopy-window (window &rest options &key filename (x 0) (y 0) width height totop?)
  "Writes window's region specified by x, y, width, height to the file
   specified by FILENAME (in XBM format). The filename is merged against 
   the default hardcopy pathname. If TOTOP? is non-NIL, a totop operation
   is performed on window before hardcopying."
  
  (with-slots (display parent (p-x x) (p-y y)) window
    (flet ((announce ()
	     (case *hardcopy-announcement*
	       ((:beep :beep-flash)
		(change-keyboard-control display :bell-duration 1000)	; 1 sec
		(bell display 100)
		(change-keyboard-control display :bell-duration :default)))
	     (case *hardcopy-announcement* 
	       ((:flash :beep-flash) (flash-window window)))))
      (when totop? (totop-window window))
      (let ((path (let ((file))
		    (loop 
		      (unless (probe-file
			       (setq file
				   (make-pathname
				    #+symbolics :raw-name
				    #-symbolics :name
				    (format nil "~A-~D"
					    filename
					    (incf *hardcopy-counter*))
				    :type #+symbolics "XBM"
				    #-symbolics "xbm"
				    :defaults *default-hardcopy-pathname*)))
			(return file))))))			
	
	(prog2
	  (announce)
	  (while-busy ()
	    (write-bitmap-file
	     path
	     (if (eq window (toplevel-window window))
		 (get-image window
			    :x x
			    :y y
			    :width (or width (contact-total-width window))
			    :height (or height (contact-total-height window)))
	       (get-image parent
			  :x (+ p-x x)
			  :y (+ p-y y)
			  :width (or width (contact-total-width window))
			  :height (or height (contact-total-height window))))
	     (pathname-name path)))
	  (announce))))))

;;;
;;; Hardcopying using the mouse
;;;

(defmethod hardcopy-region-with-mouse ((self toplevel-window) &optional
				       confine-to
				       (region-width 200)
				       (region-height 280)
				       &rest hardcopy-window-options)
  "Hardcopy a region out of the window specified by CONFINE-TO (defaults to
   the toplevel-window).
   The region size initially displayed can be specified by the REGION-WIDTH and 
   REGION-HEIGHT parameters (in mm), default is the printable region of a DINA4
   paged Apple Laserwriter)."

  (let ((region (specify-region-with-mouse self
		  :confine-to confine-to
		  :initial-region
		  (region 0 0
			  (mm2pixel (max 0 region-width))
			  (multiple-value-bind (mmx mmy)
			      (mm2pixel (max 0 region-height))
			    mmy)))))
    (when region
      (apply #'hardcopy-window confine-to
	     :x (region-x region)
	     :y (region-y region)
	     :width (region-w region)
	     :height (region-h region)
	     (append hardcopy-window-options
		     (list :filename "screen-region"))))
    ))


(defmethod hardcopy-window-with-mouse ((self toplevel-window) &rest hardcopy-window-options)
  "Hardcopy a window selected by pressing a mouse button on it.
   Press any key to abort."

  (let ((found-window (identify-window self)))
    (when found-window
      (apply #'hardcopy-window found-window
	     (append hardcopy-window-options
		     (list :filename
			   (format nil "~A" (contact-name found-window)))))
      )))
  

;;; 
;;; A Hardcopy Icon
;;;

(defcontact hardcopy-icon (popup-part-connection text-icon)
  ((name :initform :hardcopy-icon)
   (reactivity :initform
	       '(((:timer hardcopy-delay) do-hardcopy)
		 (:single-left-button
		  "Hardcopy window"
		  (call :self prepare-hardcopy :window))
		 (:shift-left-button
		  "Hardcopy region"
		  (call :self prepare-hardcopy :region))
		 (:single-middle-button
		  "Move Icon"
		  (call :move))
		 (:single-right-button
		  "Hardcopy Options"
		  (call :self select-from-popup-part))))
   (mouse-feedback :initform :border)
   (x :initform 0)
   (y :initform 0)
   (border-width :initform 1)
   (inside-border :initform 1)
   (background :initform "white")
   (popup-part :initform :default)
   (popup-part-connection :initform :self)

   ;; option slots
   (hardcopy-announcement :type (or null (member :beep :flash :beep-flash))
			  :initform :beep-flash
			  :initarg :hardcopy-announcement
			  :accessor hardcopy-announcement)
   (hardcopy-default-pathname :initform *default-hardcopy-pathname*
			      :initarg :hardcopy-default-pathname
			      :accessor hardcopy-default-pathname)
   (hardcopy-name :initform "hardcopy"
		  :initarg :hardcopy-name
		  :accessor hardcopy-name)
   (hardcopy-sheet-width :initform 200		; size in mm
			 :initarg :hardcopy-sheet-width
			 :accessor hardcopy-sheet-width)
   (hardcopy-sheet-height :initform 280		; size in mm
			  :initarg :hardcopy-sheet-height
			  :accessor hardcopy-sheet-height)
   (hardcopy-delay :type integer
		   :initform 0		       
		   :initarg :hardcopy-delay
		   :accessor hardcopy-delay
		   :documentation
		   "Specifies an interval in seconds to `sleep' before taking an image. 
                    During this period events are processed normally thus allowing 
                    the user to get the target image ready.")
   )
  (:resources
    (hardcopy-announcement :initform :beep-flash)
    (hardcopy-default-pathname :initform *default-hardcopy-pathname*)
    (hardcopy-name :initform "hardcopy")
    (hardcopy-sheet-height :initform 280)
    (hardcopy-sheet-width :initform 200)
    (hardcopy-delay :initform 0))
  )

(define-resources
  (* hardcopy-icon bitmap-dispel bitmap) "hardcopy"
  (* hardcopy-icon hardcopy-announcement) :beep-flash
  (* hardcopy-icon hardcopy-default-pathname) *default-hardcopy-pathname*
  (* hardcopy-icon hardcopy-name) "hardcopy"
  (* hardcopy-icon hardcopy-delay) 0
  (* hardcopy-icon hardcopy-sheet-height) 280
  (* hardcopy-icon hardcopy-sheet-width) 200)

(defmethod prepare-hardcopy ((self hardcopy-icon) mode)
  (with-slots (width height hardcopy-delay hardcopy-sheet-height hardcopy-sheet-width) self
    (let* ((window (if (eq mode :window)
		       (identify-window (toplevel-window self))
		     (toplevel-window self)))
	   (region (if (eq mode :window)
		       (region 0 0 nil nil)
		     (specify-region-with-mouse
		      (toplevel-window self)
		      :initial-region
		      (region 0 0
			      (mm2pixel (max 0 hardcopy-sheet-width))
			      (multiple-value-bind (mmx mmy)
				  (mm2pixel (max 0 hardcopy-sheet-height))
				mmy))))))
      (when (and window region)
	(if (zerop hardcopy-delay)	; hardcopy immediately
	    (do-hardcopy self (list window region))
	  (add-timer self 'hardcopy-delay hardcopy-delay (list window region))))
      (warp-pointer self (floor width 2) (floor height 2)))))

(defmethod do-hardcopy ((self hardcopy-icon) &optional data)
  (with-slots (hardcopy-announcement hardcopy-default-pathname hardcopy-name) self
    (let ((*default-hardcopy-pathname* hardcopy-default-pathname)
	  (*hardcopy-announcement* hardcopy-announcement))
      (setq data (or data
		     (with-event (data)
		       (delete-timer self 'hardcopy-delay)
		       data)))
      (hardcopy-window (first data)
		       :x (region-x (second data))
		       :y (region-y (second data))
		       :width (region-w (second data))
		       :height (region-h (second data))
		       :filename hardcopy-name))))

(defmethod get-popup-part ((self hardcopy-icon))
  (make-window 'hardcopy-options
	       :parent (toplevel-window self)
	       :view-of self
	       :border-width 1
	       :title "Choose Hardcopy Options"
	       :title-font '(:face :bold)
	       :part-label-width 160
	       :part-value-width  270
	       :part-label-value-distance 10
	       :part-label-font '(:face :bold)
	       :part-value-font '(:face :normal)
	       :reactivity-entries
	       `((:single-left-button
		  "Read Options"
		  (call :read))
		 (:single-middle-button
		  "Move Option Sheet"
		  (call :move)))
	       :parts
	       `((:class property-field
                  :label "Announcement:"
		  :read-function hardcopy-announcement
		  :value-part
		  (:class single-choice-text-menu
		   :layouter (distance-layouter :orientation :right)
		   :parts ((:view-of :beep :text "beep")
			   (:view-of :flash :text "flash")
			   (:view-of :beep-flash :text "beep&flash"))))
		 (:label "Delay (sec) :"
		  :read-function hardcopy-delay)
		 (:label "Sheet Width (mm):"
		  :read-function hardcopy-sheet-width)
		 (:label "Sheet Height (mm):"
		  :read-function hardcopy-sheet-height)
		 (:label "Default Directory:"
		  :read-function hardcopy-default-pathname)
		 (:label "Filename:"
		  :read-function hardcopy-name)
		 )))

(defcontact hardcopy-options (popup-window title-window text-property-sheet)
  ((hide-on-part-event? :initform nil)
   (popup-position :initform :none)))


;;; finally create a hardcopy icon
;;;
(defparameter *hardcopy-icon* (make-window 'hardcopy-icon
					   :bitmap-part
					   '(:x 1 :y 1 :border-width 1)))