comparison lisp/ps-print.el @ 16870:4a5fa29f79d6

(ps-print-version): Fix value. (cl lisp-float-type): Require them. (ps-number-of-columns ps-*-font-size): Try to select defaults better suited when `ps-landscape-mode' is non-nil. (ps-*-faces): Change default for Font Lock mode faces when `ps-print-color-p' is nil. (ps-right-header): Replace `time-stamp-yy/mm/dd' by `time-stamp-mon-dd-yyyy'. (ps-end-file ps-begin-page): Fix bug in page count for Ghostview. (ps-generate-postscript-with-faces): Replace `ps-sorter' by `car-less-than-car'. (ps-plot ps-generate): Replace `%d' by `%3d'.

16869:16ef2bd09de7

;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.

;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc.

;; Author: Jim Thompson <[e-mail]>
;; Maintainer: [e-mail] (Jacques Duthen Prestataire)
;; Keywords: print, PostScript

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;; LCD Archive Entry:
;; ps-print|James C. Thompson|[e-mail]|
;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)|
;; 26-Feb-1994|2.8|~/packages/ps-print.el|

;; 3.03 [jack] Sept 27, 1996 Jacques Duthen <[e-mail]>
;; Merge 31 diffs between 19.29 and 19.34

;; 3.02 [jack] June 26, 1996 Jacques Duthen <[e-mail]>
;; Add new page dimensions to `ps-page-dimensions-database' for `paper-type'
;; Improve landscape mode `ps-landscape-mode' and multiple columns
;; printing `ps-number-of-columns':
;; The text and the margins are no more scaled.
;; Simplify the semantics of `ps-inter-column' (space between columns).
;; Add error checking for negative `ps-print-width' and `ps-print-height'.
;; Change the semantics of `ps-top-margin' which is now the TOP MARGIN,
;; and add `ps-header-offset' instead of having `ps-top-margin' split in 2.
;; Add `ps-header-font-family', `ps-header-font-size' and 
;; `ps-header-title-font-size' to control the header.
;; Add `ps-header-line-pad'.
;; Change the semantics of `ps-font-info-database' to have symbolic
;; font families.
;; Add new fonts to `ps-font-info-database': `Courier' `Helvetica'
;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk'
;; Make public `ps-font-family' and `ps-font-size' so that the user
;; can directly control the text font and size without loading ps-print.
;; Add error checking for unknown font families and a message giving
;; the exhaustive list of available font families.
;; Document how to install a new font family.
;; Add `/ReportAllFontInfo' to get all the font families of the printer.
;; Add the possibility to make `mixed' font families.
;; Add `ps-setup' to get the current setup.
;; Add tools `ps-line-lengths' `ps-nb-pages-buffer' `ps-nb-pages-region'
;; to help choose the font size.
;; Split `ps-print-prologue' in two to insert info from header fonts
;; Replace indexes by macro `ps-page-dimensions-get-width'
;; to get access to the dimensions list.
;; Add `ps-select-font' inside `ps-get-page-dimensions'.
;; Fix the "clumsy" `ps-page-height' management.
;; Move `ps-get-page-dimensions' to the beginning of `ps-begin-file'
;; to get early error checking.
;; Add sample setup `ps-jack-setup'.
;;
;; Rewrite a lot of postscript code and add comments inside it
;; (maybe they should not (or optionally) be included in the generated
;; Postscript).
;; Translate the origin to (lm, bm) to simplify the other moves.
;; Fix bug in `/HeaderOffset' with `/PrintStartY'.
;; Fix bug in `/SetHeaderLines'.
;; Change `/ReportFontInfo' for use by `/ReportAllFontInfo'.
;; 

;; 3.01 [jack] June 4, 1996 Jacques Duthen <[e-mail]>
;; Manage float value for every variable representing a size.
;; Add `ps-font-info-database' `ps-inter-column'

;; 3.00 [jack] May 17, 1996 Jacques Duthen <[e-mail]>
;;	based on 2.8 Jim's Pretty-Good version:
;; Add `ps-landscape-mode' and `ps-number-of-columns'
;; for dumb multi-column landscape mode.

;; Baseline-version: 2.8.  (Jim's last change version -- this
;; file may have been edited as part of Emacs without changes to the
;; version number.  When reporting bugs, please also report the
;; version of Emacs, if any, that ps-print was distributed with.)

