procgen  Check-in [6822b7d006]

Overview
Comment:add libs
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 6822b7d0064a762c083ccd9a57ee760a978af3083783f18deb0a7f9435e41274
User & Date: lexi on 2019-03-30 03:45:34
Other Links: manifest | tags
Context
2019-04-17
22:45
remove outdated readme check-in: 6e90584b3f user: lexi tags: trunk
2019-03-30
03:45
add libs check-in: 6822b7d006 user: lexi tags: trunk
2019-03-28
05:14
add interlace.scm, update some shit check-in: 275f19cd9e user: lexi tags: trunk
Changes

Modified drug.scm from [6e5900594d] to [4c1ce8b744].

     1      1   (include "lib/lisp-macro.scm")
            2  +(include "lib/fail.scm")
     2      3   (include "lib/interlace.scm")
     3      4   (include "lib/bot.scm")
     4         -
     5         -(define (fail . msg)
     6         -	(display (string-append "\x1b[1;31m - err.\x1b[0m " 
     7         -							(apply string-append msg)))
     8         -	(exit 1))
     9         -(define (fail:sym s)
    10         -  (fail "bad form \x1b[3;36m'" (symbol->string s) "\x1b[0m"))
    11         -
    12         -(define-macro (fn . b) (cons 'lambda b)) ; your honor, they made me do it
    13         -
    14         -(define (verb inf ger pst ppl)
    15         -  (fn (form)
    16         -	  (define (is f) (equal? form f))
    17         -	  (cond 
    18         -		((is 'inf) inf) ((is 'ger) ger)
    19         -		((is 'pst) pst) ((is 'ppl) ppl)
    20         -		(else (fail:sym form)))))
    21         -
    22         -(define (word-append . body)
    23         -  (define (vowel? c) (member c '("a" "e" "i" "o" "u")))
    24         -  (define (join acc lst)
    25         -	(if (eq? lst '()) acc
    26         -		(let ([word (car lst)]
    27         -			  [tail (cdr lst)])
    28         -		  (if (eq? word '()) (join acc tail)
    29         -			  (join (string-append acc (if (equal? acc "") "" " ")
    30         -				 (if (not (equal? word "a")) word
    31         -					 (if (eq? tail '()) "a"
    32         -						 (let* ([next-word (car tail)]
    33         -								[onset (substring next-word 0 1)])
    34         -						   (if (vowel? onset) "an" "a"))))) tail)))))
    35         -  (join "" body))
    36         -
    37         -
    38         -(define-macro (verb-form . body)
    39         -			  (define (make-id . body)
    40         -				(string->symbol (apply string-append body)))
    41         -
    42         -			  (define (finalize-rule r)
    43         -				(define (finalize-sub-rule s)
    44         -				  (if (list? s) `(string-append ,@s) s))
    45         -				(let* ([rule-name (car r)]
    46         -					   [rule-body (cdr r)])
    47         -				  `(define (,rule-name *o*)
    48         -					 (word-append ,@(map finalize-sub-rule rule-body)))))
    49         -
    50         -			  (let* ([proc-def  (car body)]
    51         -					 [proc-name (symbol->string (car proc-def))]
    52         -					 [proc-args (cdr proc-def)]
    53         -					 [defs      (cdr body)])
    54         -
    55         -			  `(define (,(make-id "verb:" proc-name) ,@proc-args)
    56         -				 ,@(map finalize-rule defs) (verb inf ger pst ppl))))
    57         -
    58         -(link-vector 'words
    59         -			   fuck: (verb:weak "fuck")  
    60         -			 clench: (verb:weak "clench") 
    61         -			 '(verb:weak "download")
    62         -			 '(verb:weak "cyber"))
    63         - 
    64         -(define (phrase vb pp)
    65         -  (lambda (form)
    66         -	(if (equal? form 'ppl)
    67         -		(lambda (*o*)
    68         -		  (word-append (string-append ((vb 'ppl) '()) "-" pp) *o*))
    69         -		(lambda (*o*)
    70         -		  (word-append ((vb form) *o*) pp)))))
    71         -
    72         -(verb-form (weak stem)
    73         -		   ; e.g. suck → sucking
    74         -		   (inf [stem]       *o*)
    75         -		   (ger [stem "ing"] *o*)
    76         -		   (pst [stem "ed"]  *o*)
    77         -		   (ppl [stem "ed"]  *o*))
    78         -
    79         -(verb-form (e stem)
    80         -		   ; e.g. vape → vaping
    81         -		   (inf [stem "e"]   *o*)
    82         -		   (ger [stem "ing"] *o*)
    83         -		   (pst [stem "ed"]  *o*)
    84         -		   (ppl [stem "ed"]  *o*))
    85         -
    86         -(verb-form (heavy stem final)	; e.g. plug → plugging
    87         -		   (inf [stem final]       *o*)
    88         -		   (ger [stem final "ing"] *o*)
    89         -		   (pst [stem final "ed"]  *o*)
    90         -		   (ppl [stem final "ed"]  *o*))
    91         -
    92         -(verb-form (strong stem pst ppl)	; e.g. drink → drank
    93         -		   (inf [stem]       *o*)
    94         -		   (ger [stem "ing"] *o*)
    95         -		   (pst [pst]        *o*)
    96         -		   (ppl [ppl]        *o*))
    97         -
    98         -(verb-form (strong! stem pst)	; e.g. shoot → shot → shot
    99         -		   (inf [stem]       *o*)
   100         -		   (ger [stem "ing"] *o*)
   101         -		   (pst [pst]        *o*)
   102         -		   (ppl [pst]        *o*))
   103         -
   104         -
   105         -
   106         -				(verb:weak		"crunch")
   107         -				(verb:weak	 	"snort" "snorting")
   108         -				(verb:heavy	 	"stab" "b")
   109         -				(verb:strong	"drink" "drank" "drunk")
   110         -				(verb:strong	"eat"   "ate"	"eaten")
   111         -				(verb:strong	"bite"	"bit"	"bitten")
   112         -				(verb:strong!	"shoot" "shot")
   113         -				
   114         -				))
   115         -
   116         -(define verbs (interlace vector
            5  +(include "lib/struct.scm")
            6  +(include "lib/verb.scm")
            7  +
            8  +(define (forms fn vb . args)
            9  +  (list->vector (map (lambda (a) (fn vb a)) args)))
           10  +
           11  +(define (flexprep vb . args)
           12  +		  (list->vector
           13  +			(append (map (lambda (x) postpositive vb x) args)
           14  +					(map (lambda (x) phrase vb x) args))))
           15  +
           16  +
           17  +(define intransitive-verbs (interlace vector
           18  +	(forms phrase
           19  +		   (verb:strong "get" "got" "gotten") "up" "off" "out")
           20  +	(verb:weak "leak")
           21  +	(verb:weak "scream")
           22  +	(verb:weak "fear")
           23  +	hurt. (verb:strong! "hurt" "hurt")
           24  +	(forms postpositive
           25  +		   hurt "bad" "real bad" "like hell"
           26  +		   "something awful" "something fierce"
           27  +		   "something terrible" "real good")
           28  +
           29  +	(forms postpositive
           30  +		   (verb:weak "jerk") "it" "off")
           31  +
           32  +	(forms phrase (verb:strong "throw" "threw" "thrown")
           33  +			"up" "down")
           34  +	))
           35  +
           36  +(define vocab:roa-verbs (interlace vector
           37  +	get. (verb:strong "get" "got" "gotten")
           38  +		(forms phrase
           39  +			get "up" "off" "out" "in")
           40  +		(forms postpositive
           41  +		   get "in" "in on" "out of" "up in" "into"
           42  +		   "off on" "over" "over to")
   117     43   	crunch. (verb:weak "crunch")
   118         -	(phrasal crunch "up")
   119         -	(phrasal crunch "off")
   120         -	(phrasal crunch "out")
   121         -	(phrasal crunch "away")
           44  +		(flexprep crunch "up" "off" "out" "away")
           45  +		(postpositive crunch "on")
           46  +	cyber. (verb:weak "cyber")
           47  +		(flexprep cyber "up")
           48  +	slurp. (verb:weak "slurp")
           49  +		(flexprep "up")
           50  +	suck. (verb:weak "suck")
           51  +		(flexprep suck "up" "off" "down")
           52  +	throw. (verb:strong "throw" "threw" "thrown")
           53  +		(flexprep throw "up")
           54  +		(postpositive throw "back")
           55  +	chew. (verb:weak 	"chew")
           56  +		(flexprep chew "up")
           57  +		(postpositive chew "on")
           58  +	have. (verb:irregular "have" "has" "having" "had" "had")
           59  +	do. (verb:irregular "do" "does" "doing" "did" "done")
           60  +	poop. (verb:weak "poop")
           61  +		(flexprep poop "out")
           62  +		(postpositive poop "on")
           63  +	piss. (verb:weak "piss")
           64  +		(postpositive piss "on")
           65  +		(flexprep piss "out" "away" "off")
           66  +	cook. (verb:weak "cook")
           67  +		(phrase cook "up")
           68  +	tweet. (verb:weak "tweet")
           69  +		(forms phrase tweet "up" "at")
           70  +	plug. (verb:heavy "plug" "g")
           71  +		(phrase plug "in")
           72  +	(postpositive (verb:weak "laugh") "at")
           73  +	(flexprep (verb:weak "hook") "up" "in")
           74  +	(flexprep (verb:weak "turn") "on" "in")
           75  +
           76  +	(verb:weak	"download")
           77  +	(verb:weak	"snort")
           78  +	(verb:weak	"sniff")
           79  +	(verb:weak 	"down")
           80  +	(verb:weak 	"hoot")
           81  +	(verb:weak 	"toot")
           82  +	(verb:weak 	"boof")
           83  +	(verb:weak 	"blast")
           84  +	(verb:weak 	"honk")
           85  +	(verb:weak 	"whack")
           86  +	(verb:weak 	"loot")
           87  +	(verb:weak 	"slaughter")
           88  +	(verb:weak 	"ghoul")
           89  +	(verb:es 	"ravish")
           90  +	(verb:es	"piss")
           91  +	(verb:es	"crunch")
           92  +	(verb:e	 	"scrobbl")
           93  +	(verb:e	 	"chok")
           94  +	(verb:e	 	"blaz")
           95  +	(verb:e	 	"freebas")
           96  +	(verb:e	 	"us")
           97  +	(verb:e		"vap")
           98  +	(verb:e	 	"smoke")
           99  +	(verb:e	 	"gargle")
          100  +	(verb:e	 	"guzzle")
          101  +	(verb:e		"mainlin")
          102  +	(verb:y 	"tr")
          103  +	(verb:heavy	"stab" "b")
          104  +	(verb:heavy "pop" "p")
          105  +	(verb:heavy	"zap" "p")
          106  +	(verb:heavy	"slug" "g")
          107  +	(verb:strong "drink" "drank"	"drunk")
          108  +	(verb:strong "eat"   "ate"		"eaten")
          109  +	(verb:strong "bite"  "bit"		"bitten")
          110  +
          111  +	shoot. (verb:strong!	"shoot" "shot")
          112  +	(phrase shoot "up")))
          113  +
          114  +(define person     (struct '1sg '1pl '2 '3sg.f '3sg.m '3pl 'inan))
          115  +(define declension (struct 'nom 'acc 'gen 'poss 'refl 'cop))
          116  +(define pronoun (apply person (map declension '(
          117  +	  ("i"    "me"   "my"    "mine"   "myself"	   "i'm"
          118  +	  ("we"   "us"   "our"   "our"    "ourself"	   "we're") 
          119  +	  ("you"  "you"  "your"  "yours"  "yourself"   "you're")  
          120  +	  ("she"  "her"  "her"   "hers"   "herself"	   "she's")   
          121  +	  ("he"   "him"  "his"   "his"    "himself"	   "he's")
          122  +	  ("they" "them" "their" "theirs" "themselves" "they're" )
          123  +	  ("it"   "it"   "its"   "its"    "itself"     "it's" ))))))
          124  +
          125  +(define (look-up st . path)
          126  +  (if (eq? '() (cdr path)) (st (car path))
          127  +	  (look-up (st (car path)) (cdr path))))
          128  +  
          129  +
          130  +(define collapse-person (person '1sg 'pl '3sg '3sg 'pl))
          131  +; not all person forms are contrastive in english; this
          132  +; way we only have to encode the ones that contrast
          133  +
          134  +; state: a function that is called on a person, a tense
          135  +; (one of 'pst 'prs 'fut 'perf 'imperf), an aspect
          136  +; ('stat 'inch), and returns a string of text describing
          137  +; the person in that state
          138  +;  e.g.	(outta-mind '3sg.f 'prs 'stat) → "is outta her mind"
          139  +;		(suicidal '3sg.m 'fut 'stat) → "is gonna want to die"
          140  +
          141  +(define (adjective pers tense aspect)
          142  +
          143  +
          144  +(define (pick-rec top-list)  ; note: do not expose to
          145  +  (let ([e (pick top-list)]) ; empty vectors
          146  +	(if (vector? e) (pick-rec e) e)))
          147  +
          148  +(define verb:be (let ([t (struct 'inf 'pst)]
          149  +					  [p (struct '1sg '3sg 'pl)])
          150  +				  (t (p "am"  "is" "are")
          151  +					 (p "was" "was" "were"))))
          152  +
          153  +
          154  +(define noun:sg   (vector "a" "the" "this"))
          155  +(define noun:pl   (vector "" "the" "these"))
          156  +(define noun:mass (vector "" "the" "this"))
          157  +(define noun:pn   (vector ""))
          158  +
          159  +(define nouns
          160  +  (let* ([$ string-append] [: cons] [@ list]
          161  +		 [~		(lambda (str lst) (list->vector (map (lambda (fn) (fn str)) lst)))]
          162  +		 [sg	(lambda (n) (: n				noun:sg))]
          163  +		 [pl	(lambda (n) (: ($ n "s")		noun:pl))]
          164  +		 [pl/s	(lambda (n) (: ($ n "es")		noun:pl))]
          165  +		 [pl/i	(lambda (p) (lambda (_) (: p	noun:pl)))]
          166  +		 [pl/iso(lambda (n) (: n				noun:pl))]
          167  +		 [mass	(lambda (n) (: n				noun:mass))]
          168  +		 [mass/i(lambda (m) (lambda (_) (: m	noun:mass)))]
          169  +		 [pn	(lambda (n) (: n				noun:pn))])
          170  +	(vector
          171  +	  (~ "water"	[@ mass pl])
          172  +	  (~ "shoe"		[@ sg pl])
          173  +	  (~ "man"		[@ sg (pl/i "men") (mass/i "Man")])
          174  +	  (~ "mouth"	[@ sg pl])
          175  +	  (~ "ass"		[@ sg pl/s])
          176  +	  (~ "dick"		[@ sg pl mass])
          177  +	  (~ "cock"		[@ sg pl mass])
          178  +	  (~ "cunt"		[@ sg pl mass])
          179  +	  (~ "pussy"	[@ sg mass (pl/i "pussies")])
          180  +	  (~ "eyeball"	[@ sg pl])
          181  +	  (~ "bed"		[@ sg pl])
          182  +	  (~ "house"	[@ sg pl])
          183  +	  (~ "home"		[@ mass pl])
          184  +	  (~ "pants"	[@ pl/iso])
          185  +	  (~ "face"		[@ sg pl])
          186  +	  (~ "friend"	[@ sg pl])
          187  +	  (~ "pal"		[@ sg pl])
          188  +	  (~ "buddy"	[@ sg (pl/i "buddies")])
          189  +	  (~ "vomit"	[@ mass])
          190  +	  (~ "phone"	[@ sg pl])
          191  +	  (~ "pig"		[@ sg pl])
          192  +	  (~ "cop"		[@ sg pl])
          193  +	  (~ "human"	[@ sg pl])
          194  +	  (~ "God"		[@ pn])
          195  +	  (~ "god"		[@ sg pl])
          196  +	  (~ "goddess"	[@ sg pl/s])
          197  +	  (~ "asshole"	[@ sg pl])
          198  +	  (~ "clown"	[@ sg pl])
          199  +	  (~ "fear"		[@ mass])
          200  +	  (~ "person"	[@ sg (pl/i "people")]))))
          201  +; TODO: second-order verbs
          202  +#|
          203  +(define (verb-phrase tense noun)
          204  +  (let* ([verb (pick-rec transitive-verbs)]
          205  +		 [noun-form (pick noun)]
          206  +		 [det (pick (cdr noun-form))]
          207  +		 [bare-noun (car noun-form)])
          208  +	((verb tense) (word-append det bare-noun))))
          209  +
          210  +(define (mod-noun noun)
          211  +  (let* ([mode (one-of (cons transitive-verbs 'ppl)
          212  +					   (cons intransitive-verbs 'adj))]
          213  +		 [noun-form (pick noun)]
          214  +		 [bare-noun (car noun-form)]
          215  +		 [verb (pick-rec (car mode))]
          216  +		 [vbd-noun ((verb (cdr mode)) bare-noun)])
          217  +	(vector (cons vbd-noun (cdr noun-form)))))
   122    218   
   123         -	fuck. (verb:weak "fuck")
   124         -	(phrasal fuck "up")
   125         -	(phrasal fuck "out")
   126         -	(phrasal fuck "off")))
          219  +(print "in this house, we " (verb-phrase 'inf (mod-noun (pick nouns))))
          220  +(exit 0)
          221  +|#

Deleted lib/bot-gambit.scm version [85a6f672ec].

     1         -(define-macro (rule . body)
     2         -  (define (make-cases ct body acc)
     3         -    (if (eq? body '()) acc
     4         -      (make-cases (+ ct 1) (cdr body)
     5         -		(cons (list (list ct) (cons 'string-append (car body))) acc))))
     6         -  (list 'define (car body)
     7         -	(cons 'case (cons (list 'random-integer (length (cdr body)))
     8         -	  (make-cases 0 (cdr body) '()) ))))
     9         -
    10         -(define (pick ar)
    11         -  (vector-ref ar (random-integer (vector-length ar))))
    12         -
    13         -(define-macro (one-of . body)
    14         -	(define (make-cases ct body acc) ; accumulator func
    15         -	; this could probably be done much more cleanly through
    16         -	; judicious use of fold or whatever it's called but my
    17         -	; brain is too broken
    18         -		(if (eq? body '()) ; then
    19         -			acc 
    20         -		; else
    21         -			(make-cases (+ 1 ct) (cdr body) ; recurse!
    22         -				(cons `((,ct) ,(car body)) acc)))) ; the rule
    23         -
    24         -	`(case (random-integer ,(length body)) ; final output
    25         -		,@(make-cases 0 body '()))
    26         -)
    27         -(random-source-randomize! default-random-source)

Modified lib/bot.scm from [26ba00c622] to [851e9817dd].

    22     22     (define (nest-case pair)
    23     23   	(cons (list (car pair))
    24     24   		  (cdr pair)))
    25     25   
    26     26     (define (wrap pat) 
    27     27   	(if (eq? (cdr pat) '()) ;then
    28     28   		pat
    29         -		; else
           29  +	; else
    30     30   		(list (cons 'string-append pat))))
    31     31   
    32     32     (let ([branches (map wrap patterns)])
    33     33   	(@one-of nest-case branches)))
    34     34   
    35     35   
    36     36   ; exports

Modified lib/interlace.scm from [a8f59872e4] to [fd266dcc3b].

    31     31   ; the name bindings are ephemeral; they do not survive the immediate
    32     32   ; context of the constructor.
    33     33   
    34     34   (define-macro (interlace . body)
    35     35     ; given a list with both named and nameless members, identify
    36     36     ; which is which and instate the vector.
    37     37     (define (name? term)
           38  +	; given a symbol, determine wheter it is a name, and if so return
           39  +	; that name as a string and without the name-marking suffix ‹.›
           40  +	; otherwise, return #f
    38     41   	(define (coda str) (substring str
    39     42   								  (- (string-length str) 1)
    40     43   								  (string-length str)))
    41     44   	(if (not (symbol? term)) #f
    42     45   		(let* ([term-string (symbol->string term)]
    43     46   			   [final-char (coda term-string)])
    44         -		  (print "TERMSTRING:" term-string)
    45         -		  (print "CHAR:" final-char)
    46     47   		  (if (not (equal? final-char ".")) #f
    47         -			  (substring term-string 0 (- (string-length term-string) 1))))))
           48  +			  (string->symbol(substring term-string 0 (- (string-length term-string) 1)))))))
    48     49   
    49     50     (define (divide-entries lst @named @nameless)
    50     51   	; given a list, return a pair [ x . y ] such that x is a list
    51     52   	; of named terms ( name . term ) and y is a list of nameless
    52     53   	; terms.
    53     54   	(if (eq? lst '()) (cons @named @nameless)
    54     55   		(let* ([head (car lst)]

Added lib/struct.scm version [833aa00a5f].

            1  +; ʞ / struct.scm
            2  +;
            3  +; generates immutable, relatively efficient structs. declare
            4  +; a struct type x with
            5  +;	(define x (struct 'field1 'field2) 
            6  +; create a record y of that type with
            7  +;	(define y (x 123 456))
            8  +; access field1 of record y with
            9  +;	(y 'field1)
           10  +; update field2 of record y with
           11  +;	(y 'field2 123) → new record (field1 = 123; field2 = 123)
           12  +;
           13  +; this unit also includes a few utility function that chicken
           14  +; scheme conveniently "forgot." i apologize for the implementation
           15  +; of (list-head). i was very tired.
           16  +
           17  +; return a sub-list of lst up to ct (inverse of list-tail)
           18  +(define (list-head lst ct)
           19  +  (let* ([reverse-lst (reverse lst)]
           20  +		 [idx (- (length lst) (+ 1 ct))])
           21  +	(reverse (list-tail reverse-lst idx))))
           22  +	; i'm not proud of this
           23  +
           24  +; search for the first occurence of `term` in list lst.
           25  +; equal? is used by default; an alternate predicate may
           26  +; be passed after `term`
           27  +(define (member-index lst term . opt) 
           28  +  (let ([predicate (if (eq? '() opt) equal?
           29  +					   (car opt))])
           30  +	(define (search idx l)
           31  +	  (if (eq? l '()) #f
           32  +		  (if (predicate (car l) term) idx
           33  +			  (search (+ 1 idx) (cdr l)))))
           34  +	  (search 0 lst)))
           35  +
           36  +; generate a new struct type and return it as a function
           37  +; that may be called to instantiate that type.
           38  +(define (struct . keys)
           39  +  (define (generate-record . vals)
           40  +  ; the function returned by a (struct) call and called
           41  +  ; to generate a new struct by functional-update syntax
           42  +	(define (struct-ref key)
           43  +	; searches the struct for the named key and if found
           44  +	; return its index, otherwise return #f
           45  +	  (let ([query-idx (member-index keys key)])
           46  +		(if (eq? #f query-idx) #f
           47  +			(list-ref vals query-idx))))
           48  +	(define (update-record key val)
           49  +	; return a new version of this construct with the same
           50  +	; field names and values except for { key = val }
           51  +		(let* ([field-idx (member-index keys key)]
           52  +			   [new-tail (list-tail vals (+ 1 field-idx))]
           53  +			   [new-head (list-head vals (- field-idx 1))])
           54  +		  (apply generate-record (append new-head (list val) new-tail))))
           55  +
           56  +	; are values specified for every field and no more?
           57  +	; TODO: consider loosening the restriction - could
           58  +	; there be some use to allowing the used to add fields
           59  +	; only accessible through the record->list facility?
           60  +	(if (not (= (length vals) (length keys))) #f
           61  +		(lambda access
           62  +		  ; returned by generate-record, this function is called
           63  +		  ; whenever a struct is accessed
           64  +		  (case (length access)
           65  +			;determine operation to perform
           66  +			((0) vals) ; return list of values
           67  +			((1) (struct-ref (car access))); search for value
           68  +			((2) (update-record (car access) (cadr access)))
           69  +			(else #f))))) ; no other functions currently available
           70  +
           71  +	; keys are now stored in the closure; return the
           72  +	; (generate-record) function to the user so she can
           73  +	; call it to instantiate the defined struct.
           74  +	generate-record)

Added lib/verb.scm version [98598e4655].

            1  +; ʞ / verb.scm
            2  +;	(depends lisp-macro.scm struct.scm)
            3  +;	a library by lexi hale
            4  +;
            5  +; macros, functions, and rules for conjugating verbs and 
            6  +; generating verb phrases. this library rules was written 
            7  +; specifically for english verbs and cannot be used as a
            8  +; "drop-in" library for other languages; however, the
            9  +; structured and functions used are sufficiently generic
           10  +; that it should be portable to other languages with
           11  +; minimal effort.
           12  +
           13  +;;;; section i. generic functions & structures
           14  +
           15  +; struct verb
           16  +;  fields contain conjugation functions for the specified
           17  +;  tense. ((v 'inf) object) will generate a verb phrase string
           18  +;  with `object` as the direct object and in the bare form
           19  +;   'inf: bare infinitive / subjunctive / 1.PRS, 2.PRS, 3PL.PRS
           20  +;   'prs: 3SG.PRS
           21  +;   'ger: gerund (-ing form)
           22  +;   'pst: past (-ed form)
           23  +;   'ppl: past participle (often -ed or -en)
           24  +; * l10n note: the fields mentioned in the last line of the
           25  +;   (verb-form) macro must always match the fields listed in
           26  +(define verb (struct 'inf 'prs 'ger 'adj 'pst 'ppl))
           27  +
           28  +; takes a list of individual strings and joins them with
           29  +; spaces. occurrences of "a" are automatically replace by
           30  +; "an" if the word following them appears to start with a
           31  +; vowel. this can be forcibly induced by preceeding that
           32  +; word with the symbol 'vowel in the list
           33  +; TODO: make it handle initialisms. yes, everything about
           34  +; this is horrible. yes, this *is* the wrong way to do it.
           35  +; yes, i *am* ashamed. why do you ask
           36  +(define (word-append . body)
           37  +  (define (vowel? c) (member c '("a" "e" "i" "o" "u")))
           38  +  (define (vowel-onset? w)
           39  +	(if (equal? w 'vowel) #t
           40  +		(vowel? (substring w 0 1))))
           41  +  (define (join acc lst)
           42  +	(if (eq? lst '()) acc
           43  +		(let ([word (car lst)]
           44  +			  [tail (cdr lst)])
           45  +		  (if (or (eq? word '()) (eq? word 'vowel)) (join acc tail)
           46  +			  (join (string-append acc (if (equal? acc "") "" " ")
           47  +				 (if (not (equal? word "a")) word
           48  +					 (if (eq? tail '()) "a"
           49  +						 (if (vowel-onset? (car tail)) "an" "a")))) tail)))))
           50  +  (join "" body))
           51  +
           52  +; make it easier to define repetitive verb forms
           53  +(define-macro (verb-form . body)
           54  +			  (define (make-id . body)
           55  +				(string->symbol (apply string-append body)))
           56  +
           57  +			  (define (finalize-rule r)
           58  +				(define (finalize-sub-rule s)
           59  +				  (if (list? s) `(string-append ,@s) s))
           60  +				(let* ([rule-name (car r)]
           61  +					   [rule-body (cdr r)])
           62  +				  `(define (,rule-name *o*)
           63  +					 (word-append ,@(map finalize-sub-rule rule-body)))))
           64  +
           65  +			  (let* ([proc-def  (car body)]
           66  +					 [proc-name (symbol->string (car proc-def))]
           67  +					 [proc-args (cdr proc-def)]
           68  +					 [defs      (cdr body)])
           69  +
           70  +			  `(define (,(make-id "verb:" proc-name) ,@proc-args)
           71  +				 ,@(map finalize-rule defs) (verb inf prs ger adj pst ppl))))
           72  + 
           73  +; create a phrasal verb from a normal verb
           74  +;  - vb: root verb
           75  +;  - pp: preposition or pp phrase to append
           76  +(define (phrase vb pp)
           77  +  (lambda (form)
           78  +	(if (or (equal? form 'ppl) (equal? form 'adj))
           79  +		(lambda (*o*)
           80  +		  (word-append (string-append ((vb form) '()) "-" pp) *o*))
           81  +		(lambda (*o*)
           82  +		  (word-append ((vb form) *o*) pp)))))
           83  +
           84  +; create a compound form a verb that already exists
           85  +; - prefix: prefix to append (e.g. up, out, over, un)
           86  +; - vb: final, "stem" verb
           87  +(define (compound prefix vb) (lambda (form) (lambda (*o*)
           88  +	  (word-append (string-append prefix ((vb form) *o*))))))
           89  +
           90  +; create a verb where another string interposes between the
           91  +; root verb and the object. this can be used to implement
           92  +; object incorporation or prepositional verbs such as "get
           93  +; off on" (not to be confused with phrasal verbs)
           94  +; a phrasal verb.
           95  +; - vb: the root (leftmost) verb
           96  +; - pps: the preposition complex immediately following the
           97  +;   verb.
           98  +(define (postpositive vb post) (lambda (form) (lambda (*o*)
           99  +	(if (or (equal? form 'ppl) (equal? form 'adj))
          100  +		(word-append
          101  +		  (string-append ((vb form) '()) "-" post)
          102  +		  *o*)
          103  +		(word-append ((vb form) '()) post *o*)))))
          104  +
          105  +
          106  +;;; section ii. english-specific verb classes
          107  +
          108  +(verb-form (weak stem)
          109  +		   ; e.g. suck → sucking
          110  +		   (inf [stem]       *o*)
          111  +		   (prs [stem "s"]   *o*)
          112  +		   (ger [stem "ing"] *o*)
          113  +		   (adj [stem "ing"] *o*)
          114  +		   (pst [stem "ed"]  *o*)
          115  +		   (ppl [stem "ed"]  *o*))
          116  +
          117  +(verb-form (es stem)
          118  +		   ; e.g. suck → sucking
          119  +		   (inf [stem]       *o*)
          120  +		   (prs [stem "es"]   *o*)
          121  +		   (ger [stem "ing"] *o*)
          122  +		   (adj [stem "ing"] *o*)
          123  +		   (pst [stem "ed"]  *o*)
          124  +		   (ppl [stem "ed"]  *o*))
          125  +
          126  +(verb-form (e stem)
          127  +		   ; e.g. vape → vaping
          128  +		   (inf [stem "e"]   *o*)
          129  +		   (prs [stem "es"]  *o*)
          130  +		   (ger [stem "ing"] *o*)
          131  +		   (adj [stem "ing"] *o*)
          132  +		   (pst [stem "ed"]  *o*)
          133  +		   (ppl [stem "ed"]  *o*))
          134  +
          135  +(verb-form (y stem)
          136  +		   ; e.g. try → trying
          137  +		   (inf [stem "y"]   *o*)
          138  +		   (prs [stem "ies"]  *o*)
          139  +		   (ger [stem "ing"] *o*)
          140  +		   (adj [stem "ing"] *o*)
          141  +		   (pst [stem "ed"]  *o*)
          142  +		   (ppl [stem "ed"]  *o*))
          143  +
          144  +(verb-form (heavy stem final)
          145  +		   ; e.g. plug → plugging
          146  +		   (inf [stem]             *o*)
          147  +		   (prs [stem "s"]         *o*)
          148  +		   (ger [stem final "ing"] *o*)
          149  +		   (adj [stem final "ing"] *o*)
          150  +		   (pst [stem final "ed"]  *o*)
          151  +		   (ppl [stem final "ed"]  *o*))
          152  +
          153  +(verb-form (strong stem ipst ippl)
          154  +		   ; e.g. drink → drank
          155  +		   (inf [stem]       *o*)
          156  +		   (prs [stem "s"]   *o*)
          157  +		   (ger [stem "ing"] *o*)
          158  +		   (adj [stem "ing"] *o*)
          159  +		   (pst [ipst]        *o*)
          160  +		   (ppl [ippl]        *o*))
          161  +
          162  +(verb-form (irregular iinf iprs iger ipst ippl)
          163  +		   ; e.g. have → has → had
          164  +		   (inf [iinf] *o*)
          165  +		   (prs [iprs] *o*)
          166  +		   (ger [iger] *o*)
          167  +		   (adj [iger] *o*)
          168  +		   (pst [ipst] *o*)
          169  +		   (ppl [ippl] *o*))
          170  +
          171  +(verb-form (strong! stem ipst)
          172  +		   ; e.g. shoot → shot → shot
          173  +		   (inf [stem]       *o*)
          174  +		   (prs [stem "s"]   *o*)
          175  +		   (ger [stem "ing"] *o*)
          176  +		   (adj [stem "ing"] *o*)
          177  +		   (pst [ipst]       *o*)
          178  +		   (ppl [ipst]       *o*))
          179  +