;;; yamf.el -- METAFONT mode additive for YaTeX
;;; Author: Yoshinori IKEUCHI (JAC01617@nifty.ne.jp)
;;; Version: 0.13
;;; Date: 1999/5/14

(require 'yatex)
(require 'yatexprc)
;;(setq debug-on-error t)

;; User options
(defvar yamf-prefix "\C-c" "*Prefix key for yamf mode")
(defvar yamf-cc-letter t "*Use key C-c LETTER if non-nil")
(defvar yamf-mf-mode "proof" "*METAFONT's mode used by yamf")
(defvar yamf-mf-resolution 2602 "*Font resolution used by yamf")
(defvar yamf-proof-mode "proof" "*METAFONT's mode for proof used by yamf")
(defvar yamf-proof-resolution 2602 "*Font resolution for proof used by yamf")
(defvar yamf-mf-command "mf \\\\mode=%m; input" "*Command to run METAFONT")
(defvar yamf-mf-with-display-command "mf \\\\mode=%m; screenchars; input"
  "*Command to run METAFONT with online display")
(defvar yamf-mf-display-switch nil
  "*Run METAFONT with online display if t;
if numeric 1, use online display only with yamf-mf-char")
(defvar yamf-mfput-file "mfput.mf" "*Name of MEFATONT temporary file")
(defvar yamf-pk-directory "$TEXMF/fonts/pk/%m/local"
  "*Directory to install pk font")
(defvar yamf-tfm-directory "$TEXMF/fonts/tfm/local"
  "*Directory to install tfm file")
(defvar yamf-shell-file-name (or (getenv "ESHELL") (getenv "SHELL")))
(defvar yamf-shell-command-option YaTeX-shell-command-option)

;; Utility function
(defun yamf-define-keys (keymap deflist)
  "Define keys in KEYMAP using DEFLIST."
  (mapcar (function (lambda (def) (define-key keymap (car def) (cdr def))))
	  deflist))

;; Working variable
(defvar yamf-files-to-delete nil)

;; Bind keys
(defvar yamf-mode-map nil "Keymap for yamf-mode")
(defvar yamf-prefix-map nil "Keymap following prefix key for yamf-mode")
(if yamf-mode-map nil
  (setq yamf-mode-map (make-sparse-keymap))
  (setq yamf-prefix-map (make-sparse-keymap))
  (define-key yamf-mode-map yamf-prefix yamf-prefix-map)
  (yamf-define-keys yamf-prefix-map
	(if yamf-cc-letter
		'(("m" . yamf-mf) ("j" . yamf-typeset) ("p" . yamf-preview)
		  ("l" . yamf-lpr) ("c" . yamf-mf-char) ("h" . yamf-help)
		  ("i" . yamf-install-font) ("v" . yamf-proof) ("\C-?" . yamf-clean))
	    '(("\C-m" . yamf-mf) ("\C-j" . yamf-typeset) ("\C-p" . yamf-preview)
		  ("\C-l" . yamf-lpr) ("\C-c" . yamf-mf-char) ("\C-h" . yamf-help)
		  ("\C-i" . yamf-install-font) ("\C-v" . yamf-proof)
		  ("\C-?" . yamf-clean)))))

;; Major mode definition
(defun yamf-mode () "Major mode for developing METAFONT code.
Commands:
\\{yamf-mode-map}"
  (interactive)
  (kill-all-local-variables)
  (use-local-map yamf-mode-map)
  (setq mode-name "yamf")
  (setq major-mode 'yamf-mode)
  (run-hooks 'yamf-mode-hook)
  (message "Welcome to yamf mode"))

(defun yamf-proc-mode () "Major mode to control METAFONT process.
Commands: \\{YaTeX-typesetting-mode-map}"
  (interactive)
  (kill-all-local-variables)
  (use-local-map YaTeX-typesetting-mode-map)
  (setq mode-name "yamf-proc")
  (setq major-mode 'yamf-proc-mode)
  (setq mode-line-process '(":%s"))
  (run-hooks 'yamf-proc-mode-hook))

;; Commands
(defun yamf-clean () "Delete generated files"
  (interactive)
  (mapcar (function (lambda (name) (condition-case nil
	    (delete-file name)
        (file-error nil))))
    yamf-files-to-delete))

(defun yamf-help () "Help for yamf."
  (interactive)
  (describe-mode))

(defun yamf-install-font () "Install tfm and pk files"
  (interactive)
  (let (base-name res target cmd)
	(setq base-name (yamf-base-name))
	(setq res (int-to-string yamf-mf-resolution))
    (setq target (concat (yamf-replace-env yamf-tfm-directory) "/" 
	    (file-name-nondirectory base-name) ".tfm"))
    (copy-file (concat base-name ".tfm") target t)
    (setq target (concat 
	    (yamf-replace-env
		   (YaTeX-replace-format yamf-pk-directory "m" yamf-mf-mode))
		"/" (file-name-nondirectory base-name) "." res "pk"))
    (setq cmd (concat "gftopk " base-name "." res "gf " target))
    (yamf-launch-process cmd)))

(defun yamf-lpr () "Print TeX document."
  (interactive)
  (let (file cmd)
    (setq file (yamf-base-name (YaTeX-get-builtin "TEXFILE")))
    (setq cmd (or (YaTeX-get-builtin "LPR") dviprint-command-format))
	(if (string-match "%s" cmd)
      (setq cmd (YaTeX-replace-format cmd "s" file))
      (setq cmd (concat cmd " " file))) ;else
    (yamf-launch-process cmd)))

(defun yamf-mf () "Run METAFONT on current buffer."
  (interactive)
  (YaTeX-save-buffers)
  (let (cmd base-name)
    (setq cmd (yamf-build-command))
	(setq base-name (yamf-base-name))
	(setq yamf-files-to-delete
	  (append yamf-files-to-delete
        (list (concat base-name "." (int-to-string yamf-mf-resolution) "gf") 
		  (concat base-name ".tfm") (concat base-name ".log"))))
    (yamf-launch-process cmd)))

(defun yamf-proof () "Run METAFONT for proof on current buffer."
  (interactive)
  (YaTeX-save-buffers)
  (let (cmd base-name gf-name (yamf-mf-mode yamf-proof-mode) 
	  (yamf-mf-resolution yamf-proof-resolution)
	  (yamf-mf-display-switch nil))
    (setq cmd (yamf-build-command))
	(setq base-name (yamf-base-name))
	(setq gf-name
	  (concat base-name "." (int-to-string yamf-mf-resolution) "gf"))
    (yamf-launch-process cmd t)
	(yamf-launch-process (concat "gftodvi " gf-name) t)
    (setq cmd (or (YaTeX-get-builtin "PREVIEW") dvi2-command))
    (setq cmd (concat cmd " " base-name ".dvi"))
    (yamf-launch-process cmd)
	(setq yamf-files-to-delete
	  (append yamf-files-to-delete
        (list gf-name (concat base-name ".tfm") (concat base-name ".log")
		  (concat base-name ".dvi"))))))

(defun yamf-mf-char () "Run METAFONT for single character."
  (interactive)
  (save-excursion
    (let ((pos (point)) reglist (obuf (current-buffer)) tbuf text base-name
	  (yamf-mf-display-switch (not (null yamf-mf-display-switch))))
      (if (re-search-forward "^%#POSTAMBLE" nil t)
	  (progn (forward-line 0)
		 (setq reglist (list (cons (point) (point-max))))))
      (goto-char pos)
      (if (re-search-backward "^begin" nil t)
	  (let ((pos1 (point)))
	    (if (re-search-forward "^end" nil t)
		(progn (forward-line)
		       (setq reglist (cons (cons pos1 (point)) reglist))))))
      (if (re-search-backward "^%#ENDPREAMBLE" nil t)
	  (progn (forward-line)
		 (setq reglist (cons (cons (point-min) (point)) reglist))))
      (if (null reglist) (message "No region to compile.")
	(setq tbuf (get-buffer-create yamf-mfput-file))
	(set-buffer tbuf)
	(erase-buffer)
	(yamf-splice-regions obuf tbuf reglist)
	(set-visited-file-name yamf-mfput-file)
	(save-buffer 0)
	(setq yamf-files-to-delete (cons yamf-mfput-file yamf-files-to-delete))
	(yamf-mf)))))

(defun yamf-preview () "Preview TeX document."
  (interactive)
  (let (file cmd)
    (setq file (yamf-base-name (YaTeX-get-builtin "TEXFILE")))
    (setq cmd (or (YaTeX-get-builtin "PREVIEW") dvi2-command))
    (setq cmd (concat cmd " " file))
    (yamf-launch-process cmd)))

(defun yamf-typeset () "Run TeX."
  (interactive)
  (let (file cmd base-name)
    (setq file (YaTeX-get-builtin "TEXFILE"))
    (setq cmd (or (YaTeX-get-builtin "TEXCOMMAND") tex-command))
    (setq cmd (concat cmd " " file))
	(setq base-name (yamf-base-name file))
	(setq yamf-files-to-delete
	  (append yamf-files-to-delete
        (list (concat base-name ".dvi") 
		  (concat base-name ".aux") (concat base-name ".log"))))
    (yamf-launch-process cmd)))
		
;; Subroutines
(defun yamf-base-name (&optional name) 
  "Extract base name from full name (or name of current file if not given)"
  (if (null name)
    (setq name (buffer-file-name)))
  (if (string-match "\\.\\w*$" name)
    (setq name (substring name 0 (match-beginning 0))))
  name)

(defun yamf-build-command () "Build command line to run METAFONT."
  (let (cmd)
    (setq cmd
	  (cond ((YaTeX-get-builtin "!")) 
		((eq yamf-mf-display-switch t) yamf-mf-with-display-command)
		(t yamf-mf-command)))
    (setq cmd (YaTeX-replace-format cmd "m" yamf-mf-mode))
    (if (string-match "%s" cmd)
	  (setq cmd (YaTeX-replace-format cmd "s" buffer-file-name))
      (if (string-match "\\." cmd) nil
	  (setq cmd (concat cmd " " buffer-file-name))))
    cmd))

(defun yamf-replace-env (str) 
  "Replace names of env-variable in a string with their values."
  (while (string-match "\\$\\([A-Za-z0-9_]+\\)" str)
    (setq str 
	  (concat (substring str 0 (match-beginning 0))
		(getenv (substring str (match-beginning 1) (match-end 1)))
		(substring str (match-end 0)))))
  str)

(defun yamf-splice-regions (from-buf to-buf reglist)
  "Copy substrings from a buffer to another."
  (save-excursion
    (let (text)
      (mapcar (function (lambda (regpair)
            (set-buffer from-buf)
            (setq text (buffer-substring (car regpair) (cdr regpair)))
            (set-buffer to-buf)
            (insert text)))
        reglist))))

(defun yamf-launch-process (cmd &optional wait) "Start process from yamf"
  (let (outbuf)
    (setq outbuf (get-buffer-create "*yamf-proc*"))
    (YaTeX-showup-buffer outbuf)
    (if (and YaTeX-typeset-process
        (eq (process-status YaTeX-typeset-process) 'run)
        (progn
          (process-send-string YaTeX-typeset-process "x\r")
          (sit-for 1)
          (eq (process-status YaTeX-typeset-process) 'run))
        (progn
          (process-send-eof YaTeX-typeset-process)
          (sit-for 1)
          (eq (process-status YaTeX-typeset-process) 'run)))
      (error "Previous process is still running"))
    (save-excursion
      (set-buffer outbuf) (yamf-proc-mode) (erase-buffer))
    (setq YaTeX-typeset-process 
	  (start-process "yamf-proc" outbuf yamf-shell-file-name
	    yamf-shell-command-option cmd))
	(if wait
	  (while (eq (process-status YaTeX-typeset-process) 'run)
		(sit-for 1)))))

(provide 'yamf)