PDP-10.its/src/teach/teach.159

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

(herald TEACH)

(load (get (car (status macro #/`)) 'autoload)) ;get BACKQ support LOADED

;;; File hacking if on TOPS-20
(eval-when (eval compile load)
  (cond ((status feature TOPS-20)
	 (putprop 'teach  '(ps kmp/.teach) 'ppn))))

;;; Macro support
(eval-when (eval compile)
  (load '((teach) macro)))

;;; Declarations
(declare (*lexpr fresh-line		
		 program-record
		 query
		 recorded-output
		 recorded-read
		 sysread)
	 (*expr clear-screen
		load-props
		novicep
		recorded-print
		set-up-prot-file
		bug)
	 (special *protocol-filename*
		  *ITS-list-of-list-of-lessons-filenames*
		  *TOPS-20-list-of-lessons-filename*))

(defvar *novice-flag* nil)  ;currently unused, but may come in handy.

;;; 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)))))

;;; Time package
(cond ((not (get 'time 'version))
       (load '((liblsp) time))))

;;; Pretty grinding stuff for format (from ...)

(cond ((not (get 'gprint 'version))
       (load '((liblsp) gprint))))

(setq prinendline nil)

(cond ((not (get 'n 'format-ctl-one-arg))
       (defun (n format-ctl-one-arg) (obj args)
	 (apply (cond (colon-flag 'Gprintc) (t 'gprint1))
		(list* obj standard-output nil args)))))


;;; GC-OVERFLOW set in user system to this function.

(defun gc-overflow-handler (nil) t)

(load-module APROPOS)
(load-module DATABASE)
(load-module ERRHEL)
(load-module ERRHAN)
(load-module EXLIST) 
(load-module COMPLAIN (EVAL LOAD COMPILE))
(load-module IO)
(load-module LESSN)
(load-module MORE)
(load-module RECORD)
(load-module TREEPR)

;; if the user has nver used this program before, find out if
;; he's ever used Maclisp. if not, consider him a novice and pamper him.
;; at present, this isn't used for anything and is turned off (it should
;; be invoked from toplevel in the function teach-lisp-top-level), but we
;; may want to take advantage of it later.

(defun novicep ()
  (if *novice-flag*
      (if (not (query "Is this your first time using Maclisp?"))
	  (setq *novice-flag* nil))))

;;; Top-level function
(defvar *second-time-around* nil)
(defvar *** '***)
(defvar ** '**)
(defvar +++ '+++)
(defvar ++ '++)
(defvar *display-terminal* nil)
(defvar *terminal-horizontal-size* nil)
(defvar *terminal-vertical-size* nil)
(defvar *lessons-known* nil)

(defun find-terminal-characteristics ()
  (setq *display-terminal*
 	(if (memq 'cursorpos (status filem tyo)) t))
  (let ((tsize (status ttysize)))
    (setq *terminal-vertical-size* (cdr tsize))
    (cond (*display-terminal* (setq *terminal-horizontal-size*
				    (min (car tsize) 24.)))
	  (t  (setq *terminal-horizontal-size* 100)))))

(defun welcome-message ()
  (output
   "~2&Welcome to the wonderful world of TEACH-LISP. Just type forms at me and
I'll pretend I'm a real Maclisp and deal with them, except I'm nicer and
occasionally I can offer some assistance when Maclisp would just snarl at you.

To get a list of the lessons I have available along with a short description
of each, type
   (LESSON)
To start a particular lesson, type
   (LESSON <name>)
If you need further instructions, or if this is your first time using this
program, type
   (LESSON INFO)

To leave this program, type
   (QUIT)~2%"))

(defun help ()
  (recorded-output "Sorry, these feature has not yet been implemented.~%"))

(defun teach-lisp-top-level ()
  (cond
   (*second-time-around* (fresh-line))
   (t (clear-screen)
      (output "~&Hold on a sec while I set everything up for you...~%")
      (find-terminal-characteristics)
      (init-user)
      (set-up-prot-file)
      (load-props)
;; turned off for now
;      (novicep)
      (output "~&There we are. Now then...~%")
      (welcome-message)
      (setq *second-time-around* t)))
  (breakloop nil))

(defvar *recursive?* nil)

(defun breakloop (*recursive?*)
  (do ((*** ***)
       (**  **)
       (*   *)
       (+++ +++ ++)
       (++  ++  +)
       (+   +   -)
       (-))
      (nil)
    (dont-catch-**more**
     (fresh-line)
     (setq - (recorded-read))
     (cond (*recursive?*
	    (cond ((eq - P) (return nil))
		  ((and (not (atom -))
			(eq (car -) 'RETURN)
			(not (atom (cdr -)))
			(null (cddr -)))
		   (return (catch-complaints (eval (cadr -))))))))
     (catch-complaints
      (setq * (prog1 (eval -)
		     (setq *** **)
		     (setq **  * )))
      (catch-**more**
       (recorded-print *)
       (fresh-line))))))

(defun dump (&optional (filename '#.(mergef '(ts xlisp) (truename infile))))
  (with-saved-obarray
    (load-module init))
  (sstatus flush t)
  (gc)
  (cond ((status feature tops-20) (suspend))
	(t (suspend ":KILL " filename)))
  (teach-lisp-top-level))

(defvar *database-new-filename* nil)
(defvar *database-old-filename* nil)
(defvar *database-temp-file* nil)
(defvar *database-temp-filename* nil)

;;; Functions used to change TOPS-20 userid's to get rid of all
;;; non-alphanumerics.

(defun alpha-numeric? (char)
  (or (and (not (< char #/0))
	   (not (> char #/9)))
      (and (not (< char #/A))
	   (not (> char #/Z)))
      (and (not (< char #/a))
	   (not (> char #/z)))))

(defun alpha-userid (name)
  (implode (mapcan #'(lambda (c) (if (alpha-numeric? c) (ncons c)))
		   (exploden name))))

(defun init-user ()
  (let ((user (cond ((status feature its) (status userid))
		    (t (alpha-userid (status userid)))))
	(home-dir (status hsname)))
    (setq *database-old-filename* `((,home-dir) ,user tdb))
    (setq *database-new-filename*
	  (caseq (status filesys)
	    ((ITS)   `((,home-dir) ,user tdb))
	    ((DEC20) `((,home-dir) ,user tdb -1))
	    (t (bug "Unknown file system"))))
    (setq *database-temp-filename*
	  (mergef `(_TEACH ,user) *database-new-filename*))
    (setq *protocol-filename* `((,home-dir) ,user tprot))))


;;; Local Modes:;
;;; Mode:LISP;
;;; Comment Column:50;
;;; End:;