Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!linus!decvax!duke!mcnc!ncsu!uvacs!mac
From: mac@uvacs.UUCP
Newsgroups: net.sources
Subject: Text Filter
Message-ID: <1125@uvacs.UUCP>
Date: Thu, 12-Jan-84 13:25:30 EST
Article-I.D.: uvacs.1125
Posted: Thu Jan 12 13:25:30 1984
Date-Received: Sat, 14-Jan-84 04:38:05 EST
Lines: 271

;
;         Blither a` la Tim Stryker
;         programmed by Jeff Dalton '78
;         copyright (c) 1977 by the trustees of Dharma College
;         adapted for Franz by alex colvin 1983

; This program was originally written to engage the user in a dialogue.
; It was converted for UN*X to use as a text filter, e.g.
;       deroff th | mumble -match 3 | nroff -me | page
; Some of the code is idiomatic DTSS Lisp, some is just strange.  It
; shouldn't be taken as a guide to Lisp programming.

; $Compile: liszt -r -o %F %f

; functionq[f] == a cheap funarg, since we don't need closures
;
(def functionq (macro (l) (cons 'quote (cdr l))))

(declare
 (special sentences     ; list of known sentences
	  replymax      ; bound on reply length (avoid Quack ! Quack ! ...)
	  matchdist     ; coherence factor
	  sequence      ; controls replies
	  $gcprint      ; system GC trace flag
	  ))

; worker[] == main driver
;
(def worker
 (lambda ()
  (readargs)
  (talk)
  ))

; readargs[] == scan argv and set parameters

(def readargs
 (lambda ()
  (prog (n a)
	(setq n 0)
   a    (setq n (add1 n))
	(cond ((equal n (argv)) (return)))
	(setq a (argv n))
	(cond ((eq a '-match)
	       (setq matchdist (makenum (argv (setq n (add1 n))))) )
	      ((eq a '-length)
	       (setq replymax (makenum (argv (setq n (add1 n))))) )
	      ((eq a '-sequence)
	       (setq sequence t) )
	      ((eq a '-db)
	       (setq $gcprint t) )
	      )
	(go a) )))

; makenum[x] == convert a symbol x to a number

(def makenum (lambda (x) (readlist (explodec x))))

; talk[] == function to conduct the conversation

(declare
 (special letter        ; peek character
	  eof           ; eof flag
	  ))

(def talk
 (lambda ()
  (prog (letter answer)
	(setq letter (readc))
   a:   (setq answer (readanswer))
	(cond ((eq (car answer) eof)
	       (return) )
	      (t
	       (setq sentences (cons answer sentences ))
	       (analyze answer)
	       (printsentence (replyto answer))
	       ))
	(go a:)
   )))

;
;     sentence i/o functions
(declare
 (special nl            ; newline
	  spa           ; space
	  tab           ; tab
	  ))

(setq nl  (ascii 10))
(setq spa (ascii 32))
(setq tab (ascii 9))
(setq eof nil)        ; value of (readc) on eof

;   readword[] == returns the next word
;                 leaving the first character after the word in 'letter'

(def readword
 (lambda ()
  (prog (word)
   sp:  (cond ((get letter 'whitespace)
	       (setq letter (readc))
	       (go sp:)))

	(setq word (cons letter nil))
	(cond ((get letter 'break)
	       (setq letter (readc))
	       (return (car word))))

   eat: (setq letter (readc))
	(cond
	 ((get letter 'break)
	  (return (implode (nreverse word)))))
	(setq word (cons letter word))
	(go eat:))))


;   readanswer[] == read a sentence from the terminal

(def readanswer
 (lambda ()
  (prog (word sentence)
   a:   (setq word (readword))
	(setq sentence (cons word sentence ))
	(cond ((get word 'endsentence) (return (nreverse sentence)) ))
	(go a:)
   )))

; character classes

(def defclass
 (lambda (class chars)
  (map (functionq (lambda (x) (putprop (car x) t class)))
       chars)))

; word breaks
(defclass 'break
	  (list nl tab spa eof
		'\? '\( '\) '\[ '\] '\@ '\,  '\! '\. '\: '\; '\"))
; white space characters
(defclass 'whitespace
	  (list nl tab spa))
; end of sentence characters
(defclass 'endsentence
	  (list eof '\? '\. '\!))


;  printsentence [sentence] == prints the sentence in a readable form to the port

(def printsentence
 (lambda (sentence)
  (prog ()
   a    (cond (sentence (princ (car sentence))
			(cond ((not (get (cadr sentence) 'break))
			       (princ spa)))
			(setq sentence (cdr sentence))
			(go a)  ))
	(terpri)
   )))

;
; sentence recombination

; analyze[sentence] == associate each word in the sentence with the rest
; of the sentence
;
(def analyze
 (lambda (sentence)
  (map (functionq (lambda (words) (associate (car words) words)  ))
       sentence)
 ))

; use 'follows property
(def associate
 (lambda (word follow)
  (putprop word
	   (cons follow (get word 'follows))
	   'follows  )))


;;    functions to construct a reply

(def replyto
 (lambda (sentence)
  (extendreply replymax (initialreply sentence)) ))

; select a response to start with
; if the seqquence flag is set then the last input is used,
; otherwise some random input
;
(def initialreply
 (lambda (sentence)
  (cond (sequence sentence)
	(t (randomth sentences) )) ))

; extendreply[max;words] == extends the words for at most max
;
(def extendreply
 (lambda (max words)
  (cond ((zerop max) '(|...|))
	((null words) nil)
	(t
	 (cons (car words)
	       (extendreply (sub1 max) (extension (cdr words)))
 ))     ))     )

; extension[a] == splice on a new extension to reply a after match
(def extension
 (lambda (a)
  (splicen matchdist
	   a
	   (randomth (extend matchdist
			     a
			     (get (car a) 'follows)
 ))        )         )       )

; splicen[n;a;b] == appends b after the first n elements of a
;
(def splicen
 (lambda (n a b)
  (cond ((zerop n) b)
	((null a) b)
	(t (cons (car a) (splicen (sub1 n) (cdr a) b) )))))

; extend[dist;words;exts] == select those exts that match words for dist
; and return what follows the matching part.
;
(def extend
 (lambda (dist words exts)
  (cond ((zerop dist) exts)
	(t (extend (sub1 dist)
		   (cdr words)
		   (restrict (car words) exts)
		   ))
  )))

; restrict[word;exts] == returns the cdr[ext] for each ext s.t. car[ext]=word
;
(def restrict
 (lambda (word exts)
  (mapcon (functionq
	   (lambda (exts)
	    (cond ((eq (caar exts) word) (list (cdar exts)))
		  (t nil)
	    )))
	  exts
   )))

;     useful little functions


;     randomth [l] -- returns a random member of the list l

(def randomth
 (lambda (l)
  (cond ((null (cdr l)) (car l))        ; singleton
	(t (nth (random (sub1 (length l)))
		l
 ))     )  )    )


;     begin

(setq sentences nil)
(setq replymax 20)      ; maximum number of "words" in a reply
(setq matchdist 1)      ; distince sentences must match
(setq sequence nil)     ; scramble sentences

(setq gcdisable nil)    ; !!! EVADE LOAD "FEATURE"

(worker)
(exit)