mirror of
https://github.com/PDP-10/its.git
synced 2026-03-25 01:47:08 +00:00
516 lines
16 KiB
Common Lisp
Executable File
516 lines
16 KiB
Common Lisp
Executable File
;;; -*- Mode:LISP; -*-
|
||
(herald LESSN)
|
||
|
||
;;;; Declarations
|
||
(declare (special *default-lesson-filename*
|
||
*in-more-break*
|
||
*ITS-list-of-list-of-lessons-filenames*
|
||
*lessons-known*
|
||
*TOPS-20-list-of-lessons-filename*)
|
||
(*expr clear-screen
|
||
lesson-has-been-seen
|
||
seen-lesson?
|
||
set-prop
|
||
user-record)
|
||
(*lexpr active-menu
|
||
complain
|
||
fresh-line
|
||
output
|
||
program-record
|
||
prop
|
||
quiet-bug
|
||
recorded-output
|
||
sysread
|
||
query))
|
||
|
||
;;; File hacking if on TOPS-20
|
||
(eval-when (eval compile load)
|
||
(cond ((status feature TOPS-20)
|
||
(putprop 'teach '(ps kmp/.teach) 'ppn))))
|
||
|
||
;;; IOTA snarfing
|
||
(eval-when (eval compile)
|
||
(cond ((not (status feature iota))
|
||
(load '((liblsp) iota fasl)))))
|
||
|
||
;;; Base setup
|
||
(eval-when (eval compile load)
|
||
(setq base 10. ibase 10.))
|
||
|
||
;;; Macro support
|
||
(eval-when (eval compile)
|
||
(load '((teach) macro)))
|
||
|
||
;;; Variable declarations
|
||
|
||
(defvar *disallow-interrupts* nil)
|
||
(defvar *lesson-file* nil)
|
||
(defvar *lesson-name* nil)
|
||
(defvar *lesson-exit-handler* nil "Don't handle lesson exits at toplevel")
|
||
; *lesson-information* is a list of the form:
|
||
; (<stream> (eval name position) ...
|
||
; (eval-print name position)
|
||
; (try name position) ... etc ...)
|
||
; associated with the current lesson file.
|
||
(defvar *lesson-information* nil)
|
||
|
||
(define-interrupt-handler abort-lesson-handler
|
||
(abort-lesson))
|
||
(define-interrupt-handler read-lesson-section-handler
|
||
(read-lesson-section))
|
||
(define-interrupt-handler read-previous-lesson-section-handler
|
||
(read-previous-lesson-section))
|
||
(define-interrupt-handler repeat-lesson-section-handler
|
||
(repeat-lesson-section))
|
||
|
||
;;; Macro support, etc.
|
||
|
||
(defmacro catch-lesson-exit (&body body)
|
||
`(*catch 'lesson-exit-handler
|
||
(let ((*lesson-exit-handler* t))
|
||
,@body)))
|
||
|
||
(defun exit-lesson () (*throw 'lesson-exit-handler nil))
|
||
|
||
(defmacro lesson-function (name) `(get ,name 'lesson-function))
|
||
|
||
(defmacro define-lesson-function (type doc &body body)
|
||
doc ;ignored
|
||
`(defun (,type lesson-function) nil
|
||
,@body))
|
||
|
||
(defun add-lesson-information (type)
|
||
(let ((name (read-optional-label *lesson-file*))
|
||
(information-location (filepos *lesson-file*)))
|
||
(push (list type name information-location)
|
||
(cdr *lesson-information*))))
|
||
|
||
;;; Functions for retrieving the various types of information
|
||
;;; stored in *lesson-information*.
|
||
|
||
(defun get-lesson-information (types list)
|
||
(ass #'(lambda (x y) (memq y x)) types list))
|
||
|
||
(defun ass (fn obj list)
|
||
(do ((l list (cdr l)))
|
||
((null l) nil)
|
||
(if (funcall fn obj (caar l))
|
||
(return (car l)))))
|
||
|
||
(defun get-optional-label (types list)
|
||
(cadr (get-lesson-information types list)))
|
||
|
||
;;; Functions for getting names and positions from a piece of information.
|
||
(defun get-name (obj) (cadr obj))
|
||
(defun get-position (obj) (caddr obj))
|
||
|
||
(defun read-optional-label (stream)
|
||
(prog1 (do ((c (tyipeek nil stream) (tyipeek nil stream)))
|
||
((= c #\return) nil)
|
||
(if (not (member c '(#\space #\tab)))
|
||
(return (read stream)))
|
||
(tyi stream))
|
||
(do ((c (tyipeek nil stream) (tyipeek nil stream)))
|
||
((= c #\return) (tyi stream))
|
||
(tyi stream))))
|
||
|
||
;;;; Other stuff
|
||
|
||
(declare (*lexpr *lesson open-lesson))
|
||
|
||
;;; Find out what lessons we've available for this incarnation
|
||
;;; of XTEACH.
|
||
|
||
(defun get-list-of-lessons ()
|
||
(cond ((status feature ITS)
|
||
(mapallfiles '(lambda (x) (push (caddr x) *lessons-known*))
|
||
*ITS-list-of-list-of-lessons-filenames*))
|
||
(t(setq *lessons-known*
|
||
(cond ((probef *TOPS-20-list-of-lessons-filename*)
|
||
(iota ((stream *TOPS-20-list-of-lessons-filename*
|
||
'(in ascii dsk)))
|
||
(sysread stream)))
|
||
(t nil)))))
|
||
(setq *lessons-known* (sort *lessons-known* 'alphalessp)))
|
||
|
||
;;; Function for providing a full file name in the place of the single
|
||
;;; word names for lessons.
|
||
|
||
(defun full-lesson-name (name)
|
||
(mergef (mergef `(* ,name) *default-lesson-filename*)
|
||
defaultf))
|
||
|
||
;;; Function to find a particular special function request in an open file.
|
||
|
||
(defun find-special-function-in-file (function file)
|
||
(cautiously-incrementing-filepos file
|
||
(do ((c (tyipeek nil file -1)
|
||
(tyipeek nil file -1)))
|
||
((= c -1) nil)
|
||
(caseq c
|
||
((#\linefeed) (tyi file))
|
||
((#/.) (tyi file)
|
||
(let ((special (sysread file)))
|
||
(if (eq special function)
|
||
(let ((special-func (lesson-function special)))
|
||
(if special-func
|
||
(return (filepos file))
|
||
(quiet-bug
|
||
"unknown lesson command requested in ~
|
||
find-special-function-in-file: ~S~%"
|
||
function)
|
||
(return nil)))
|
||
(readline file))))
|
||
(t (let ((line (readline file)))
|
||
(if (null line) (return nil))))))))
|
||
|
||
;;; Get the description of each lesson that is to be printed from the
|
||
;;; lesson file. this one time code is run by TEACH-LISP-TOP-LEVEL.
|
||
|
||
(defun set-up-lesson-descriptions ()
|
||
(do ((lessons *lessons-known* (cdr lessons)))
|
||
((null lessons))
|
||
(let* ((name (car lessons))
|
||
(full-name (full-lesson-name name)))
|
||
(if (probef full-name)
|
||
(iota ((stream full-name '(in ascii dsk)))
|
||
(if (find-special-function-in-file 'document stream)
|
||
(putprop name (readline stream) 'lesson-description)
|
||
(putprop name name 'lesson-description)))
|
||
(putprop name
|
||
"Oops... thought i had a lesson here.
|
||
Please report this by sending mail to BUG-XTEACH."
|
||
'lesson-description)))))
|
||
|
||
(defun describe-lesson (name)
|
||
(get name 'lesson-description))
|
||
|
||
(defun in-lesson? ()
|
||
(if (not *lesson-file*)
|
||
(complain "~&You're not in the middle of a lesson.")))
|
||
|
||
(defmacro lesson (&optional (name nil name?))
|
||
(cond (name? `(*lesson ',name))
|
||
(t (*lesson))))
|
||
|
||
(defun *lesson (&optional (name nil name?))
|
||
(let ((*disallow-interrupts* t))
|
||
(cond ((and *lesson-file*
|
||
name?
|
||
(query "You're already in lesson ~A.~
|
||
~%Shall I start the new one for you anyway?"
|
||
*lesson-name*))
|
||
(kill-lesson)
|
||
(*lesson name))
|
||
(*lesson-file*
|
||
(cond ((query "Want to go on with lesson ~A now?"
|
||
*lesson-name*)
|
||
(catch-complaints
|
||
(fresh-line 1)
|
||
(read-lesson-section)))
|
||
((query "Want a menu of available lessons?")
|
||
(catch-complaints
|
||
(when-abnormal-exit (open-lesson)
|
||
(output
|
||
"~&Ok, lesson ~A's still around waiting for you.~%"
|
||
*lesson-name*))
|
||
(fresh-line 1)
|
||
(read-lesson-section)))
|
||
(t
|
||
(output "~&Ok, lesson ~A's still around waiting for you.~%"
|
||
*lesson-name*)))
|
||
'*)
|
||
(t
|
||
(catch-complaints
|
||
(cond (name? (open-lesson name))
|
||
(t (open-lesson)))
|
||
(fresh-line 1)
|
||
(read-lesson-section))
|
||
'*))))
|
||
|
||
(defun start-lesson (name)
|
||
(let ((full-name (full-lesson-name name)))
|
||
(if (not (probef full-name))
|
||
(complain "~2&I'm sorry, I can find no lesson by the name ~A."
|
||
name))
|
||
(clear-screen)
|
||
(if *lesson-file* (kill-lesson)) ;clean up if needed
|
||
(setq *lesson-file* (open full-name 'in)
|
||
*lesson-information* (list *lesson-file*)
|
||
*lesson-name* name)
|
||
(program-record "Starting lesson ~A." name)))
|
||
|
||
(defun open-lesson (&optional (name *lesson-name* name?))
|
||
(cond ((not name?)
|
||
(let ((wanted-lesson (active-menu *lessons-known*
|
||
#'describe-lesson
|
||
#'start-lesson
|
||
"Menu of available lessons")))
|
||
(if (not wanted-lesson) (complain))))
|
||
((not name)
|
||
(complain "~&NIL is not a valid lesson! If you want a menu of ~
|
||
lessons, type /"(LESSON)/"~%"))
|
||
(t
|
||
(start-lesson name))))
|
||
|
||
|
||
;;; Functions for doing stuff in a lesson file (moving around and reading and
|
||
;;; killing...)
|
||
|
||
;;; Go back to the previous tag marked in *file-information* if there
|
||
;;; is one; signal error, otherwise.
|
||
;;; Moving backwards entails moving the file position and changing
|
||
;;; the state of file-information* to be as though things after
|
||
;;; the tag had not been read.
|
||
|
||
|
||
;;; first hit is the one that caused us to be in a position
|
||
;;; to be paid attention to.
|
||
;;; second is the lesson we just stopped.
|
||
;;; third is lesson before lesson just done.
|
||
|
||
(defun trimmed-lesson-information (list)
|
||
(let ((inf (get-lesson-information '(tag try) list)))
|
||
(cdr (memq inf list))))
|
||
|
||
(defun repeat-lesson-section ()
|
||
;; trim off the try that got us here
|
||
;; and then looke for the next try or tag.
|
||
(in-lesson?)
|
||
(let ((list (trimmed-lesson-information (cdr *lesson-information*))))
|
||
(let ((flag (get-lesson-information '(tag try) list)))
|
||
(if flag (set-lesson-section-to flag)
|
||
(complain "You're at the beginning of this sesson")))))
|
||
|
||
|
||
(defun read-previous-lesson-section ()
|
||
;; trim off the try that got us here and the lesson we just did.
|
||
;; look for a preceding tag or try.
|
||
(in-lesson?)
|
||
(let ((list (trimmed-lesson-information
|
||
(trimmed-lesson-information
|
||
(cdr *lesson-information*)))))
|
||
(let ((flag (get-lesson-information '(tag try) list)))
|
||
(if flag (set-lesson-section-to flag)
|
||
(complain "There isn't a section before this one")))))
|
||
|
||
|
||
(defun set-lesson-section-to (flag)
|
||
(filepos *lesson-file* (get-position flag))
|
||
(setq *lesson-information*
|
||
(cons (car *lesson-information*)
|
||
(memq flag *lesson-information*)))
|
||
(read-lesson-section))
|
||
|
||
|
||
;;; assume cursor is at start of a lesson.
|
||
;;; read lines until reach end of this section, end of file,
|
||
;;; or "try" (it says stop here for user to play)
|
||
;;; for each line,
|
||
;;; 1. normal line, just echo.
|
||
;;; 2. try line, give over to user.
|
||
;;; 3. eval line, read in lisp exprs and eval them until
|
||
;;; hit ().
|
||
;;; 4. end-of-file line, close file and return.
|
||
|
||
(defun want-lesson? ()
|
||
(recorded-output "~&You're not in a lesson at the moment.~%")
|
||
(cond ((and *lesson-name*
|
||
(query "Restart lesson ~A?" *lesson-name*))
|
||
(*lesson *lesson-name*))
|
||
((query "Start a new lesson?")
|
||
(active-menu *lessons-known*
|
||
#'(lambda (x) x)
|
||
#'*lesson
|
||
"Menu of available lessons"))))
|
||
|
||
(defun kill-lesson ()
|
||
(cond ((or (filep *lesson-file*)
|
||
(sfap *lesson-file*))
|
||
(close *lesson-file*)))
|
||
(program-record "Killing lesson ~A." *lesson-name*)
|
||
(setq *lesson-file* nil))
|
||
|
||
(defun abort-lesson ()
|
||
(in-lesson?)
|
||
(kill-lesson)
|
||
(output "~&Lesson ~A aborted.~%" *lesson-name*))
|
||
|
||
(defun end-of-lesson-file ()
|
||
(kill-lesson)
|
||
(if (query "Would you care to have lesson ~A restarted?"
|
||
*lesson-name*)
|
||
(*lesson *lesson-name*)))
|
||
|
||
(defvar *muzzled* nil "If this is on, the lessons aren't typed out.")
|
||
|
||
(defun read-lesson-section ()
|
||
(let ((*muzzled* nil)) ;special -- may be rebound by lesson-function IF
|
||
(cond ((not *lesson-file*)
|
||
(catch-complaints
|
||
(catch-**more**
|
||
(catch-lesson-exit
|
||
(want-lesson?)))))
|
||
(t (catch-**more**
|
||
(catch-complaints
|
||
(cautiously-incrementing-filepos *lesson-file*
|
||
(catch-lesson-exit
|
||
(do ((c (tyipeek nil *lesson-file* -1)
|
||
(tyipeek nil *lesson-file* -1)))
|
||
((= c -1) (end-of-lesson-file))
|
||
(caseq c
|
||
((#\linefeed) (tyi *lesson-file*))
|
||
((#/.) (tyi *lesson-file*)
|
||
(let* ((special (sysread *lesson-file*))
|
||
(special-func (lesson-function special)))
|
||
(if special-func
|
||
(funcall special-func)
|
||
(quiet-bug
|
||
"warpo lesson command encountered: ~S~%"
|
||
special)
|
||
(readline *lesson-file*))))
|
||
(t (let ((line (readline *lesson-file*)))
|
||
(cond ((null line)
|
||
(end-of-lesson-file)
|
||
(return nil))
|
||
((not *muzzled*)
|
||
(output "~&~A~%" line)))))))))))))))
|
||
|
||
|
||
;;; Special functions to be run.
|
||
|
||
; note -- a .IF will conditionalize only to the next .IF, .END-IF or
|
||
; something that ends a section like a .PAUSE or a .TRY
|
||
|
||
(define-lesson-function if "conditionalize out a section of text"
|
||
(setq *muzzled* (not (eval (read *lesson-file*)))))
|
||
|
||
(define-lesson-function end-if "end an if"
|
||
(setq *muzzled* nil))
|
||
|
||
(define-lesson-function eval "invisibly eval a form to the user's environment"
|
||
(eval (read *lesson-file*)))
|
||
|
||
;; This reads an entire Lisp form and prints it, including any ;...'s
|
||
(defun read-verbosely (instream)
|
||
(let ((start-filepos (filepos instream)))
|
||
(let ((form (read instream)))
|
||
(readline instream) ;toss rest of line (in case of trailing semi)
|
||
(let ((end-filepos (filepos instream)))
|
||
(filepos instream start-filepos)
|
||
(do ((l (readline instream nil) (readline instream nil)))
|
||
((or (null l) (not (< (filepos instream) end-filepos)))
|
||
(if l (output "~&~A~%" l))) ;output the last line
|
||
(output "~&~A~%" l))
|
||
form))))
|
||
|
||
(define-lesson-function eval-print "same as eval but not invisible"
|
||
(eval (read-verbosely *lesson-file*)))
|
||
|
||
(define-lesson-function pp
|
||
"have a Lisp form pretty printed in the text without having it evaled"
|
||
(read-verbosely *lesson-file*))
|
||
|
||
(define-lesson-function try "return from this lesson retaining file info"
|
||
(add-lesson-information 'try)
|
||
(recorded-output "~2&You try now. To continue, type ^N.~%")
|
||
(exit-lesson))
|
||
|
||
(define-lesson-function pause "return from this lesson without implying try"
|
||
(add-lesson-information 'pause)
|
||
(recorded-output "~2&To continue, type ^N.~%")
|
||
(exit-lesson))
|
||
|
||
(define-lesson-function tag "tag marks the beginning of a file"
|
||
(add-lesson-information 'tag)
|
||
nil)
|
||
|
||
(define-lesson-function comment "comments to be allowed in the file"
|
||
(readline *lesson-file*)
|
||
nil)
|
||
|
||
(define-lesson-function document "comments to be allowed in the file"
|
||
(readline *lesson-file*)
|
||
nil)
|
||
|
||
(define-lesson-function eof "note lesson is over"
|
||
(lesson-has-been-seen *lesson-name*))
|
||
|
||
;;; This lesson is finished. Do you want to go on? (Y or N) Yes.
|
||
;;; The next recommended lesson is ADVANCED. Wanna try that? (Y or N) No.
|
||
;;; Ok, sucker. Type the lesson you want ended by Return: WIZARD
|
||
;;; This function is only to be used as the last thing in a lesson.
|
||
|
||
(define-lesson-function next "used to point to the next lesson. should
|
||
only occur as last thing in a lesson, cuz it kills this lesson."
|
||
(lesson-has-been-seen *lesson-name*)
|
||
(let ((first-choice (sysread *lesson-file*)))
|
||
(kill-lesson)
|
||
(cond ((query "Lesson ~A is finished. Would you care to proceed?"
|
||
*lesson-name*)
|
||
(get-apropriate-next-lesson first-choice))
|
||
(t (if (query "Would you care to retry lesson ~A?"
|
||
*lesson-name*)
|
||
(*lesson *lesson-name*)))))
|
||
(exit-lesson))
|
||
|
||
(defun get-apropriate-next-lesson (first-choice)
|
||
(do ((flag nil t)
|
||
(lesson-choice first-choice (get-next-next-lesson lesson-choice flag)))
|
||
((not lesson-choice)
|
||
(output "~&I've no~@[~* further~] suggestions for you.~%" flag)
|
||
(get-a-new-lesson))
|
||
(if (not (seen-lesson? lesson-choice))
|
||
(return (if (query "The next recommended lesson is ~A. Do you ~
|
||
wish to try that?"
|
||
lesson-choice)
|
||
(*lesson lesson-choice)
|
||
(get-a-new-lesson))))))
|
||
|
||
(defun get-next-next-lesson (choice flag)
|
||
(output "~2&The next recommended lesson~@[~* after that~] is ~S, ~
|
||
~%but you've already seen it...~
|
||
~%Hold on while I try to think of some other suggestion...~2%"
|
||
flag
|
||
choice)
|
||
(let ((full-name (full-lesson-name choice)))
|
||
(if (probef full-name)
|
||
(iota ((stream full-name '(in ascii dsk)))
|
||
(if (find-special-function-in-file 'next stream)
|
||
(sysread stream)
|
||
nil))
|
||
nil)))
|
||
|
||
(defun get-a-new-lesson ()
|
||
(output "~2&Here is a list of lessons to choose from:~%")
|
||
(active-menu *lessons-known*
|
||
#'(lambda (x) x)
|
||
#'*lesson
|
||
"Menu of available lessons"))
|
||
|
||
(define-lesson-function required
|
||
"there are lessons that should be run before this one"
|
||
(let ((requirement (read *lesson-file*)))
|
||
(if (not (seen-lesson? requirement))
|
||
(progn
|
||
(recorded-output "Before you start lesson ~S you really should know ~
|
||
~%about what is in Lesson ~S."
|
||
*lesson-name*
|
||
requirement)
|
||
(if (query "Should I start it for you?")
|
||
(progn
|
||
(kill-lesson)
|
||
(program-record
|
||
"User is gonna be reasonable and do the prereq first")
|
||
(*lesson requirement))
|
||
(program-record "user is a turkey and is ignoring the prereq.")
|
||
(output "~&Ok, but don't say i didn't warn you...~2%"))))))
|
||
|
||
|
||
;;; Local Modes:;
|
||
;;; Mode:LISP;
|
||
;;; Comment Column:50;
|
||
;;; Lisp WHEN-ABNORMAL-EXIT Indent:1;
|
||
;;; Lisp CAUTIOUSLY-INCREMENTING-FILEPOS Indent:1;
|
||
;;; End:;
|