;;; -*- Mode:LISP; Package:ZWEI; Patch-File:T; Readtable:ZL; Base:10 -*-

;;;Pathname defaults

(setq zwei:*pathname-defaults*
      (lisp:remove nil zwei:*pathname-defaults* :key #'car))

(setq zwei:*pathname-defaults*
      (push (cons nil (make-pathname :defaults "keith;foo.lisp"
				     :host si:associated-machine))
	    zwei:*pathname-defaults*))

(setq zwei:*pathname-defaults*
      (lisp:remove si:local-host zwei:*pathname-defaults* :key #'car))

(push (cons si:local-host (make-pathname :defaults "temp;foo.lisp"
					 :host si:local-host))
      zwei:*pathname-defaults*)

;;; Add ZMail bug destinations
;;Old Daze
;(if (null(cl:assoc "UNIX" *zmail-bug-list* :test #'string-equal))
;    (push '("UNIX"
;	    :VALUE "UNIX"
;	    :DOCUMENTATION "Report a bug in Unix software.")
;	  *zmail-bug-list*))
;;
;(if (null(cl:assoc "VISTA" *zmail-bug-list* :test #'string-equal))
;    (push '("VISTA"
;	    :VALUE "VISTA"
;	    :DOCUMENTATION "Report a bug in Vista software.")
;	  *zmail-bug-list*))

;;;Install standard commands for my convenience

(login-forms
  zwei:(set-comtab *standard-comtab*
	      '(
		;;set up hand keys to work like arrow keys
		#\hand-up com-up-real-line
		#\hand-down com-down-real-line
		#\hand-left com-backward
		#\hand-right com-forward
		;;quick page moves
		#\meta-hand-up com-previous-page
		#\meta-hand-down com-next-page
		;;Make roman keys do useful stuff
		#\roman-i com-backward-paragraph
		#\roman-ii com-forward-paragraph
		#\roman-iii com-beginning-of-line
		#\roman-iv com-end-of-line
		#\meta-roman-i com-correct-spelling
		;; Untabify (change tab to spaces)
		#\control-i com-untabify
		;;Make delete do rubout
		#\delete com-rubout
		;;Exotic
		#\meta-control-shift-m com-compiler-optimize)))

;;;Personal commands
;;;
;;;EZ installation: 

(defmacro install-command-and-advertise (command &optional char
					 (comtab '*zmacs-comtab*) announcement)
  "Install COMMAND (a DEFCOM'd symbol) on COMTAB.
If CHAR is non-NIL, store command on key CHAR.
Print command documentation and, if specified, ANNOUNCEMENT."
  ;; Install and notify.
  `(let((command ,command)
	(comtab ,comtab)
	(char ,char)
	(announcement ,announcement)
	(standard-output terminal-io))
     (when char (command-store command char comtab))
     (set-comtab comtab nil (make-command-alist (ncons command)))
     (format t "~&~%***Installing ~:[extended command~;key command~] ~:(~A~) on ~A~@[~&~A~]"
	     char
	     command
	     (comtab-name comtab)
	     announcement)
     (if char (document-key char comtab)
       (format t "~&~A" (get command 'documentation)))))

;;;Printing

(DEFUN PRINT-BUFFER-1-no-headings (INTERVAL &OPTIONAL (*STANDARD-OUTPUT* *QUERY-IO*))
  "Print INTERVAL's contents on default printer.
The value supplied for *STANDARD-OUTPUT* is used for printing
notes about the progress of the printing."
  (LET* ((FONTS (SEND INTERVAL :GET-ATTRIBUTE ':FONTS))
	 (STREAM (IF (ATOM FONTS)
		     (ZWEI:INTERVAL-STREAM INTERVAL)
		   (ZWEI:INTERVAL-STREAM INTERVAL NIL NIL T))))
    (SI:HARDCOPY-STREAM STREAM
			:page-headings nil
			:file-heading nil))
  (FORMAT T " -- Done.")
  T)

(DEFCOM COM-QUICK-PRINT-BUFFER-no-headings "Prints the current buffer on the default hardcopy device without headings." ()
  (typein-line "~&Attempting transmission: ")
  (PRINT-BUFFER-1-NO-HEADINGS *INTERVAL*)
  DIS-NONE)

(install-command-and-advertise 'com-quick-print-buffer-no-headings #\super-shift-p)

(defcom com-print-associated-file
	"Print file associated with ZMacs buffer; prints without headings."
	()
  ;; Buffer must be a file
  (if (probe-file *zmacs-buffer-name*)
      ;; So print it
      (hardcopy-file *zmacs-buffer-name*
		     :page-headings nil
		     :file-heading nil)
    ;; or die
    (barf "~&~a is not an accessible file.~&"
	  *zmacs-buffer-name*))
  ;; Nothing to redisplay
  dis-none)

(install-command-and-advertise 'com-print-associated-file #\hyper-p)

(DEFUN MEMO-HEADING (INTERVAL)
  (let((first  (SEND INTERVAL :first-BP)))
    (move-bp (point) first)
    (INSERT-MOVING (point)
		   (STRING-APPEND
		     (MAKE-STRING 30 :INITIAL-ELEMENT #\SPACE)
		     "MEMORANDUM"  #\RETURN #\RETURN
		     "TO:"         #\TAB #\RETURN
		     "FROM:"       #\TAB
		     (IF (AND (BOUNDP 'FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST)
			      (STRINGP FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST))
			 FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
		       "")
		     #\RETURN
		     "DATE:"       #\TAB
		     (LET((TIMESTRING (FORMAT NIL "~\TIME\" (TIME:GET-UNIVERSAL-TIME))))
		       (SUBSTRING TIMESTRING 0 (STRING-SEARCH #\SPACE TIMESTRING)))
		     #\RETURN
		     "SUBJ:"       #\TAB #\RETURN
		     "COPY:"       #\TAB #\RETURN))
    dis-text))

(DEFCOM COM-MEMO-HEADING "Prints a memorandum heading at the beginning of the current buffer."
  (typein-line "~&Memo header: ")
  (MEMO-HEADING *INTERVAL*)
  (typein-line " -- Done.")
  DIS-TEXT)

(install-command-and-advertise 'com-memo-heading)

;;;Buffers

(defcom com-bury-buffer "Rotate the buffer stack (current buffer goes to bottom)" ()
  (WITHOUT-INTERRUPTS
    (DOLIST (W *ALL-ZMACS-WINDOWS*)
      (LET ((HISTORY (SEND W :BUFFER-HISTORY)))
	(APPEND-REMOVE-ON-HISTORY *interval* HISTORY)))
    (SETQ *ZMACS-BUFFER-LIST* (APPEND (REMQ *interval* *ZMACS-BUFFER-LIST*)
				      (LIST *interval*)))
    (MAKE-BUFFER-CURRENT (first *zmacs-buffer-list*)))
  dis-text)

(install-command-and-advertise 'com-bury-buffer #\super-b)

(defcom com-rotate-buffer-stack "Rotates the buffer stack (bottom of stack becomes new current one)." ()
  (WITHOUT-INTERRUPTS
    (DOLIST (W *ALL-ZMACS-WINDOWS*)
      (LET ((HISTORY (SEND W :BUFFER-HISTORY)))
	(PUSH-REMOVE-ON-HISTORY *interval* HISTORY)))
    (SETQ *ZMACS-BUFFER-LIST* (APPEND (last *ZMACS-BUFFER-LIST*)
				      (butlast *ZMACS-BUFFER-LIST*)))
    (MAKE-BUFFER-CURRENT (first *zmacs-buffer-list*)))
  dis-text)

(install-command-and-advertise 'com-rotate-buffer-stack #\super-r)

;;;Point

(defcom com-pop-point-pdl "Pop the point pdl (and move to last point)." (KM)
  (MULTIPLE-VALUE-BIND (BP PLINE)
      (POINT-PDL-POP *WINDOW*)
    (POINT-PDL-MOVE BP PLINE))
  DIS-BPS)

(install-command-and-advertise 'com-pop-point-pdl #\control-hand-up)

;;;Selecting files as tag table

(defvariable *zmacs-prefer-preload-tag-table-files-in-background* nil :boolean)

(defcom com-select-files-as-tag-table "Prompts for and selects files to use as a tag table.
  With a numeric argument, reads in all specified files in the background." ()
  (let* ((pathname (READ-defaulted-pathname
		     "File or files to use as tag table:"
		     (merge-pathnames (DEFAULT-PATHNAME)
				      (make-pathname :name :wild :type :lisp :version :newest))))
	 (tag-table-name (typein-line-readline "Name for this tag table:"))
	 (file-list (directory pathname)))
    (SELECT-FILE-LIST-AS-TAG-TABLE
      file-list
      (do ((used-name tag-table-name
		      (typein-line-readline
			(format nil "/"~a/" is already the name of a tag table. ~
Please enter another name for this new one:"
				used-name))))
	  (nil)
	(if (not (ass #'string-equal used-name *zmacs-tag-table-alist*))
	    (return used-name))))
    ;;;Optionally, pre-load all files
    (when (or *zmacs-prefer-preload-tag-table-files-in-background* *numeric-arg-p*)
      (process-run-function (format nil "Load ~A files into ZMacs" tag-table-name)
			    #'(lambda (files window)
				(dolist (file files) (load-file-into-zmacs file nil))
				(tv:careful-notify
				  window t
				  "The files of ~A have been loaded into ZMacs and selected as current tag table."
				  tag-table-name))
			    ;;Args to background file-finding function:
			    file-list *window*)))
  ;;;Done.
  (typein-line "Done.")
  DIS-NONE)
			  
(install-command-and-advertise 'com-select-files-as-tag-table)

;;;Byte specs

(DEFCOM COM-EVALUATE-byte-spec-AND-REPLACE-INTO-BUFFER
	"Evaluate the current s-expression as a byte specifier and replace
with the proper (BYTE x y) form into the buffer.
The original expression is deleted and the BYTE spec, printed out, replaces it."
	()
  (com-forward-sexp-no-up)
  (com-backward-sexp-no-up)
  (LET* ((POINT (point))
	 (MARK (MARK))
	 (STREAM (REST-OF-INTERVAL-STREAM POINT))
	 (FORM (READ-OR-BARF STREAM)))
    (MOVE-BP MARK (SEND STREAM :READ-BP))
    (typecase form
      (number
       (let* ((width     (logand form #o77))
	      (position  (lsh    form -6.))
	      (result (format nil "(BYTE ~D. ~D.)" width position)))
		(if (= (eval (read-from-string result)) form)
		    (progn
		      (WITH-UNDO-SAVE ("replacement" POINT MARK T)
			(princ result STREAM)
			(WITH-BP (END (SEND STREAM :READ-BP) :NORMAL)
			  (DELETE-INTERVAL POINT MARK T)
			  (MOVE-BP POINT END))))
		  (error "UNBYTE error: (UNBYTE ~S) -> ~A" form result))))
      (symbol
       (when (y-or-n-p "~S is a symbol -- edit its definition?" form)
	 (edit-definition form T T)))
      (list
       (if (fboundp (setq form (first form)))
	   (when (y-or-n-p "~S is a function -- edit its definition?" form)
	     (edit-definition form T T))
	 (barf "~S is not a function." form)))
      (t (barf "Cannot create a byte specifier from ~S" form))))
  DIS-TEXT)

(install-command-and-advertise 'com-evaluate-byte-spec-and-replace-into-buffer #\hyper-b)

;;;Collection Buffers
;;;
;;;This is a tool for making and using buffers as holding places to collect
;;;various things - specified regions, lines, sexp's, etc.
;;;
;;;This is useful if you are, for example, perusing a large piece of code or
;;;text and you want to copy selected portions into another buffer.  Using
;;;these commands, you never have to move to the other buffer.
;;;
;;;Create a collection buffer with Meta-X Start Collection Buffer, or select
;;;any existing buffer with the same command.  Use any of the following
;;;commands to copy text into the current collection buffer:

;;; - Collect Definition
;;; - Collect Line
;;; - Collect Note
;;; - Collect Region
;;; - Collect Paragraph
;;; - Collect Sexp (TBD)

(defvar *current-collection-buffer* nil)

(defun current-collection-buffer ()
  (let ((buffer (or *current-collection-buffer*
		    (setq *current-collection-buffer*
			  (find-buffer-named "*Collection-Buffer*")))))
    (unless (memq buffer *zmacs-buffer-list*)
      (if (y-or-n-p "There is no current collection buffer.  Start one?")
	  (progn (com-start-collection-buffer)
		 (setq buffer *current-collection-buffer*)
		 (fquery '(:type :tyi :clear-input t :choices :any
			   :list-choices nil)
			 "Press any key to continue:"))
	(barf "Cannot collect without a collection buffer.")))
    buffer))

(defmacro collecting-buffer-flags (buffer)
  `(getf (plist ,buffer) 'collecting-buffer-flags))

(defmacro get-collecting-buffer-flag (buffer flag)
  `(getf (collecting-buffer-flags ,buffer) ,flag))

(defmacro set-collecting-buffer-flag (buffer flag value)
  (declare (zwei:indentation 1 1 2 1))
  `(setf (get-collecting-buffer-flag ,buffer ,flag) ,value))

(defun set-collecting-buffer-flags (buffer)
  (set-collecting-buffer-flag buffer :pathname
    (y-or-n-p "Note buffer pathname or name in comment before inserting sections?")))

(defun maybe-set-collecting-buffer-flags (buffer)
  (unless (collecting-buffer-flags buffer)
    (set-collecting-buffer-flags buffer)))
   
(defun do-collecting-flags-before (from to)
  (when from
    (let ((flags (collecting-buffer-flags to)))
      (if (getf flags :pathname)
	  (insert-moving
	    (interval-last-bp to)
	    (format nil "~@[~2&;;;From ~A~&~]"
		    (or (buffer-pathname from)
			(buffer-name from))))))))

(defcom com-start-collection-buffer
	"Create or select a collection buffer for use with Collect commands."
	()
  (setq *current-collection-buffer*
	(read-buffer-name "Collection buffer name:"
			  "*Collection-Buffer*" t))
  (set-collecting-buffer-flags *current-collection-buffer*)
  (typein-line "~&Use /"Collect/" commands to gather information into /"~A/""
	       (buffer-name (current-collection-buffer)))
  dis-none)

(install-command-and-advertise 'com-start-collection-buffer)

(defcom com-set-collection-buffer
	"Switch to selected collection buffer for use with Collect commands."
	()
  (setq *current-collection-buffer*
	(read-buffer-name "Collection buffer name:"
			  "*Collection-Buffer*" nil))
  (maybe-set-collecting-buffer-flags *current-collection-buffer*)
  (typein-line "~&Use /"Collect/" commands to gather information into /"~A/""
	       (buffer-name (current-collection-buffer)))
  dis-none)

(install-command-and-advertise 'com-set-collection-buffer)

(defmacro with-current-collection-buffer ((var) &body body)
  (declare (indentation 1 1))
  `(let ((,var (current-collection-buffer)))
     ,@body
     (move-bp (buffer-saved-point ,var) (interval-last-bp ,var))))

(defcom com-collect-definition
	"Collect the current DEFUN (or other type of definition)
  into the current collection buffer.
With a numeric argument, collect the definition name only."
	()
  (with-current-collection-buffer (collection-buffer)
    (let ((def-name (read-function-name
		      (format nil "Collect Definition~@[ Name~]:" *numeric-arg*)
		      (section-node-name (bp-node (point)))
		      'aarray-ok)))
      (if *numeric-arg-p*
	  ;;Just collect the definition name.
	  (insert-moving
	    (interval-last-bp collection-buffer)
	    (format nil "~%~S" def-name))
	;;Collect the Sexp corresponding to the chosen definition.
	(let ((files (si:get-all-source-file-names def-name)))
	  (if (null files)
	      (barf "No known definition of ~A" def-name)
	    ;;;Now we have an alist of form types and pathname(s)
	    ;;;containing definition(s) of <def-name>.  If we only have
	    ;;;one form type (e.g., there's a DEFUN but no DEFVAR), and
	    ;;;we only have one defining file pathname, then there is
	    ;;;only one definition possibility.
	    (let ((file (if (and (= (length files) 1)
				 (= (length (car files)) 2))
			    (cadar files)
			  (block pick-a-file
			    (typein-line "There are multiple definitions of ~A:" def-name)
			    ;;Walk down alist of form/pathname pairs, let user choose one.
			    (dolist (pair files)
			      (when (consp pair)
				(let ((form-type (car pair))
				      (defining-files (cdr pair)))
				  (dolist (defining-file defining-files)
				    (when (y-or-n-p "Do you want the definition of ~A as a ~A in ~A?"
						    def-name form-type defining-file)
				      (return-from pick-a-file defining-file))))))))))
	      (if (null file)
		  (barf "No definition chosen for collection."))
	      ;;Now there's only one file possibility.
	      (setq file (send file :source-pathname))
	      (typein-line "~&Looking for definition in ~A..." file)
	      ;;Better find the file first, or it'll only work on
	      ;;definitions in files already read into the machine!
	      (let* ((buffer (find-file file nil))
		     (def (or (assoc buffer
				     (or (get def-name 'zmacs-buffers)
					 (barf "No definitions found for ~A." def-name)))
			      (barf "Cannot find a unique definition of ~A.
Try Meta-. to visit definitions and collect the one(s) you want." def-name)))
		     (line (cdr def))
		     (definition-start (create-bp line 0)))
		;;Now we know where the def is
		(do-collecting-flags-before buffer collection-buffer)
		;;Back up to include comments and/or package prefixes:
		(setq definition-start
		      (backward-over-comment-lines
			(or (backward-over-package-prefix definition-start) definition-start)))
		;;Insert definition text into collection buffer:
		(insert-interval (interval-last-bp collection-buffer)
				 definition-start
				 (forward-sexp definition-start 1)
				 t)
		;;Insert 2 newlines at end of collection buffer:
		(insert-moving (interval-last-bp collection-buffer) #\Return)
		(insert-moving (interval-last-bp collection-buffer) #\Return))))))
      ;;Finally, tell the user what happened:
      (typein-line "Collected definition~@[ name~*~] into /"~A/"."
		   *numeric-arg-p*
		   (buffer-name collection-buffer))))
  dis-text)

(install-command-and-advertise 'com-collect-definition #/hyper-F)

(defcom com-collect-line
	"Collect the line surrounding point into the current collection buffer."
	()
  (with-current-collection-buffer (buffer)
    (do-collecting-flags-before nil buffer)
    (insert-moving
      (interval-last-bp buffer)
      (string-append #/return (bp-line (point))))
    (typein-line "Collected line into /"~A/"." buffer))
  dis-text)

(install-command-and-advertise 'com-collect-line #/hyper-L)

(defcom com-collect-note
	"Collect a note typed into the mini-buffer into the current collection buffer."
	()
  (with-current-collection-buffer (buffer)
    (do-collecting-flags-before nil buffer)
    (insert-moving
      (interval-last-bp buffer)
      (string-append #\newline
		     (string-trim '(#\newline)
				  (typein-line-multi-line-readline
				    "Note for collection buffer (end with ~C):" #\END))
		     #\newline))
    (typein-line "Collected note into /"~A/"." buffer))
  dis-text)

(install-command-and-advertise 'com-collect-note #/hyper-N)

(defcom com-collect-paragraph
	"Collect the paragraph(s) from point into the current collection buffer."
	()
  (with-current-collection-buffer (buffer)
    (do-collecting-flags-before *interval* buffer)
    (insert-interval
      (interval-last-bp buffer)
      (copy-interval (paragraph-interval (point) *numeric-arg*)))
    (typein-line "Collected ~D paragraph~:P into /"~A/"." *numeric-arg* buffer))
  dis-text)

(install-command-and-advertise 'com-collect-paragraph #/hyper-H)

(defcom com-collect-region
	"Collect the currently marked region into the current collection buffer.
With a numeric argument, remove region from current buffer after collecting."
	()
  (with-current-collection-buffer (buffer)
    (do-collecting-flags-before *interval* buffer)
    (region (start end)
      (insert-interval
	(interval-last-bp buffer)
	(copy-interval start end t buffer))
      (when *numeric-arg-p*
	(with-undo-save ("Collection-Region-Remove" start end t)
	  (kill-interval start end t t t))
	(setq *current-command-type* 'kill)
	(clean-point-pdl *window*)
	(let ((pdl (window-point-pdl *window*)))
	  (and pdl (move-bp (mark) (caar pdl))))))
    (typein-line "Collected region into /"~A/"." buffer))
  dis-text)

(install-command-and-advertise 'com-collect-region #/hyper-r)

;;;Our commenting conventions:

(install-command-and-advertise 'com-indent-for-local-modification-cts #/ctrl-$)
(install-command-and-advertise 'com-indent-for-systematic-modification-cts #/ctrl-&)
(install-command-and-advertise 'com-indent-for-enhancement-suggestive-cts #/ctrl-@)
(install-command-and-advertise 'com-indent-for-maintenance-suggestive-cts #/ctrl-+)

(defcom com-describe-comment-indents "Describes the keys for local commenting conventions" ()
  (document-key #/ctrl-$ *zmacs-comtab*)
  (document-key #/ctrl-& *zmacs-comtab*)
  (document-key #/ctrl-@ *zmacs-comtab*)
  (document-key #/ctrl-+ *zmacs-comtab*)
  dis-none)

(install-command-and-advertise 'com-describe-comment-indents)

;;;
;;Installed in zwei system 129.
;(defcom com-unfasl-file
;	"Unfasl selected file and visit output"
;	()
;  (let* ((default (fs:default-pathname(pathname-defaults)))
;	 (file (read-defaulted-pathname "File to UNFASL:"  (send default :new-pathname :type :qfasl) "QFASL"))
;	 output-file)
;    (typein-line "~&UNFASLing /"~A/"" file)
;    (setq output-file (si:unfasl-file file))
;    (find-file output-file))
;  dis-none)

;(install-command-and-advertise 'com-unfasl-file)


(DEFCOM COM-SET-tvFONT "Quietly toggle the current buffer's font between TVFONT and CPTFONT." ()
  (LET* ((FONT (if (eq (TV:FONT-NAME (AREF (SEND (WINDOW-SHEET *WINDOW*) :FONT-MAP) 0))
		       'fonts:tvfont)
		   'fonts:cptfont 'fonts:tvfont)))
    (unless (BOUNDP FONT)
      (LOAD (FORMAT NIL "SYS: FONTS; ~A" FONT)
	    :PACKAGE 'FONTS
	    :SET-DEFAULT-PATHNAME NIL
	    :IF-DOES-NOT-EXIST NIL)
      (OR (BOUNDP FONT) (BARF "~S is not a defined font" FONT)))
    (SEND *INTERVAL* :SET-ATTRIBUTE :FONTS (list FONT) nil)
    (REDEFINE-FONTS *WINDOW* (list (CONS (SYMBOL-NAME FONT) (SYMBOL-VALUE FONT))))
    (UPDATE-FONT-NAME))
  DIS-ALL)

(install-command-and-advertise 'com-set-tvfont #\super-t *standard-comtab*)