;;; -*- Mode:LISP; -*-

(herald RECORD)

;;; Create protocol file for user. Each time the user uses teach-lisp
;;; add a new record (or start the file, if it's the user's first time).
;;;
;;; Each record should start with a notice of the date and what version
;;; of teach-lisp was used to invoke this recording session.
;;; PROGRAM-RECORD includes certain things the program says to itself.

(declare (*expr alha-userid time:print-current-time)
	 (*lexpr sysread)
	 (special *default-script-filename*
		  *protocol-filename*))


(defvar *protocol-file* nil)
(defvar *script-file* nil)
(defvar *files-to-write-to* nil) ;ncons of same

;;; Base setup
(eval-when (eval compile load)
  (setq base 10. ibase 10.))

;;; IOTA snarfing
(eval-when (eval compile)
  (cond ((not (status feature iota))
	 (load '((liblsp) iota fasl)))))

;;; One time code to make sure this file exists for us. 

(defun set-up-prot-file ()
  (cond ((not (probef *protocol-filename*))
	 (iota ((stream *protocol-filename* '(out ascii dsk block)))
	   (format stream
		   "~%;;; -*- Mode:TEXT; -*-~
		      ~%;;;Stuff that the user said is preceded by `==>'~
		      ~%;;;Stuff that the program said is unadulterated.~2%"
		   ))))
  (setq *protocol-file* (open *protocol-filename* '(append ascii dsk block)))
  (setq *files-to-write-to* (ncons *protocol-file*))
  (format *protocol-file*
	  "~%;;;XTEACH.~A Record of user session for ~A~
	     ~%;;;Created ~A by ~A~2%"
	  (or (get 'teach 'version) 0)
	  (status userid)
	  (time:print-current-time nil)
	  (status uname)))

(defun program-record (&rest stuff)
  (if *script-file*
      (progn
       (format *script-file* "~&")
       (lexpr-funcall #'format *script-file* stuff)
       (format *script-file* "~&")
       (force-output *script-file*)))
  (if *protocol-file*
      (progn
       (format *protocol-file* "~&")
       (lexpr-funcall #'format *protocol-file* stuff)
       (format *protocol-file* "~&")
       (force-output *protocol-file*))))
      
(defun recorded-read (&rest stuff)
  (if *script-file* (format *script-file* "~&==> "))
  (if *protocol-file* (format *protocol-file* "~&==> "))
  (let ((echofiles *files-to-write-to*))
    (lexpr-funcall #'read stuff)))

(defun recorded-sysread (&rest stuff)
  (if *script-file* (format *script-file* "~&==> "))
  (if *protocol-file* (format *protocol-file* "~&==> "))
  (let ((echofiles *files-to-write-to*))
    (lexpr-funcall #'sysread stuff)))

(defun recorded-output (&rest stuff)
  (lexpr-funcall #'program-record stuff)
  (lexpr-funcall #'output stuff))

(defun recorded-print (thing)
  (program-record "~S" thing)
  (output "~&~S" thing))


;;; To be run if the user wants a script file of this session.
;;; Takes an optional argument of the file to script to.
;;; If user doesn't supply a file name, use the default script file.
;;; Cases:
;;;      1. file doesn't exist.
;;;      2. file exists and is script file.
;;;      3. file exists and is not script file.

(defun script (&optional filename)
  (let ((script-filename (if filename
			     (mergef filename `((* ,(status homedir))))
			   (mergef `((* ,(status homedir)))
				   *default-script-filename*))))
    (cond ((not (probef script-filename))
	   (setq script-filename
		 (iota ((stream script-filename 'out))
		   (truename stream)))
	   (recorded-output "~&Creating script file ~A for you.~%"
			    (namestring script-filename)))
	  ((or (script-file? script-filename)
	       (not (version-file script-filename)))
	   (setq script-filename
		 (iota ((stream script-filename 'in))
		   (truename stream)))
	   (recorded-output "~&Appending to file ~A for you.~%"
			    (namestring script-filename)))
	  (t
	   (recorded-output "~&~A is not a script file, so I'm creating a new ~
			  ~%version of that file for you.~%"
			    (namestring script-filename))
	   (setq script-filename
		 (iota ((stream script-filename 'out))
		   (truename stream)))))
    (setq *script-file* (open script-filename '(append ascii dsk block)))
    (setq *files-to-write-to* (cons *script-file* *files-to-write-to*))
    (format *script-file* "~&(COMMENT TEACH-LISP SCRIPT FILE FOR ~A ON ~A)~2%"
	    (status userid)
	    (time:print-current-time nil))))

(defun version-file (name)
  (let ((name (namelist name)))
    (or (eq (caddr name) '>)
	(let* ((true-name (truename (iota ((stream name 'in)) stream)))
	       (second (caddr true-name)))
	  (do ((chars (exploden second) (cdr chars)))
	      ((null chars) t)
	    (if (or (< (car chars) #/0) (> (car chars) #/9)) (return nil)))))))

(defun script-file? (filename)
  (iota ((stream filename 'in))
    (let* ((cons-of-read (errset (sysread stream) nil))
	   (x (if cons-of-read (car cons-of-read) nil)))
      (and (not (atom x))
	   (eq (pop x) 'COMMENT)
	   (not (atom x))
	   (eq (pop x) 'TEACH-LISP)
	   (not (atom x))
	   (eq (pop x) 'SCRIPT)))))

(defun stop-script ()
  (setq *files-to-write-to* (delq *script-file* *files-to-write-to*))
  (close *script-file*)  
  (setq *script-file* nil)
  (recorded-output "~&Closing script file.~%"))