1 ! Copyright (C) 2015, 2018 John Benediktsson
2 ! See https://factorcode.org/license.txt for BSD license
3 USING: arrays assocs combinators kernel literals math math.order
4 math.parser sequences splitting unicode ;
10 ! Irregular pluralizations
11 CONSTANT: singular-to-plural H{
14 { "alumnus" "alumni" }
16 { "octopus" "octopi" }
19 { "nucleus" "nuclei" }
21 { "stimulus" "stimuli" }
24 { "analysis" "analyses" }
28 { "diagnosis" "diagnoses" }
29 { "ellipsis" "ellipses" }
30 { "hypothesis" "hypotheses" }
32 { "paralysis" "paralyses" }
33 { "parenthesis" "parentheses" }
34 { "synopsis" "synopses" }
35 { "synthesis" "syntheses" }
39 { "appendix" "appendices" }
41 { "matrix" "matrices" }
45 { "bureau" "bureaus" }
46 { "tableau" "tableaux" }
49 { "child" "children" }
55 { "bacterium" "bacteria" }
56 { "corpus" "corpora" }
57 { "criterion" "criteria" }
58 { "curriculum" "curricula" }
62 { "memorandum" "memoranda" }
63 { "phenomenon" "phenomena" }
64 { "stratum" "strata" }
72 { "offspring" "offspring" }
75 { "species" "species" }
84 { "antenna" "antennae" }
85 { "formula" "formulae" }
86 { "nebula" "nebulae" }
87 { "vertebra" "vertebrae" }
96 CONSTANT: plural-to-singular $[ singular-to-plural [ swap ] assoc-map ]
98 :: match-case ( master disciple -- master' )
100 { [ master >lower master = ] [ disciple >lower ] }
101 { [ master >upper master = ] [ disciple >upper ] }
102 { [ master >title master = ] [ disciple >title ] }
108 CONSTANT: vowels "aeiou"
111 vowels member? ; inline
113 : singularize ( word -- singular )
115 { [ dup empty? ] [ ] }
116 { [ dup singular-to-plural key? ] [ ] }
117 { [ plural-to-singular ?at ] [ ] }
118 { [ dup "s" tail? not ] [ ] }
121 dup "ies" ?tail [ last vowel? not ] [ drop f ] if
122 ] [ 3 head* "y" append ]
124 { [ dup "es" tail? ] [ 2 head* ] }
128 : pluralize ( word -- plural )
130 { [ dup empty? ] [ ] }
131 { [ dup plural-to-singular key? ] [ ] }
132 { [ singular-to-plural ?at ] [ ] }
135 dup "y" ?tail [ last vowel? not ] [ drop f ] if
136 ] [ but-last "ies" append ]
139 [ dup { "s" "ch" "sh" } [ tail? ] with any? ]
140 [ dup "es" tail? [ "es" append ] unless ]
145 : singular? ( word -- ? )
146 [ singularize ] [ = ] bi ;
148 : plural? ( word -- ? )
149 [ singularize pluralize ] [ = ] bi ;
151 : ?pluralize ( count singular -- singular/plural )
152 swap 1 = [ pluralize ] unless ;
154 : count-of-things ( count word -- str )
155 dupd ?pluralize [ number>string ] dip " " glue ;
157 : a10n ( word -- numeronym )
159 [ 1 head ] [ length 2 - number>string ] [ 1 tail* ] tri
163 : a/an ( word -- article )
164 [ first ] [ length ] bi 1 = "afhilmnorsx" vowels ?
167 : ?plural-article ( word -- article )
168 dup singular? [ a/an ] [ drop "the" ] if ;
170 : comma-list ( parts conjunction -- clause-seq )
172 [ length dup 1 [-] + ", " <array> ]
173 [ [ 2 * pick set-nth ] each-index ] bi
174 ] dip over length dup 3 >= [
175 [ 3 > ", " " " ? " " surround ] [ 2 - pick set-nth ] bi