
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MODULE      : general.scm
;; DESCRIPTION : general scheme routines for TeXmacs
;; COPYRIGHT   : (C) 2001  Joris van der Hoeven
;;
;; This software falls under the GNU general public license and comes WITHOUT
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
;; If you don't have this file, write to the Free Software Foundation, Inc.,
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mode related
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (always?) #t)
(define (in-text?) (equal? (get-env "mode") "text"))
(define (in-math?) (equal? (get-env "mode") "math"))
(define (in-prog?) (equal? (get-env "mode") "prog"))
(define (in-session?) (inside? "session"))
(define (not-in-session?) (not (inside? "session")))
(define (in-math-in-session?) (and (in-math?) (in-session?)))
(define (in-math-not-in-session?) (and (in-math?) (not-in-session?)))
(define (in-cas-with-converters?)
  (or (in-pari?) (in-macaulay2?) (in-maxima?) (in-mupad?) (in-reduce?)))

(define (in-czech?) (and (in-text?) (equal? (get-env "language") "czech")))
(define (in-dutch?) (and (in-text?) (equal? (get-env "language") "dutch")))
(define (in-english?) (and (in-text?) (equal? (get-env "language") "english")))
(define (in-finnish?) (and (in-text?) (equal? (get-env "language") "finnish")))
(define (in-french?) (and (in-text?) (equal? (get-env "language") "french")))
(define (in-german?) (and (in-text?) (equal? (get-env "language") "german")))
(define (in-hungarian?)
  (and (in-text?) (equal? (get-env "language") "hungarian")))
(define (in-italian?) (and (in-text?) (equal? (get-env "language") "italian")))
(define (in-polish?) (and (in-text?) (equal? (get-env "language") "polish")))
(define (in-portugese?)
  (and (in-text?) (equal? (get-env "language") "portugese")))
(define (in-romanian?)
  (and (in-text?) (equal? (get-env "language") "romanian")))