;;; Commentary:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;

;; Jim
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Code:

(defconst ps-print-version "3.01"
  "ps-print.el,v 3.01 1996/06/13 18:12 jack

Jack's last change version -- this file may have been edited as part of
Emacs without changes to the version number.  When reporting bugs,
please also report the version of Emacs, if any, that ps-print was
distributed with.

Please send all bug fixes and enhancements to
	Jacques Duthen <[e-mail]>.
")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User Variables:

;;; Interface to the command system

  "*List associating a symbolic paper type to its width and height.
see `ps-paper-type'.")

(defvar ps-paper-type 'letter
  "*Specifies the size of paper to format for.
Should be one of the paper types defined in `ps-page-dimensions-database':
`letter', `legal', `a4'...")

(defvar ps-landscape-mode 'nil
  "*Non-nil means print in landscape mode.")

(defvar ps-number-of-columns 1
  "*Specifies the number of columns")

;;; Horizontal layout

;;  ------------------------------------------

You can get all the fonts of YOUR printer using `ReportAllFontInfo'.")

(defvar ps-font-family 'Courier
  "Font family name for ordinary text, when generating Postscript.")

(defvar ps-font-size   8.5
  "Font size, in points, for ordinary text, when generating Postscript.")

(defvar ps-header-font-family      'Helvetica
  "Font family name for text in the header, when generating Postscript.")

(defvar ps-header-font-size        12
  "Font size, in points, for text in the header, when generating Postscript.")

(defvar ps-header-title-font-size  14
  "Font size, in points, for the top line of text in the header,
when generating Postscript.")

;;; Colors

(defvar ps-auto-font-detect t
  "*Non-nil means automatically detect bold/italic face attributes.
nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces',
and `ps-underlined-faces'.")

(defvar ps-bold-faces '()
  "*A list of the \(non-bold\) faces that should be printed in bold font.
This applies to generating Postscript.")

(defvar ps-italic-faces '()
  "*A list of the \(non-italic\) faces that should be printed in italic font.
This applies to generating Postscript.")

(defvar ps-underlined-faces '()
  "*A list of the \(non-underlined\) faces that should be printed underlined.
This applies to generating Postscript.")

(defvar ps-left-header
  (list 'ps-get-buffer-name 'ps-header-dirpart)

In either case, function or variable, the string value has PostScript
string delimiters added to it.")
(make-variable-buffer-local 'ps-left-header)

(defvar ps-right-header
  (list "/pagenumberstring load" 'time-stamp-yy/mm/dd 'time-stamp-hh:mm:ss)
  "*The items to display (each on a line) on the right part of the page header.
This applies to generating Postscript.

See the variable `ps-left-header' for a description of the format of
this variable.")

  (setq ps-page-count 0))

(defun ps-end-file ()
  (ps-output "\nEndDoc\n\n")
  (ps-output "%%Trailer\n")
  (ps-output "%%Pages: " (format "%d\n" ps-showpage-count)))

(defun ps-next-page ()
  (ps-end-page)
  (ps-flush-output)
  (ps-begin-page))

(defun ps-begin-page (&optional dummypage)
  (ps-get-page-dimensions)
  (setq ps-width-remaining  ps-print-width)
  (setq ps-height-remaining ps-print-height)

  (setq ps-page-count (+ ps-page-count 1))

  (ps-output "\n%%Page: " 
	     (format "%d %d\n" ps-page-count (+ 1 ps-showpage-count)))
  (ps-output "BeginDSCPage\n")
  (ps-output (format "/PageNumber %d def\n" ps-page-count))
  (ps-output "/PageCount 0 def\n")

  (if ps-print-header
      (progn
	(ps-generate-header "HeaderLinesLeft"    ps-left-header)
	(ps-generate-header "HeaderLinesRight"   ps-right-header)
	(ps-output (format "%d SetHeaderLines\n" ps-header-lines))))

  (ps-output "BeginPage\n")
  (ps-set-font      ps-current-font)
  (ps-set-bg        ps-current-bg)
  (ps-set-color     ps-current-color)

	      (setq ps-razchunk q-done)
	      (setq foo
		    (if (< q-todo 100)
			(/ (* 100 q-done) q-todo)
		      (/ q-done (/ q-todo 100))))
	      (message "Formatting...%d%%" foo))))))

(defun ps-set-font (font)
  (setq ps-current-font font)
  (ps-output (format "/f%d F\n" ps-current-font)))

(defun ps-mapper (extent list)
  (nconc list (list (list (extent-start-position extent) 'push extent)
                    (list (extent-end-position extent) 'pull extent)))
  nil)

(defun ps-sorter (a b)
  (< (car a) (car b)))

(defun ps-extent-sorter (a b)
  (< (extent-priority a) (extent-priority b)))

(defun ps-print-ensure-fontified (start end)

		 (eq ps-print-emacs-type 'xemacs))
	   ;; Build the list of extents...
	   (let ((a (cons 'dummy nil))
		 record type extent extent-list)
	     (map-extents 'ps-mapper nil from to a)
	     (setq a (cdr a))
	     (setq a (sort a 'ps-sorter))
	   
	     (setq extent-list nil)
	   
	     ;; Loop through the extents...
	     (while a

	;; are copied into ps-spool-buffer.
	(inhibit-read-only t))
    (save-restriction
      (narrow-to-region from to)
      (if ps-razzle-dazzle
	  (message "Formatting...%d%%" (setq ps-razchunk 0)))
      (set-buffer buffer)
      (setq ps-source-buffer buffer)
      (setq ps-spool-buffer (get-buffer-create ps-spool-buffer-name))
      (ps-init-output-queue)
      (let (safe-marker completed-safely needs-begin-file)

16870:4a5fa29f79d6

;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.

;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc.

;; Author:     Jim Thompson (was <[e-mail]>)
;; Maintainer: Jacques Duthen <[e-mail]>
;; Keywords:   print, PostScript
;; Time-stamp: <97/01/09 13:52:08 duthen>
;; Version:    3.04

(defconst ps-print-version "3.04"
  "ps-print.el, v 3.04 <97/01/09 duthen>

Jack's last change version -- this file may have been edited as part of
Emacs without changes to the version number.  When reporting bugs,
please also report the version of Emacs, if any, that ps-print was
distributed with.

Please send all bug fixes and enhancements to
	Jacques Duthen <[e-mail]>.
")

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;

;; Jim
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Code:

(eval-when-compile
  (require 'cl))

(unless (featurep 'lisp-float-type)
  (error "`ps-print' requires floating point support"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User Variables:

;;; Interface to the command system

  "*List associating a symbolic paper type to its width and height.
see `ps-paper-type'.")

(defvar ps-paper-type 'letter
  "*Specifies the size of paper to format for.
Should be one of the paper types defined in `ps-page-dimensions-database', for
example `letter', `legal' or `a4'.")

(defvar ps-landscape-mode 'nil
  "*Non-nil means print in landscape mode.")

(defvar ps-number-of-columns (if ps-landscape-mode 2 1)
  "*Specifies the number of columns")

;;; Horizontal layout

;;  ------------------------------------------

You can get all the fonts of YOUR printer using `ReportAllFontInfo'.")

(defvar ps-font-family 'Courier
  "Font family name for ordinary text, when generating Postscript.")

(defvar ps-font-size   (if ps-landscape-mode 7 8.5)
  "Font size, in points, for ordinary text, when generating Postscript.")

(defvar ps-header-font-family      'Helvetica
  "Font family name for text in the header, when generating Postscript.")

(defvar ps-header-font-size       (if ps-landscape-mode 10 12)
  "Font size, in points, for text in the header, when generating Postscript.")

(defvar ps-header-title-font-size (if ps-landscape-mode 12 14)
  "Font size, in points, for the top line of text in the header,
when generating Postscript.")

;;; Colors

(defvar ps-auto-font-detect t
  "*Non-nil means automatically detect bold/italic face attributes.
nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces',
and `ps-underlined-faces'.")

(defvar ps-bold-faces
  (unless ps-print-color-p
    '(font-lock-function-name-face
      font-lock-builtin-face
      font-lock-variable-name-face
      font-lock-keyword-face
      font-lock-warning-face))
  "*A list of the \(non-bold\) faces that should be printed in bold font.
This applies to generating Postscript.")

(defvar ps-italic-faces
  (unless ps-print-color-p
    '(font-lock-variable-name-face
      font-lock-string-face
      font-lock-comment-face
      font-lock-warning-face))
  "*A list of the \(non-italic\) faces that should be printed in italic font.
This applies to generating Postscript.")

(defvar ps-underlined-faces
  (unless ps-print-color-p
    '(font-lock-function-name-face
      font-lock-type-face
      font-lock-reference-face
      font-lock-warning-face))
  "*A list of the \(non-underlined\) faces that should be printed underlined.
This applies to generating Postscript.")

(defvar ps-left-header
  (list 'ps-get-buffer-name 'ps-header-dirpart)

In either case, function or variable, the string value has PostScript
string delimiters added to it.")
(make-variable-buffer-local 'ps-left-header)

(defvar ps-right-header
  (list "/pagenumberstring load" 'time-stamp-mon-dd-yyyy 'time-stamp-hh:mm:ss)
  "*The items to display (each on a line) on the right part of the page header.
This applies to generating Postscript.

See the variable `ps-left-header' for a description of the format of
this variable.")

  (setq ps-page-count 0))

(defun ps-end-file ()
  (ps-output "\nEndDoc\n\n")
  (ps-output "%%Trailer\n")
  (ps-output (format "%%%%Pages: %d\n" (1+ (/ (1- ps-page-count)
					      ps-number-of-columns)))))

(defun ps-next-page ()
  (ps-end-page)
  (ps-flush-output)
  (ps-begin-page))

(defun ps-begin-page (&optional dummypage)
  (ps-get-page-dimensions)
  (setq ps-width-remaining  ps-print-width)
  (setq ps-height-remaining ps-print-height)

  ;; Print only when a new real page begins.
  (when (zerop (mod ps-page-count ps-number-of-columns))
    (ps-output (format "\n%%%%Page: %d %d\n"
		       (1+ (/ ps-page-count ps-number-of-columns))
		       (1+ (/ ps-page-count ps-number-of-columns)))))

  (ps-output "BeginDSCPage\n")
  (ps-output (format "/PageNumber %d def\n" (incf ps-page-count)))
  (ps-output "/PageCount 0 def\n")

  (when ps-print-header
    (ps-generate-header "HeaderLinesLeft"    ps-left-header)
    (ps-generate-header "HeaderLinesRight"   ps-right-header)
    (ps-output (format "%d SetHeaderLines\n" ps-header-lines)))

  (ps-output "BeginPage\n")
  (ps-set-font      ps-current-font)
  (ps-set-bg        ps-current-bg)
  (ps-set-color     ps-current-color)

	      (setq ps-razchunk q-done)
	      (setq foo
		    (if (< q-todo 100)
			(/ (* 100 q-done) q-todo)
		      (/ q-done (/ q-todo 100))))
	      (message "Formatting...%3d%%" foo))))))

(defun ps-set-font (font)
  (setq ps-current-font font)
  (ps-output (format "/f%d F\n" ps-current-font)))

(defun ps-mapper (extent list)
  (nconc list (list (list (extent-start-position extent) 'push extent)
                    (list (extent-end-position extent) 'pull extent)))
  nil)

(defun ps-extent-sorter (a b)
  (< (extent-priority a) (extent-priority b)))

(defun ps-print-ensure-fontified (start end)

		 (eq ps-print-emacs-type 'xemacs))
	   ;; Build the list of extents...
	   (let ((a (cons 'dummy nil))
		 record type extent extent-list)
	     (map-extents 'ps-mapper nil from to a)
	     (setq a (sort (cdr a) 'car-less-than-car))
	   
	     (setq extent-list nil)
	   
	     ;; Loop through the extents...
	     (while a

	;; are copied into ps-spool-buffer.
	(inhibit-read-only t))
    (save-restriction
      (narrow-to-region from to)
      (if ps-razzle-dazzle
	  (message "Formatting...%3d%%" (setq ps-razchunk 0)))
      (set-buffer buffer)
      (setq ps-source-buffer buffer)
      (setq ps-spool-buffer (get-buffer-create ps-spool-buffer-name))
      (ps-init-output-queue)
      (let (safe-marker completed-safely needs-begin-file)