;-*- Mode:LISP; Package:STEVE; Readtable:CL; Base:10 -*-

;Copyright (c) May 1983 by Christopher Eliot
; and Massachusetts Institute of Technology.
;Permission to copy all or part of this material is granted, provided
; that the copies are not made or distributed for resale, the MIT
; copyright notice and reference to the source file and the software
; distribution version appear, and that notice is given that copying
; is by permission of Massachusetts Institute of Technology.

;
;This file contains random functions used by the editor, which
;do not depend heavily on other functions in the editor. Some of
;them may depend upon its data formats however. This is certainly not
;a guarantee that anything here will work in another context.
;
;*****************************************************************************
;Compilation note.
;Before installation every file in the editor should be compiled in
;an environment where the whole editor is loaded. This ensures that DEFSUBSTs
;are expanded, and that macros work correctly.
;******************************************************************************
;

(defvar *query-line*)
(defvar *notify-line*)
(defvar *more-line*)
(defvar *feedback-line*)
(defvar *double-line*)
(defvar *error-line*)
(defvar *prefix-echo-line*)

;Now 135 spaces long for bigger TTYs.
(defconstant 80spaces "                                                                                                                                       ")
(defconstant 80dashes "---------------------------------------------------------------------------------------------------------------------------------------")

					
;
;Ascii dependant cruft which helps fix the read stream.
;