(define (in-russian?) (and (in-text?) (equal? (get-env "language") "russian")))
(define (in-spanish?) (and (in-text?) (equal? (get-env "language") "spanish")))
(define (in-swedish?) (and (in-text?) (equal? (get-env "language") "swedish")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Keyboard related stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define set-keymap-body
  (lambda (l)
    (if (and (>= (length l) 2) (list? (cadr l)) (string? (caadr l)))
	(system-set-keymap (car l) (cdr l))
	(system-set-keymap (eval (car l)) (eval (cadr l))))))

(define-macro set-keymap
  (lambda l (set-keymap-body l)))

(define remove-keymap-body
  (lambda (l)
    (if (and (>= (length l) 2) (string? (cadr l)))
	(system-remove-keymap (car l) (cdr l))
	(system-remove-keymap (eval (car l)) (eval (cadr l))))))

(define-macro remove-keymap
  (lambda l (remove-keymap-body l)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (get-env s)
  (tree->string (get-env-tree s)))

(define (setup-printer cmd type dpi)
  (set-printing-command cmd)
  (set-printer-page-type type)
  (set-printer-dpi dpi))

(define (preview-with-ghostview)
  (print-to-file "$TEXMACS_HOME_PATH/system/preview.ps")
  (cond ((file-exists? "$PATH" "ghostview")
	 (shell "ghostview $TEXMACS_HOME_PATH/system/preview.ps &"))
	((file-exists? "$PATH" "gv")
	 (shell "gv $TEXMACS_HOME_PATH/system/preview.ps &"))
	((file-exists? "$PATH" "ggv")
	 (shell "ggv $TEXMACS_HOME_PATH/system/preview.ps &"))
	(else (set-message
	       "Error: ghostview does not seem to be installed on your system"
	       "preview"))))

(define (choose-file-and-print-page-selection start end)
  (choose-file "Print page selection to file" "postscript"
	       `(lambda (name) (print-pages-to-file name ,start ,end))))

(define (conditional-quit-TeXmacs confirm)
  (if (yes? confirm) (quit-TeXmacs)))

(define (safely-quit-TeXmacs)
  (if (exists-unsaved-buffer?)
      (interactive
       '("There are unsaved files. Really quit?")
       'conditional-quit-TeXmacs)
      (quit-TeXmacs)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Loading and saving
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (conditional-save-buffer file fm confirm)
  (if (yes? confirm) (texmacs-save-buffer file fm)))

(define (secure-save-buffer file fm)
  (if (file-exists? "." file)
      (interactive '("File already exists. Overwrite existing file?")
		   `(lambda (confirm)
		      (conditional-save-buffer ,file ,fm confirm)))
      (texmacs-save-buffer file fm)))

(define save-buffer
  (lambda l
    (cond ((= (length l) 0)
	   (if (no-name?)
	       (interactive '("Save as:") 'save-buffer)
	       (texmacs-save-buffer (get-name-buffer) "generic")))
	  ((= (length l) 1) (secure-save-buffer (car l) "generic"))
	  ((= (length l) 2) (secure-save-buffer (car l) (cadr l)))
	  (else (secure-save-buffer
		 (unique-file-name (car l) (cadr l)) (caddr l))))))

(define (conditional-load-buffer-path dir file fm where confirm)
  (if (yes? confirm)
      (texmacs-load-buffer dir (string-append file "~") fm where #t)
      (texmacs-load-buffer dir file fm where #f)))

(define (load-buffer-path-bis dir file fm where)
  (if (and (file-exists? dir file)
	   (file-exists? dir (string-append file "~")))
      (let ((f1 (unique-file-name dir file))
	    (f2 (unique-file-name dir (string-append file "~"))))
	(if (newer? f2 f1)
	    (interactive
	     '("Load more recent autosave file?")
	     `(lambda (confirm)
		(conditional-load-buffer-path ,dir ,file ,fm ,where confirm)))
	    (texmacs-load-buffer dir file fm where #f)))
      (texmacs-load-buffer dir file fm where #f)))

(define load-buffer-path
  (lambda l
    (cond ((= (length l) 2)
	   (load-buffer-path-bis (car l) (cadr l) "generic" 0))
	  ((and (= (length l) 3) (string? (caddr l)))
	   (load-buffer-path-bis (car l) (cadr l) (caddr l) 0))
	  ((and (= (length l) 3) (integer? (caddr l)))
	   (load-buffer-path-bis (car l) (cadr l) "generic" (caddr l)))
	  (else (load-buffer-path-bis
		 (car l) (cadr l) (caddr l) (cadddr l))))))

(define load-buffer
  (lambda l
    (cond ((= (length l) 1)
	   (load-buffer-path-bis "$TEXMACS_FILE_PATH" (car l) "generic" 0))
	  ((and (= (length l) 2) (string? (cadr l)))
	   (load-buffer-path-bis "$TEXMACS_FILE_PATH" (car l) (cadr l) 0))
	  ((and (= (length l) 2) (integer? (cadr l)))
	   (load-buffer-path-bis
	    "$TEXMACS_FILE_PATH" (car l) "generic" (cadr l)))
	  (else (load-buffer-path-bis
		 "$TEXMACS_FILE_PATH" (car l) (cadr l) (caddr l))))))

(define (load-texmacs-buffer s) (load-buffer s "TeXmacs"))
(define (save-texmacs-buffer s) (save-buffer s "TeXmacs"))
(define (load-latex-buffer s) (load-buffer s "latex"))
(define (save-latex-buffer s) (save-buffer s "latex"))
(define (load-html-buffer s) (load-buffer s "html"))
(define (save-html-buffer s) (save-buffer s "html"))
(define (load-scheme-buffer s) (load-buffer s "scheme"))
(define (save-scheme-buffer s) (save-buffer s "scheme"))
(define (load-verbatim-buffer s) (load-buffer s "verbatim"))
(define (save-verbatim-buffer s) (save-buffer s "verbatim"))
(define (load-help-buffer s) (load-buffer s "help"))
(define (load-in-new-window s) (load-buffer s 1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Initialization commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (init-page-margins l r t b)
  (init-env "odd page margin" l)
  (init-env "even page margin" l)
  (init-env "page right margin" r)
  (init-env "page top margin" t)
  (init-env "page bottom margin" b))

(define (init-screen-reduction l r t b)
  (init-env "reduction page left margin" l)
  (init-env "reduction page right margin" r)
  (init-env "reduction page top margin" t)
  (init-env "reduction page bottom margin" b))

(define (init-page-size w h p)
  (init-env "page type" "user")
  (init-env "page width" w)
  (init-env "page height" h)
  (init-env "paragraph width" p)
  (init-page-margins "5mm" "5mm" "5mm" "5mm")
  (init-screen-reduction "0cm" "0cm" "0cm" "0cm"))

(define (init-text-width s) (init-env "paragraph width" s))
(define (init-font-size s) (init-env "font base size" s))
(define (init-dpi s) (init-env "dpi" s))
(define (init-first-indent s) (init-env "first indentation" s))
(define (init-interline s) (init-env "interline space" s))
(define (init-interline-spc s) (init-env "line stretch" s))
(define (init-interpar-spc s) (init-env "interparagraph space" s))
(define (init-magn s) (init-env "magnification" s))
(define (other-shrinking-factor s) (set-shrinking-factor (string->number s)))
(define (init-page-shrink s) (init-env "page shrink" s))
(define (init-page-extend s) (init-env "page extend" s))
(define (init-page-flexibility s) (init-env "page flexibility" s))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; try to obtain the papersize in this order from
;; - the environment variable PAPERCONF
;; - the contents of the file specified by the PAPERSIZE environment variable
;; - the contents of the file "/etc/papersize"
;; or else default to "a4"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (get-default-paper-size)
  (or (getenv "PAPERCONF")
      (let ((papersizefile (or (getenv "PAPERSIZE") '"/etc/papersize")))
	(if
	 (access? papersizefile R_OK)
	 (let ((pps-port (open-input-file papersizefile)))
	   (let ((size (read-line pps-port)))
	     (begin
	       (close-input-port pps-port)
	       size)))
	 "a4"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Miscellaneous commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (real-math-font? fn)
  (or (equal? fn "roman") (equal? fn "concrete")))

(define (real-math-family? fn)
  (or (equal? fn "mr") (equal? fn "ms") (equal? fn "mt")))

(define (prog-remove-backwards)
  (if (inside? "input") (session-remove-backwards) (remove-backwards)))

(define (filter-maxima-in session s)
  (cond ((equal? s "") "0;")
	((equal? (car (reverse (string->list s))) #\;) s)
	((equal? (car (reverse (string->list s))) #\$) s)
	(else (string-append s ";"))))

(define (extern-exec s)
  (if (inside? "session")
      (connection-exec (get-env "prog language") (get-env "this session") s)))

(define (not-implemented s) (set-message "Error: not yet implemented" s))
