Overview
| Comment: | add libs |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA3-256: |
6822b7d0064a762c083ccd9a57ee760a |
| 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 +