(eval-when (compile load)

(defconstant *first-non-control-character-code* (char-int #\space))
(defconstant *first-meta-character-code* 128)
(defconstant *tab-distance* 8)

);eval-when

(defconstant n-spaces
  #.(loop with vector = (make-vector 9)	   ;Initial value inconsequential
	  for i from 0 to 8
	  do (setf (svref vector i) (make-string i :initial-element #\sp))
	  finally (return vector)))

(defconstant control-character-translation-table
  #.(loop with vect = (make-vector (char-int #\space))
	              ;Initial value inconsequential
	  for i from 0 below (char-int #\space)
	  for char = (int-char i)
	  if (memq char '(#\bell #\backspace #\tab #\line
				 #\page #\return #\altmode))
	  do (setf (aref vect i) char)
	  else do (setf (aref vect i)   
			(code-char (logior& (char-code char) #o100)
				   char-control-bit))
	  finally (return vect)))


(defconstant character-translation-table
 #.(loop with vect = (make-vector 256)	   ;Initial value inconsequential
	 for i from 0 to 255
	 for chr = (int-char i)
	 do (cond ((memq chr  '(#\bell #\backspace #\tab #\line
				 #\page #\return #\altmode))
		   (setf (aref vect i) chr))
		  ((>=& i 128)
		   (setf (aref vect i) (code-char (logandc2& i #o0200)
						  char-meta-bit)))
		  (t (setf (aref vect i) chr)))
	 do (cond ((memq (make-char (setq chr (aref vect i)))
			 '(#\bell #\backspace #\tab #\line
				 #\page #\return #\altmode)))
		  ((<& (char-code chr) (char-int #\space))
		   (setf (aref vect i) 
			 (code-char (logior& (char-code chr) #o100)
				    (logior& (char-bits chr)
					     char-control-bit)))))
	 finally (return vect)))

;This is very much dependant upon the ASCII character set.
(defsubst canonicalize-control-characters (char)
  (svref character-translation-table (char-int char)))

(defun coerse-to-string-charp (char)
  (cond ((string-charp char) char)
	((not (=& 0 (char-font char))) nil)
	((not (=& 0 (logandc2 (char-bits char) #.(logior& char-control-bit
							char-meta-bit))))
	 nil)
	(t (let ((code (char-code char)))
	     (when (not (=& 0 (logand& (char-bits char) char-control-bit)))
	       (setq code (logandc2& code #o100)))
	     (when (not (=& 0 (logand& (char-bits char) char-meta-bit)))
	       (setq code (logior& code #o200)))
	     (int-char code)))))

(defparameter preknown-character-printed-representations
  #.(loop with v = (make-vector char-code-limit :initial-element nil)
	  for i from 0 below char-code-limit
	  as c = (code-char i)
	  do (unless (graphic-char-p c)
	       (setf (svref v i)
		     (format nil (if (and (<& i 32) (not (char-name c)))
				     "~:C"
				     "~@C")
			     c)))
	  finally (return v)))



(defsubst stringify-tab (col)
  (let ((col1 col))
    (svref n-spaces (-& (logandc1& 7 (+& col1 8)) col1))))


(defsubst stringify-non-tab (chr)
  (svref preknown-character-printed-representations (char-code chr)))

(defsubst stringify-char (chr col)
  ;Normally a graphic-charp character will not be an argument.
  (let ((chrctr chr)
	(col1 col))
    (if (eq chrctr #\tab)
	(svref n-spaces
		;This depends upon tabs being 8 columns apart.
		(-& (logandc1& 7 (+& col1 8)) col1))
	(svref preknown-character-printed-representations
		(char-code chrctr)))))

;
;Edit-cursors bind a buffer, a cursor and a window together.
;

(defflavor edit-cursor (buffer line position window home-line home-pos) (bp)
  :ordered-instance-variables
  :initable-instance-variables
  ;;:gettable-instance-variables
  :outside-accessible-instance-variables)

(defmethod (edit-cursor :print-self) (&optional (stream standard-output)
				      ignore ignore)
  (format stream "#<~s ~a " 'edit-cursor (buffer-name buffer))
  (print-bp-internal line position stream)
  (write-char #\> stream))

(defun create-edit-cursor (buffer &optional (line (buffer-content buffer))
				  	    (pos 0)
					    (window nil))
  (let ((new-bp (make-instance 'edit-cursor
			       :line line
			       :position pos
			       :buffer buffer
			       :window window
			       :home-line line
			       :home-pos 0)))
    (send line :add-bp new-bp)
    (push new-bp *all-edit-cursors*)
    new-bp))

;This is how to make a new buffer. If the name is not unique, the
;existing buffer may be used however.
(defun make-buffer (name)
  (let ((buffer (buffer name :create nil)))
    (when (not (null buffer))
      (with-double-second-line
       (with-double-line
	(format *terminal-io* "A buffer named ~a (file ~a) already exists."
		name (send (buffer-file-name buffer) :string-for-editor))
	(format *terminal-io*
		"~&Type buffer name to use, or CR to reuse ~a (or <DEL> to select it): "
		name)
	(let ((new-name (prescan #'read-buffer-name nil)))
	  (cond ((null new-name)
		 )
		((string= new-name "")
		 (when (buffer-modified? buffer)
		   (when (with-query-line
			  (oustr "Save changes to buffer? " *terminal-io*)
			  (ed-y-or-n-p "Save changes to ~a "
				       (buffer-name buffer)))
		     (save-file buffer)))
		 (%kill-buffer-primitive buffer)
		 (setq buffer nil))
		(t (setq name new-name)
		   (setq buffer (buffer name :create t))))))))
    (when (null buffer)
      ;; This delays calculation of the environment until
      ;; it is actually needed.
      (setf buffer (make-instance 'buffer
				  :name name
				  :access buffer-access-any
				  :environment nil
				  :mark-ring (make-vector mark-ring-size
							  :initial-element nil)
				  :mark-ring-index 0
				  :narrow-info nil))
      (setf (buffer-content buffer) (make-line buffer nil nil))
      (setf (buffer-modified? buffer) nil)
      (push buffer *all-buffers*)
      (send buffer :set-file-name (editor-default name))
      (when *buffer-creation-hook*
	(funcall *buffer-creation-hook* buffer)))
    buffer))

(defun make-point (name &optional (window nil))
  (let ((buff (make-buffer name)))
    (create-edit-cursor buff (buffer-content buff) 0 window)))

(defun select-point (point &aux (buffer (edit-cursor-buffer point)))
  (unless (eq *editor-buffer* buffer)
    (setq *last-buffer-selected* *editor-buffer*))
  (unless (eq *editor-cursor* point)
    (setq *editor-cursor* point
	  *.* point
	  *editor-buffer* buffer
	  *b* *editor-buffer*
	  *context-change-flag* t))
  (when (null (edit-cursor-window point))
    (with-no-passall
     (oustr "Selected point has no associated window." echo-area-window)
     (oustr "I will try to fix it" echo-area-window)
     (one-window))))

(defun select-point-in-current-window (point)
  (unless (eq point *editor-cursor*)
    (setf (edit-cursor-window point) (edit-cursor-window *editor-cursor*)
	  (edit-cursor-window *editor-cursor*) nil)
    (select-point point)))



;
;Character syntax for STEVE.
;
;What we need is a way to set/read the syntax for any STRING-CHAR
;For now we will assume there are at most 8 bits of information
;about any character.
;This will be stored in a 256 byte table.
;

(defvar syntax-bit-map nil)

(defvar *all-modes* nil)

;Type must be an symbol.
;When using the syntax base option, the base must be declared before it
;is used.
(defmacro declare-syntax-type (type &optional (base nil))
  `(progn (defvar ,type ,(if (null base)
			     '(make-empty-syntax-table)
			     `(copy-syntax-table ,base)))
	  (defprop ,type t syntax-type)
	  (or (memq ,type *all-modes*)
	      (push ,type *all-modes*))))

(defun make-empty-syntax-table ()
  (make-bit-vector (* 256 8)))

(defun copy-syntax-table (table)
  ;(bits-replace (make-empty-syntax-table) table 0 0 (* 256 8))
  (copy-seq table))

(defvar next-unused-syntax-bit 0)
(defvar max-syntax-bit 7)

(defmacro declare-syntax-bit (name)
  ;;This allocates a bit automatically, and sets the name to reference it.
  (let ((mask (intern (string-append name "-MASK"))))
    `(progn
       (defvar ,name)
       (defvar ,mask)
       (when (null (get ',name 'syntax-bit))
	 (when (>& next-unused-syntax-bit max-syntax-bit)
	   (ed-lose "Too Many Syntax Bits Allocated"))
	 (putprop ',name next-unused-syntax-bit 'syntax-bit)
	 (setq next-unused-syntax-bit (1+& next-unused-syntax-bit))
	 (setq ,name (get ',name 'syntax-bit))
	 (setq ,mask (^& 2 ,name))
	 (push (list ,name ',name (^& 2 ,name)) syntax-bit-map)))))

(defun syntax-description (table char
			   &aux (byte (get-char-syntax table char)))
 (loop for (bit-number name) in syntax-bit-map
       if (logbitp& bit-number byte)
       collect name))

;This can be expanded by SETF.
(defmacro get-char-syntax (table char)
 `(get-a-byte ,table (char-code ,char)))

;This can be expanded by SETF.
(defmacro get-char-syntax-bit (table char bit)
  ;`(bit ,table (+& (*& 8 (char-code ,char)) ,bit))
  ;So can this.  And this is fairly good access, since the arguments to
  ; load-byte are constant (maybe).
  `(load-byte (get-a-byte ,table (char-code ,char)) ,bit 1))

(defmacro of-syntax (char bit)
  ;`(=& 1 (get-char-syntax-bit syntax-table ,char ,bit))
  `(logtest& (get-char-syntax syntax-table ,char) (ash& 1 ,bit)))

;
;Syntax table generation.
;
;Paren matching.
;Paren matching is more wired in than in emacs.
;We assume that:
;	Open paren For	Close paren
;	(		)
;	[		]
;	{		}
;	<		>
;And all others will either be illegal as parens, or match themselves.
;Any complaints?
;

(defvar paren-matches
	'((#\) . #\()
	  (#\] . #\[)
	  (#\} . #\{)
	  (#\> . #\<)
	  (#\' . #\`)

	  (#\( . #\))
	  (#\[ . #\])
	  (#\{ . #\})
	  (#\< . #\>)
	  (#\` . #\')))

(defmacro get-paren-match (paren)
  `(cdr (assq ,paren paren-matches)))

;Syntax bit declarations.

(declare-syntax-bit word-alphanumeric)
(declare-syntax-bit lisp-alphanumeric)
(declare-syntax-bit white-space)
(declare-syntax-bit paren-open)
(declare-syntax-bit paren-close)
(declare-syntax-bit string-quote)
(declare-syntax-bit character-quote)
(declare-syntax-bit prefix)

(defparameter lisp-word-chars ".")

(defparameter text-word-chars "'")

(defparameter lisp-atom-chars "!#&*+/<=>?@^`-_:\\[]")

(defparameter extra-alphanumerics "$%")

(defparameter white-space-chars #.(to-string '(#\space #\tab #\return)))

(defparameter prefix-chars "':`,#;\\")

(defun set-to-syntax (table string syntax)
  (loop for i from 0 below (string-length string)
	do (setf (get-char-syntax-bit table (char string i) syntax) 1)))

(defun set-default-syntax (table)
  (loop for i from 0 below 256
	for chr = (int-char i)
	if (alphanumericp chr)
	do (setf (get-char-syntax-bit table chr word-alphanumeric) 1
		 (get-char-syntax-bit table chr lisp-alphanumeric) 1))

  (set-to-syntax table extra-alphanumerics word-alphanumeric)
  (set-to-syntax table extra-alphanumerics lisp-alphanumeric)

  (set-to-syntax table lisp-word-chars lisp-alphanumeric)
  (set-to-syntax table lisp-atom-chars lisp-alphanumeric)

  (set-to-syntax table white-space-chars white-space)

  (set-to-syntax table prefix-chars prefix)

  (setf (get-char-syntax-bit table #\( paren-open) 1)
  (setf (get-char-syntax-bit table #\) paren-close) 1)
  (setf (get-char-syntax-bit table #\" string-quote) 1)
  (setf (get-char-syntax-bit table #\| string-quote) 1)
  (setf (get-char-syntax-bit table #\\ character-quote) 1))

;
;
;Syntax types.
;

(declare-syntax-type *fundamental-syntax*)
(set-default-syntax *fundamental-syntax*)

(declare-syntax-type *text-syntax*)
(set-default-syntax *text-syntax*)
(set-to-syntax *text-syntax* text-word-chars word-alphanumeric)

(declare-syntax-type *lisp-syntax*)
(set-default-syntax *lisp-syntax*)
(set-to-syntax *lisp-syntax* lisp-word-chars word-alphanumeric)

;;;The current value of SYNTAX-TABLE is the current syntax.
(defvar syntax-table *lisp-syntax*)



;
;Syntax table usage.
;

(defsubst atom-char? (chr)
  ;(=& 1 (get-char-syntax-bit syntax-table chr lisp-alphanumeric))
  (logtest& (get-char-syntax syntax-table chr) lisp-alphanumeric-mask))

(defsubst word-char? (chr)
  ;(=& 1 (get-char-syntax-bit syntax-table chr word-alphanumeric))
  (logtest& (get-char-syntax syntax-table chr) word-alphanumeric-mask))

(defsubst white-space? (chr)
  ;(=& 1 (get-char-syntax-bit syntax-table chr white-space))
  (logtest& (get-char-syntax syntax-table chr) white-space-mask))

(defsubst character-quote? (chr)
  (logtest& (get-char-syntax syntax-table chr) character-quote-mask))

(defsubst horizontal-white-space? (chr)
  (and (white-space? chr) (not (char= chr #\newline))))


(defsubst paren-open? (chr)
  (logtest& (get-char-syntax syntax-table chr) paren-open-mask))

(defsubst paren-close? (chr)
  (logtest& (get-char-syntax syntax-table chr) paren-close-mask))

(defsubst string-quote? (chr)
  (logtest& (get-char-syntax syntax-table chr) string-quote-mask))


;
;Macros to do some fancy line control stuff.
;

(defmacro with-line (line &body forms)
 `(unwind-protect
   (progn (cursorpos ,line 0) (send *terminal-io* :clear-eol) ,@forms)
   (cursorpos ,line 0)
   (send *terminal-io* :clear-eol)))

(defmacro with-line-remaining (line &body forms)
 `(progn (cursorpos ,line 0) (send *terminal-io* :clear-eol) ,@forms))

(defmacro declare-line (name line &aux (arg (gensym)))
 `(progn (defmacro ,(intern (string-append "WITH-" name "-LINE")) (&body ,arg)
	  (list* 'with-line ',line ,arg))
         (defmacro ,(intern (string-append "WITH-" name "-LINE-REMAINING"))
		     (&body ,arg)
	   (list* 'with-line-remaining ',line ,arg))))

(declare-line query *query-line*)
(declare-line notify *notify-line*)
(declare-line more *more-line*)
(declare-line feedback *feedback-line*)
(declare-line double *double-line*)
(declare-line double-second (1+& *double-line*))
(declare-line error *error-line*)
(declare-line prefix-echo *prefix-echo-line*)

;
;Functions to do overwritten displays.
;This has to be retro-fitted to the editor.
;

(defvar *overwrite-line* 0)

(defun overwrite-open-line (line)
 (cursorpos line 0 *terminal-io*)
  (send *terminal-io* :clear-eol)
 (setq creamed-tty-lines-to
       (max& (1+& line) creamed-tty-lines-to))
 (setq *overwrite-line* line)
 t)

(defun overwrite-home ()
 (overwrite-open-line 0))

(defun overwrite-start ()
 (overwrite-open-line *overwrite-line*))

(defun overwrite-done ()
 (setq *overwrite-line* (1+& *overwrite-line*)))

(defun overwrite-terpri ()
  (setq *overwrite-line* (1+& *overwrite-line*))
  (when (>& *overwrite-line* *last-overwrite-line*)
    (setq *overwrite-line* 0)
    (with-more-line
      (setq creamed-tty-lines-to (max& (send *terminal-io* :linenum)
				       creamed-tty-lines-to))
      (oustr "*more*" *terminal-io*)
      (cond ((char= (peek-char&save) #\space)
	     (read-char&save))
	    (t (when (char= (peek-char&save) #\rubout)
		 (read-char&save))
	       (ed-abort)))))
  (overwrite-open-line *overwrite-line*))


(defun editor-notify (string)
 (with-notify-line-remaining
  (princ string *terminal-io*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The "missing" functions "below" were move to AUX2
