;;; -*- Mode: Lisp; Package: User; Base: 10. -*-


;;;  This file contains code to allow external access to
;;; the editor buffers.

#|

The code in this file supports editor operations from the "outside
world."

Using functions provided here, you can read from, and write to, any
buffer known in ZMACS.  You can also create your own buffers.

To get a buffer, you provide its buffer name.  If you provide an unknown
buffer name, you will get a new buffer.  Use the function:
(GET-ZMACS-BUFFER <buffer-name>).  (All functions are in the USER package.)
If you supply a T argument, you will get the "current" buffer.

If you wish to make a buffer current, so that the next time you go into the 
editor that buffer is visible and selected, use the function:
(MAKE-BUFFER-CURRENT-BUFFER <buffer>)


You can set the contents of a buffer (destroying whatever is in there),
or append to the contents of a buffer using:
(EDITOR-SET-STRING <string> <buffer>)
(EDITOR-APPEND-STRING <string> <buffer>)

You can retrieve the contents of a buffer, returning a string:
(EDITOR-GET-STRING <buffer>)

Finally, and most interesting, you can get a STREAM tied
to a buffer, for input or output.
You can do consecutive PRINTs, FORMATS, TYOs, or whatever
to this stream.  Text is inserted starting at the beginning
of the buffer, but naturally, if you print "foo" and print
"bar" later, you will wind up with "foobar" in the buffer in
order, but still ahead of text that was in the buffer before
you got the stream.

You can READ, TYI, or whatever from the stream, but you will
only get stuff that was in the buffer when you opened the 
stream.  The stream CANNOT be reset.  If you want to read 
starting from the beginning, get a new stream.

To get a stream, use the function:
(BUFFER-STREAM <buffer>)

|#


;;;  Returns a buffer that you can play with, given a name.
;;; If supplied with T, will get the "current" buffer.  If supplied
;;; with a non-existent buffer, will create a buffer of that
;;; name.
(defun get-zmacs-buffer (&optional buffer-name)
  (cond
    ((eq buffer-name t)
     #+(or LMI TI) zwei:*interval*
     #+Symbolics (car zwei:*zmacs-buffer-history*))
    (t (zwei:find-buffer-named buffer-name t))))

;;; Added 11 November 1985 RMSoley for TI/LMI/Symbolics compatibility
;;; ***** IS THIS REALLY RIGHT?  WHAT IF WE'RE ALREADY IN THE EDITOR?
(eval-when (eval compile load)
(defmacro zmacs-editor-closure ()
  '(symeval-in-instance (zwei:find-or-create-idle-zmacs-window) 'zwei:editor-closure)))

;;;  zwei:*zmacs-command-loop* is an instance of zmacs-top-level-editor
(defun make-buffer-current-buffer (buffer &optional ada-mode-p)

  ;; If running under the tutor, clobber all top level editors.  That way
  ;; we talk only to the tutor editor.
;  (cond ((status feature tutor)
;	 (loop for window in (send (second tv:all-the-screens) ':inferiors)
;	       do (cond ((typep window 'zwei:zmacs-frame)
;			 (send window ':kill)
;			 (tv:screen-manage-window-area window))) )))

  (process-sleep 120. "Foo")

  ;; Do the real work.
  (send zwei:*zmacs-command-loop* ':eval-inside-yourself
	`(zwei:make-buffer-current ',buffer))

  ;; If user wants ada_mode, and it is loaded, do it.
  ;;(If ada_mode isn't loaded, this trashes the buffer.)
  (cond ((and ada-mode-p (status feature ada_mode))
	 (font-current-buffer)
	 #+(or LMI TI)
	 (funcall (zmacs-editor-closure) #'zwei:turn-on-mode 'ada-mode)
	 #+Symbolics
	 (send zwei:*zmacs-command-loop* ':eval-inside-yourself
	       '(zwei:set-major-mode 'ada-mode))))
  )
	 


;;;  Makes the currently selected buffer contain the specified
;;; string.  Any previous contents are lost.
(defun editor-set-string (string buffer)
  (let ((interval (zwei:create-interval
		    (send buffer ':first-bp) (send buffer ':last-bp) t)))
    (zwei:delete-interval interval)
    (zwei:insert (zwei:interval-last-bp interval) string)))


;;;  Append the given string to the current editor buffer.
(defun editor-append-string (string buffer)
  (let ((interval (zwei:create-interval
		    (send buffer ':first-bp) (send buffer ':last-bp) t)))
    (zwei:insert (zwei:interval-last-bp interval) string)))





;;;  Return the string in the current buffer.
(defun editor-get-string (buffer)
  (zwei:string-interval (send buffer ':first-bp) (send buffer ':last-bp)))


;;;  Returns a stream for reading from the buffer
(defun buffer-stream (buffer)
  (zwei:interval-stream (send buffer ':first-bp) (send buffer ':last-bp) t t))


;;; *zmacs-buffer-list*



;;;  Creates a fonted string given a string with CTRL-F characters in it.
;;;
(defun make-fat-string (string)
  (loop for i from 0 to (1- (string-length string))
	with font = 0
	with fat-string = (make-array 10 ':type 'art-fat-string
				      ':leader-list '(0))
	do (cond ((= (aref string i) 6.)	;If a ctrl-f
		  (setq font (- (aref string (1+ i)) #/0)
			i (1+ i)))
		 (t (array-push-extend fat-string (dpb font %%ch-font (aref string i)))))
	finally (return fat-string)))

(defun font-current-buffer (&optional (font-list '(fonts:cptfontb
							 fonts:hl12bi
							 fonts:cptfontb
							 fonts:tr18b)))
  (let ((tem (loop for font in font-list
		   collect (cons (get-pname font) (symeval font)))))
    #+Symbolics
    (send zwei:*zmacs-command-loop* ':eval-inside-yourself
	  `(progn (redefine-fonts *window* ',tem)
		  (redefine-fonts *window* ',tem)
		  (when (send *interval* ':operation-handled-p ':putprop)
		    (send *interval* ':putprop ',tem ':font-alist)
;		    (and (send *interval* ':operation-handled-p ':editing-file-p)
;			 (set-attribute-internal
;			   ':fonts "fonts"
;			   (and ',tem (format nil "~{~a~^,~}" (mapcar 'car ',tem)))
;			   (make-font-alist-attribute ',tem)))
		    )
		  (update-font-name)
		  ))
    #+(or LMI TI)
    (funcall (zmacs-editor-closure)
	     #'(lambda ()
		 (zwei:redefine-fonts zwei:*window* tem)
		 (zwei:redefine-fonts zwei:*window* tem)
		 (when (send zwei:*interval* ':operation-handled-p ':putprop)
		   (send zwei:*interval* ':putprop tem ':font-alist))
		 (zwei:update-font-name)))))

(defun font-other-buffer (buffer &optional (font-list '(fonts:cptfontb
							      fonts:hl12bi
							      fonts:cptfontb
							      fonts:tr18b)))
  (let ((tem (loop for font in font-list
		   collect (cons (get-pname font) (symeval font)))))
    (send buffer ':putprop tem ':font-alist)))



;;;(update-attribute-list-internal *interval*)



(defun make-editor-ada-mode ()
  #+(or LMI TI)
  (funcall (zmacs-editor-closure) #'zwei:com-ada-mode)
  #+Symbolics
  (send zwei:*zmacs-command-loop* ':eval-inside-yourself '(zwei:com-ada-mode)))