1 ! Copyright (C) 2015, 2018 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
3 USING: accessors arrays assocs combinators help.markup kernel
4 literals math math.order math.parser sequences splitting unicode
11 ! Irregular pluralizations
12 CONSTANT: singular-to-plural H{
15 { "alumnus" "alumni" }
17 { "octopus" "octopi" }
20 { "nucleus" "nuclei" }
22 { "stimulus" "stimuli" }
25 { "analysis" "analyses" }
29 { "diagnosis" "diagnoses" }
30 { "ellipsis" "ellipses" }
31 { "hypothesis" "hypotheses" }
33 { "paralysis" "paralyses" }
34 { "parenthesis" "parentheses" }
35 { "synopsis" "synopses" }
36 { "synthesis" "syntheses" }
40 { "appendix" "appendices" }
42 { "matrix" "matrices" }
46 { "bureau" "bureaus" }
47 { "tableau" "tableaux" }
50 { "child" "children" }
56 { "bacterium" "bacteria" }
57 { "corpus" "corpora" }
58 { "criterion" "criteria" }
59 { "curriculum" "curricula" }
63 { "memorandum" "memoranda" }
64 { "phenomenon" "phenomena" }
65 { "stratum" "strata" }
73 { "offspring" "offspring" }
76 { "species" "species" }
85 { "antenna" "antennae" }
86 { "formula" "formulae" }
87 { "nebula" "nebulae" }
88 { "vertebra" "vertebrae" }
97 CONSTANT: plural-to-singular $[ singular-to-plural [ swap ] assoc-map ]
99 :: match-case ( master disciple -- master' )
101 { [ master >lower master = ] [ disciple >lower ] }
102 { [ master >upper master = ] [ disciple >upper ] }
103 { [ master >title master = ] [ disciple >title ] }
109 : singularize ( word -- singular )
111 { [ dup empty? ] [ ] }
112 { [ dup singular-to-plural key? ] [ ] }
113 { [ plural-to-singular ?at ] [ ] }
114 { [ dup "s" tail? not ] [ ] }
118 last "aeiou" member? not
120 ] [ 3 head* "y" append ]
122 { [ dup "es" tail? ] [ 2 head* ] }
126 : pluralize ( word -- plural )
128 { [ dup empty? ] [ ] }
129 { [ dup plural-to-singular key? ] [ ] }
130 { [ singular-to-plural ?at ] [ ] }
134 last "aeiou" member? not
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" "aeiou" ?
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
178 : or-markup-example ( classes -- markup )
181 [ name>> ] keep \ $link
184 ] if swap 2array [ a/an " " append ] dip 2array
185 ] map "or" comma-list ;
187 : $or-markup-example ( classes -- )
188 or-markup-example print-element ;