Text Filter
mac at uvacs.UUCP
mac at uvacs.UUCP
Fri Jan 13 04:25:30 AEST 1984
;
; 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)
More information about the Comp.sources.unix
mailing list