;;;; ps-print-config.el -- John's config for ps-print
;;; Time-stamp: <2006-07-27 12:17:07 john>

(require 'ps-print)
(require 'cl) 

(setq ps-font-info-database
      (append
       '((Quintets			; the family key
	  (fonts (normal      . "Quintets")
		 (bold        . "Quintets-bold")
		 (italic      . "Quintets-oblique")
		 (bold-italic . "Quintets-boldoblique"))
	  (size . 10.0)
	  (line-height . 11.1)
	  (space-width . 5.175)
	  (avg-char-width . 5.175))
	 (Quill				; the family key
	  (fonts (normal      . "Quill")
		 (bold        . "Quill")
		 (italic      . "Quill")
		 (bold-italic . "Quill"))
	  (size . 10.0)
	  (line-height . 13.0)
	  (space-width . 1.41421)
	  (avg-char-width . 2.71376))
	 (Quintura			; the family key
	  (fonts (normal      . "Quintura")
		 (bold        . "Quintura")
		 (italic      . "Quintura")
		 (bold-italic . "Quintura"))
	  (size . 10.0)
	  (line-height . 13.0)
	  (space-width . 1.41421)
	  (avg-char-width . 2.71376)))
       (if (boundp 'ps-font-info-database)
	   ps-font-info-database
	  nil)))

(defun ps-config-set-font (font size family)
  "Set the FONT and SIZE for ps-print.
If either is nil, it is left at its old value."
  (when font
    (let ((slanter (if (member font '("Courier"))
		       "Oblique"
		     "Italic")))
      (setq
       ps-font font
       ps-font-bold (concat font "-Bold")
       ps-font-italic (concat font "-" slanter)
       ps-font-bold-italic (concat font "-Bold" slanter))))
  (when size
    (setq
     ps-font-size size
     ps-line-height (* size 1.2)
     ps-avg-char-width (* size .556)
     ps-space-width ps-avg-char-width))
  (when family
    (setq ps-font-family family))
  )

(mapcar 'makunbound '(ps-print-extra-fonts-path jcgs-added-fonts))

(defvar ps-print-extra-fonts-path (list (substitute-in-file-name
					 (expand-file-name "$COMMON/psfonts")))
  "List of directories containing extra PostScript fonts.")

(defvar jcgs-added-fonts
  (apply 'append
	 (mapcar
	  (function
	   (lambda (directory)
	     (directory-files directory nil 
			       "^[^.~]+$"
			      )))
	  ps-print-extra-fonts-path))
  "List of names of added fonts.")

(defvar jcgs-added-font-families '(Quintets Quill Quintura)
  "Font families for which I must download font definitions")

(defun jcgs-ps-must-include-fonts ()
  "Work out whether I need to include any fonts."
  (member ps-font-family jcgs-added-font-families))

(defun added-font-file-contents (font)
  "Return the PostScript definition of FONT, as a string."
  (let ((filename (catch 'found
		    (dolist (fontdir ps-print-extra-fonts-path)
		      (let ((fullname (expand-file-name font fontdir)))
			(when (file-readable-p fullname)
			  (throw 'found fullname))))
		    nil)))
    (message "got filename %s for font %s" filename font)
    (if filename
	(save-window-excursion
	  (find-file filename)
	  (prog1
	      (buffer-string)
	    (bury-buffer)))
      nil)))

(defun jcgs-ps-add-fonts-to-prologue (prologue)
  "Return a version of PROLOGUE with any necessary fonts added to it."
  (let* ((family (assq ps-font-family ps-font-info-database))
	 (fonts (cdr (assq 'fonts family)))
	 (normal (cdr (assq 'normal fonts)))
	 (bold (cdr (assq 'bold fonts)))
	 (italic (cdr (assq 'italic fonts)))
	 (bold-italic (cdr (assq 'bold-italic fonts)))
	 (font-strings nil)
	 )
    (dolist (font (list normal bold italic bold-italic))
      (message "Considering %s for adding to prologue" font)
      (when (member font jcgs-added-fonts)
	(message "%s is one of jcgs-added-fonts" font)
	(push (added-font-file-contents font) font-strings)))
    (apply 'concat prologue font-strings)))

(defstruct ps-page-style
  title-name
  font-family
  size
  landscape
  n-columns)

(defvar ps-page-styles nil
  "Known named page styles.")

(defmacro ps-define-page-style (name family size landscape n-columns)
  "Define a page style with NAME FAMILY SIZE LANDSCAPE N-COLUMNS."
  `(push (cons ,name
	       (make-ps-page-style
		:title-name ,name
		:font-family ,family
		:size ,size
		:landscape ,landscape
		:n-columns ,n-columns))
	 ps-page-styles))

(defvar ps-config-use-color nil
  "Whether my ps config is to use color.")

(defun ps-toggle-color ()
  "Toggle whether I use color"
  (interactive)
  (setq ps-print-color-p (not ps-print-color-p) 
	ps-print-color-p ps-config-use-color
	ps-printer-name "foundry")
  (message "%s printer selected" (if ps-config-use-color "Color" "Mono")))

(defvar ps-config-style-history nil
  "History for reading ps config styles.")

(defun ps-prompt-for-style (prompt)
  "Using PROMPT, get the user to choose a style."
  (when (null ps-config-style-history)
    (setq ps-config-style-history (mapcar 'car ps-page-styles)))
  (if nil
  (let ((completion-ignore-case t))
    (completing-read prompt ps-page-styles nil t ps-current-page-style
		     (cons 'ps-config-style-history
			   (position ps-current-page-style ps-config-style-history))))
  (completing-read-with-history-hack prompt 'ps-config-style-history "Normal" ps-config-style-history ps-page-styles)))

(ps-define-page-style "Normal" 'Quintets 4 t 4)
(ps-define-page-style "Four-column" 'Quintets 4 t 4)
(ps-define-page-style "Three-column" 'Quintets 5 t 3)
(ps-define-page-style "Two-column" 'Quintets 6 t 2)
(ps-define-page-style "One-column" 'Quintets 7 t 1)
(ps-define-page-style "Two wide columns" 'Quintets 4 t 2)
(ps-define-page-style "Two extremely tight columns" 'Quintets 3 t 2)
(ps-define-page-style "Three extremely tight columns" 'Quintets 3 t 3)
(ps-define-page-style "Four incredibly tight columns" 'Quintets 2 t 4)
(ps-define-page-style "Five incredibly tight columns" 'Quintets 2 t 5)
(ps-define-page-style "One very wide column" 'Quintets 4 t 1)
(ps-define-page-style "Big" 'Quintets 36 nil 1)
(ps-define-page-style "Quill" 'Quill 12 nil 1)
(ps-define-page-style "Quintura-medium" 'Quintura 12 nil 1)
(ps-define-page-style "Quintura-small" 'Quintura 9 t 2)
(ps-define-page-style "Quintura-large" 'Quintura 18 nil 1)

(defvar ps-current-page-style "Normal"
  "The current page style, read by jcgs-ps-set-style when not given an argument.")

(defun ps-set-default-style (style)
  "Set the default style to STYLE."
  (interactive (list (ps-prompt-for-style "Default ps-print style: ")))
  (setq ps-current-page-style style)) 

(defun ps-enable-colour ()
  "Switch to colour printing."
  (interactive)
  (setq ps-config-use-color t))

(defun ps-enable-mono ()
  "Switch to mono printing."
  (interactive)
  (setq ps-config-use-color nil))

(defun jcgs-ps-set-style (&optional style-name)
  "Set up my ps-print configuration"
  (when (null style-name) (setq style-name ps-current-page-style))
  (let ((style (cdr (assoc style-name ps-page-styles))))
    (if t				; nil
	(ps-config-set-font nil (ps-page-style-size style) (ps-page-style-font-family style))
      (ps-config-set-font "Courier" 6 nil))

    (setq ps-paper-type 'a4
	  ;; ps-lpr-switches nil
	  ps-printer-name "foundry"
	  ps-spool-duplex nil

	  ps-bold-faces '(font-lock-function-name-face font-lock-keyword-face)
	  ps-italic-faces '(font-lock-string-face font-lock-comment-face)
	  ps-build-face-reference t

	  ps-landscape-mode (ps-page-style-landscape style)
	  ps-number-of-columns (ps-page-style-n-columns style)
	  ps-inter-column (/ 72 ps-number-of-columns)

	  ps-default-fg '(0.0 0.0 0.0)
	  ps-default-bg '(1.0 1.0 1.0)

	  ps-print-color-p ps-config-use-color

	  ps-print-header t
	  ps-print-header-frame t
	  ps-show-n-of-n t
	  ps-header-lines 3
	  ps-print-only-one-header t
	  ps-header-offset 9
	  ;; ps-left-header '(ps-header-dirpart ps-get-buffer-name)
	  ;; ps-right-header' ("/pagenumberstring load" time-stamp-yy/mm/dd time-stamp-hh:mm:ss)
	  )

    (unless (boundp 'original-ps-print-prologue-1)
      (message "Saving original ps-print-prologue-1")
      (setq original-ps-print-prologue-1 ps-print-prologue-1))
  
    (if (jcgs-ps-must-include-fonts)
	(setq ps-print-prologue-1 (jcgs-ps-add-fonts-to-prologue original-ps-print-prologue-1))
      (setq ps-print-prologue-1 original-ps-print-prologue-1))
    ;; (with-output-to-temp-buffer "*Latest Pr1 used*" (princ ps-print-prologue-1))

    ))

(defun jcgs-ps-print-config ()
  (jcgs-ps-set-style))

; (defun ps-print-include-font-definition (font)
;   "Include the definition of FONT if there is one in ps-print-extra-fonts-path."
;   (catch 'found
;     (let ((dirs ps-print-extra-fonts-path))
;       (while dirs
; 	(let ((filename (expand-file-name font (car dirs))))
; 	  (when (file-exists-p filename)
; 	    (insert-file-contents filename)
; 	    (throw 'found t)))
; 	(setq dirs (cdr dirs))))))

; (defun ps-begin-job--used-to-override ();; override the one in ps-print.el
;   (setq ps-page-count 0)
;   (ps-print-include-font-definition ps-font)
;   (ps-print-include-font-definition ps-font-bold)
;   (ps-print-include-font-definition ps-font-italic)
;   (ps-print-include-font-definition ps-font-bold-italic))

;; (autoload 'jcgs-ps-print-config "ps-print-config")
(add-hook 'ps-print-hook 'jcgs-ps-print-config)

;;; end of ps-print-config.el