basis/english/english.factor

   1 ! Copyright (C) 2015, 2018 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: accessors arrays assocs assocs.extras combinators
   4 help.markup kernel literals locals math math.parser sequences
   5 sequences.extras splitting unicode words ;
   6
   7 IN: english
   8
   9 <PRIVATE
  10
  11 <<
  12 ! Irregular pluralizations
  13 CONSTANT: singular-to-plural H{
  14
  15     ! us -> i
  16     { "alumnus" "alumni" }
  17     { "cactus" "cacti" }
  18     { "octopus" "octopi" }
  19     { "focus" "foci" }
  20     { "fungus" "fungi" }
  21     { "nucleus" "nuclei" }
  22     { "radius" "radii" }
  23     { "stimulus" "stimuli" }
  24
  25     ! is -> es
  26     { "analysis" "analyses" }
  27     { "axis" "axes" }
  28     { "basis" "bases" }
  29     { "crisis" "crises" }
  30     { "diagnosis" "diagnoses" }
  31     { "ellipsis" "ellipses" }
  32     { "hypothesis" "hypotheses" }
  33     { "oasis" "oases" }
  34     { "paralysis" "paralyses" }
  35     { "parenthesis" "parentheses" }
  36     { "synopsis" "synopses" }
  37     { "synthesis" "syntheses" }
  38     { "thesis" "theses" }
  39
  40     ! ix -> ices
  41     { "appendix" "appendices" }
  42     { "index" "indices" }
  43     { "matrix" "matrices" }
  44
  45     ! eau -> eaux
  46     { "beau" "beaux" }
  47     { "bureau" "bureaus" }
  48     { "tableau" "tableaux" }
  49
  50     ! ? -> en
  51     { "child" "children" }
  52     { "man" "men" }
  53     { "ox" "oxen" }
  54     { "woman" "women" }
  55
  56     ! ? -> a
  57     { "bacterium" "bacteria" }
  58     { "corpus" "corpora" }
  59     { "criterion" "criteria" }
  60     { "curriculum" "curricula" }
  61     { "datum" "data" }
  62     { "genus" "genera" }
  63     { "medium" "media" }
  64     { "memorandum" "memoranda" }
  65     { "phenomenon" "phenomena" }
  66     { "stratum" "strata" }
  67
  68     ! no change
  69     { "bison" "bison" }
  70     { "deer" "deer" }
  71     { "fish" "fish" }
  72     { "means" "means" }
  73     { "moose" "moose" }
  74     { "offspring" "offspring" }
  75     { "series" "series" }
  76     { "sheep" "sheep" }
  77     { "species" "species" }
  78     { "swine" "swine" }
  79
  80     ! oo -> ee
  81     { "foot" "feet" }
  82     { "goose" "geese" }
  83     { "tooth" "teeth" }
  84
  85     ! a -> ae
  86     { "antenna" "antennae" }
  87     { "formula" "formulae" }
  88     { "nebula" "nebulae" }
  89     { "vertebra" "vertebrae" }
  90     { "vita" "vitae" }
  91
  92     ! ouse -> ice
  93     { "louse" "lice" }
  94     { "mouse" "mice" }
  95 }
  96 >>
  97
  98 CONSTANT: plural-to-singular $[ singular-to-plural assoc-invert ]
  99
 100 :: match-case ( master disciple -- master' )
 101     {
 102         { [ master >lower master = ] [ disciple >lower ] }
 103         { [ master >upper master = ] [ disciple >upper ] }
 104         { [ master >title master = ] [ disciple >title ] }
 105         [ disciple ]
 106     } cond ;
 107
 108 PRIVATE>
 109
 110 : singularize ( word -- singular )
 111     dup >lower {
 112         { [ dup empty? ] [ ] }
 113         { [ dup singular-to-plural key? ] [ ] }
 114         { [ plural-to-singular ?at ] [ ] }
 115         { [ dup "s" tail? not ] [ ] }
 116         {
 117             [
 118                 dup "ies" ?tail [
 119                     last "aeiou" member? not
 120                 ] [ drop f ] if
 121             ] [ 3 head* "y" append ]
 122         }
 123         { [ dup "es" tail? ] [ 2 head* ] }
 124         [ but-last ]
 125     } cond match-case ;
 126
 127 : pluralize ( word -- plural )
 128     dup >lower {
 129         { [ dup empty? ] [ ] }
 130         { [ dup plural-to-singular key? ] [ ] }
 131         { [ singular-to-plural ?at ] [ ] }
 132         {
 133             [
 134                 dup "y" ?tail [
 135                     last "aeiou" member? not
 136                 ] [ drop f ] if
 137             ] [ but-last "ies" append ]
 138         }
 139         {
 140             [ dup { "s" "ch" "sh" } [ tail? ] with any? ]
 141             [ dup "es" tail? [ "es" append ] unless ]
 142         }
 143         [ "s" append ]
 144     } cond match-case ;
 145
 146 : singular? ( word -- ? )
 147     [ singularize ] [ = ] bi ;
 148
 149 : plural? ( word -- ? )
 150     [ singularize pluralize ] [ = ] bi ;
 151
 152 : ?pluralize ( count singular -- singular/plural )
 153     swap 1 = [ pluralize ] unless ;
 154
 155 : count-of-things ( count word -- str )
 156     dupd ?pluralize [ number>string ] dip " " glue ;
 157
 158 : a10n ( word -- numeronym )
 159     dup length 3 > [
 160         [ 1 head ] [ length 2 - number>string ] [ 1 tail* ] tri
 161         3append
 162     ] when ;
 163
 164 : a/an ( word -- article )
 165     [ first ] [ length ] bi 1 = "afhilmnorsx" "aeiou" ?
 166     member? "an" "a" ? ;
 167
 168 : ?plural-article ( word -- article )
 169     dup singular? [ a/an ] [ drop "the" ] if ;
 170
 171 : comma-list ( parts conjunction  -- clause-seq )
 172     [ ", " join-with ] dip over length dup 3 >= [
 173         [ 3 > ", " " " ? " " surround ] [ 2 - pick set-nth ] bi
 174     ] [ 2drop ] if ;
 175
 176 : or-markup-example ( classes -- markup )
 177     [
 178         dup word? [
 179             [ name>> ] keep \ $link
 180         ] [
 181             dup \ $snippet
 182         ] if swap 2array [ a/an " " append ] dip 2array
 183     ] map "or" comma-list ;
 184
 185 : $or-markup-example ( classes -- )
 186     or-markup-example print-element ;