procgen  verb.scm at tip

File lib/verb.scm from the latest check-in


; [ʞ] verb.scm
;  ~ lexi hale <lexi@hale.su>
;  © affero general public license
;  > (load "lib/lisp-macro.scm")
;    (load "lib/fn-struct.scm")
;    (load "lib/verb.scm")

; macros, functions, and rules  for conjugating verbs and
; generating verb phrases. this library rules was written
; specifically for english verbs and  cannot be used as a
; "drop-in"  library for  other  languages; however,  the
; structured and functions  used are sufficiently generic
; that  it should  be  portable to  other languages  with
; minimal effort.

;;;; section i. generic functions & structures

; struct verb
;  fields contain conjugation functions for the specified
;  tense. ((v 'inf) object) will generate a verb phrase string
;  with `object` as the direct object and in the bare form
;   'inf: bare infinitive / subjunctive / 1.PRS, 2.PRS, 3PL.PRS
;   'prs: 3SG.PRS
;   'ger: gerund (-ing form)
;   'pst: past (-ed form)
;   'ppl: past participle (often -ed or -en)
; * l10n note: the fields mentioned in the last line of the
;   (verb-form) macro must always match the fields listed in
(define verb (struct 'inf 'prs 'ger 'adj 'pst 'ppl))

; takes a list of individual  strings and joins them with
; spaces. occurrences of "a" are automatically replace by
; "an" if the word following them appears to start with a
; vowel. this can be  forcibly induced by preceeding that
; word with the symbol 'vowel in the list
; TODO: make it handle initialisms. yes, everything about
; this is horrible. yes, this *is* the wrong way to do it.
; yes, i *am* ashamed. why do you ask
(define (word-append . body)
  (define (vowel? c) (member c '("a" "e" "i" "o" "u")))
  (define (vowel-onset? w)
	(if (equal? w 'vowel) #t
		(vowel? (substring w 0 1))))
  (define (join acc lst)
	(if (eq? lst '()) acc
		(let ([word (car lst)]
			  [tail (cdr lst)])
		  (if (or (eq? word '()) (eq? word 'vowel)) (join acc tail)
			  (join (string-append acc (if (equal? acc "") "" " ")
				 (if (not (equal? word "a")) word
					 (if (eq? tail '()) "a"
						 (if (vowel-onset? (car tail)) "an" "a")))) tail)))))
  (join "" body))

; make it easier to define repetitive verb forms
(define-macro (verb-form . body)
			  (define (make-id . body)
				(string->symbol (apply string-append body)))

			  (define (finalize-rule r)
				(define (finalize-sub-rule s)
				  (if (list? s) `(string-append ,@s) s))
				(let* ([rule-name (car r)]
					   [rule-body (cdr r)])
				  `(define (,rule-name *o*)
					 (word-append ,@(map finalize-sub-rule rule-body)))))

			  (let* ([proc-def  (car body)]
					 [proc-name (symbol->string (car proc-def))]
					 [proc-args (cdr proc-def)]
					 [defs      (cdr body)])

			  `(define (,(make-id "verb:" proc-name) ,@proc-args)
				 ,@(map finalize-rule defs) (verb inf prs ger adj pst ppl))))
 
; create a phrasal verb from a normal verb
;  - vb: root verb
;  - pp: preposition or pp phrase to append
(define (phrase vb pp)
  (lambda (form)
	(if (or (equal? form 'ppl) (equal? form 'adj))
		(lambda (*o*)
		  (word-append (string-append ((vb form) '()) "-" pp) *o*))
		(lambda (*o*)
		  (word-append ((vb form) *o*) pp)))))

; create a compound form a verb that already exists
; - prefix: prefix to append (e.g. up, out, over, un)
; - vb: final, "stem" verb
(define (compound prefix vb) (lambda (form) (lambda (*o*)
	  (word-append (string-append prefix ((vb form) *o*))))))

; create a  verb where another string  interposes between
; the  root verb  and the  object.  this can  be used  to
; implement object  incorporation or  prepositional verbs
; such as "get  off on" (not to be  confused with phrasal
; verbs) a phrasal verb.
; - vb: the root (leftmost) verb
; - pps: the preposition complex immediately following
;   the verb.
(define (postpositive vb post) (lambda (form) (lambda (*o*)
	(if (or (equal? form 'ppl) (equal? form 'adj))
		(word-append
		  (string-append ((vb form) '()) "-" post)
		  *o*)
		(word-append ((vb form) '()) post *o*)))))


;;; section ii. english-specific verb classes

(verb-form (weak stem)
		   ; e.g. suck → sucking
		   (inf [stem]       *o*)
		   (prs [stem "s"]   *o*)
		   (ger [stem "ing"] *o*)
		   (adj [stem "ing"] *o*)
		   (pst [stem "ed"]  *o*)
		   (ppl [stem "ed"]  *o*))

(verb-form (es stem)
		   ; e.g. suck → sucking
		   (inf [stem]       *o*)
		   (prs [stem "es"]   *o*)
		   (ger [stem "ing"] *o*)
		   (adj [stem "ing"] *o*)
		   (pst [stem "ed"]  *o*)
		   (ppl [stem "ed"]  *o*))

(verb-form (e stem)
		   ; e.g. vape → vaping
		   (inf [stem "e"]   *o*)
		   (prs [stem "es"]  *o*)
		   (ger [stem "ing"] *o*)
		   (adj [stem "ing"] *o*)
		   (pst [stem "ed"]  *o*)
		   (ppl [stem "ed"]  *o*))

(verb-form (y stem)
		   ; e.g. try → trying
		   (inf [stem "y"]   *o*)
		   (prs [stem "ies"]  *o*)
		   (ger [stem "ing"] *o*)
		   (adj [stem "ing"] *o*)
		   (pst [stem "ed"]  *o*)
		   (ppl [stem "ed"]  *o*))

(verb-form (heavy stem final)
		   ; e.g. plug → plugging
		   (inf [stem]             *o*)
		   (prs [stem "s"]         *o*)
		   (ger [stem final "ing"] *o*)
		   (adj [stem final "ing"] *o*)
		   (pst [stem final "ed"]  *o*)
		   (ppl [stem final "ed"]  *o*))

(verb-form (strong stem ipst ippl)
		   ; e.g. drink → drank
		   (inf [stem]       *o*)
		   (prs [stem "s"]   *o*)
		   (ger [stem "ing"] *o*)
		   (adj [stem "ing"] *o*)
		   (pst [ipst]        *o*)
		   (ppl [ippl]        *o*))

(verb-form (strong-heavy stem final ipst ippl)
		   ; e.g. drink → drank
		   (inf [stem]       *o*)
		   (prs [stem "s"]   *o*)
		   (ger [stem final "ing"] *o*)
		   (adj [stem final "ing"] *o*)
		   (pst [ipst]        *o*)
		   (ppl [ippl]        *o*))

(verb-form (irregular iinf iprs iger ipst ippl)
		   ; e.g. have → has → had
		   (inf [iinf] *o*)
		   (prs [iprs] *o*)
		   (ger [iger] *o*)
		   (adj [iger] *o*)
		   (pst [ipst] *o*)
		   (ppl [ippl] *o*))

(verb-form (strong! stem ipst)
		   ; e.g. shoot → shot → shot
		   (inf [stem]       *o*)
		   (prs [stem "s"]   *o*)
		   (ger [stem "ing"] *o*)
		   (adj [stem "ing"] *o*)
		   (pst [ipst]       *o*)
		   (ppl [ipst]       *o*))