procgen  cclg.ml at trunk

File cclg.ml artifact 1db4eea4b2 on branch trunk


type word = A of string | An of string
type root = Edy of word | Xy of word | Ation of word | Le of word | A of word | Cy of word
	| Rous of word | Ics of word | Ics2 of word | Sis of word | X of word | Ality of word | Ty of word
	| Ication of word | Tion of word | Arity of word | Sm of word | Ine of word
type prefix = Inv of word | Vf of word * string
let prefixes = [|
	Vf(A "mult","i"); Inv (A "pre"); Vf(An "ex","o"); Vf(A "retr","o");
	Inv (A "hyper"); Vf(A "hem","i"); Inv (A "eu"); Vf(A "par","a");
	Vf(A "gastr","o"); Vf(A "bell","i"); Inv (An "an"); Vf(A "mes","o");
	Vf(A "therm","o"); Vf(A "copr","o"); Vf(A "pleb","i"); Vf(An "ant","i");
	Vf(A "pseud","o"); Vf(A "quas", "i"); Vf(A "crypt","o"); Vf(A "bronch","o");
	Vf(A "hydr","o"); Vf(A "psych","o"); Vf(A "tel","e"); Vf(An "arachn","o");
	Vf(A "nyct","o"); Inv(A "dys"); Inv(A "mis"); Vf(A "mis","o"); Vf(A "the","o");
	Vf(A "terr","a"); Vf(An "astr","a"); Vf(An "astr","o"); Vf(An "archae","o");
	Vf(An "erot","o"); Vf(A "proct","o"); Vf(An "atm","o"); Vf(A "strat","o");
	Inv(A "geo"); Vf(An "omn","i"); Inv(A "poly"); Vf(A "malign","o");
	Vf(A "micr","o"); Vf(A "macr","o"); Vf(A "nan","o"); Vf(A "femt","o");
	Vf(A "kil","o"); Vf(A "pet","a"); Inv(A "tri"); Vf(A "tetr","a");
	Vf(A "yoct","o"); Vf(A "meg","a"); Vf(A "un","i"); Inv(A "bi"); Vf(A "dec","a");
	Vf(A "pent","a"); Inv(An "endo"); Vf(An "electr","o"); Vf(A "pat","a");
	Vf(A "hem","o"); Inv(An "arch"); Vf(A "mesm","o");  Vf(A "card","io");
	Vf(A "necr","o"); Inv(An "un"); Vf(An "ultr","a"); Inv(A "trans");
	Inv(A "post"); Inv(A "sub"); Inv(A "pro"); Vf(A "ben","e"); Inv(An "ab");
	Inv(An "inter"); Vf(An "intr","a"); Inv(A "non"); Inv(A "counter");
	Vf(A "contr","a"); Vf(A "path","o"); Vf(A "phon","o"); Inv(A "pan");
	Vf(A "zo","o"); Vf(A "chron","o"); Inv(A "re"); Inv(A "con"); Vf(A "volcan","o");
	Inv(A "tech"); Vf(A "plasm","o"); Vf(A "megal","o"); Inv(A "cyber"); 
	Vf(A "met","a"); Inv(A "neo"); Vf(An "ocul","o"); Vf(A "strangul","o");
	Vf(A "dendr","o"); Vf(A "matr","i"); Vf(A "patr","i"); Vf(A "lesb","o");
	Vf(A "hom","o"); Vf(A "heter","o"); Vf(A "prot","o"); Vf(An "ect","o");
	Vf(A "weeb","o"); Vf(A "fung","i"); Vf(A "per","i"); Vf(A "petr","i");
	Vf(A "sad","o"); Vf(A "femin","i"); Vf(A "mascul","o"); Vf(A "claustr","o");
    Vf(A "neur","o"); Vf(A "norm","o"); Inv (A "eu"); Vf(A "sten","o");
    Vf(A "stegan","o"); Vf(A "rhod", "o");

	Vf(An "agor","a"); Vf(A "thanat","o"); Vf(A "vagin","o"); Vf(A "bi","o"); 
	Vf(A "blog","o"); Vf(A "prometh","eo"); Vf(An "anesthes", "io");
    Vf(A "din","o"); Vf(A "medic","o");
|]

let roots = [|
	Edy (A "com");
	Edy (A "trag");
	Xy (A "gala");
	Ation (A "lact");
	Le (A "mirac");
	Rous (A "fib");
	A (An "arcan");
	Cy (A "poli");
	Ty (A "poli");
	Ics (A "polit");
	Ics (A "mathemat");
	Ics2 (A "memet");
	Sis (A "mime");
	Ics (A "linguist");
	Ics2 (A "linguist");
	Ics2 (A "therm");
	Ics (A "cosmet");
	Ics (A "anesthet");
	Ics (A "techn");
	Sis (A "synthe");
	X (An "appendi");
	Ication (A "prognost");
	Ality (A "lachrym");
	Tion (A "prohibi");
	Ation (A "not");
	Ality (A "lingu");
	Arity (A "pulmon");
	Sis (A "sta");
	Sis (A "kine");
	Ality (A "lexic");
	Ality (A "mort");
	Ation (A "gener");
	Ality (A "nocturn");
	Cy (A "delica");
	Ation (A "masturb");
	Sm (An "orga");
	Sm (A "cla");
	Cy (A "malignan");
	Tion (A "func");
	Ics (A "dialect");
	Ics (A "pedant");
	Ation (A "form");
	Ation (A "dict");
	Tion (A "construc");
	Tion (A "trac");
	Tion (A "cep");
	Ation (A "port");
	Tion (A "scrip");
	Tion (A "junc");
	Ation (A "spir");
	Ation (A "coloniz");
	Ation (A "fornic");
	Ics (A "disastr");
	Ics (A "theatr");
	Ality (A "sexu");
	Ation (A "transl");
	Sm (A "sadi");
	Sm (A "masochi");
	Ation (An "ejacul");
	Ation (A "jacul");
	Ality (A "vagin");
	Ality (A "mystic");
	Sm (A "mystici");
	Ty (A "normativi");
	Ality (A "norm");
	Ality (A "typic");
	Xy (A "do");
	Ality (A "leg");
	Sm (A "legali");
	Ation (A "leg");
	A (A "pragmat");
	A (A "stigmat");
	Ine (A "rhadamanth");
|]

let nsuffixes = [|
	An "ite";
	An "ate";
	An "itis";
	A "sis";
	A "rrhea";
	A "tion";
	An "icon";
	A "phoria";
	A "cide";
	An "ology";
	An "ologics";
	An "ologer";
	An "ologist";
	A "phobia";
	A "sphere";
	A "spherics";
	A "gon";
	A "tron";
	A "metry";
	A "meter";
	A "noia";
	A "noiac";
	A "noid";
	A "cracy";
	A "crat";
	A "mancy";
	An "ism";
	An "ist";
	An "ary";
	An "ory";
	A "scope";
	A "jection";
	A "mission";
	A "ception";
	A "ceptor";
	An "arch";
	An "archy";
	A "turbation";
	A "turbator";
	A "plasm";
	A "mania";
	A "maniac";
	A "dendron";
	A "gasm";
	A "philia";
	A "philiac";
	A "phile";
	A "sexuality";
	A "romance";
	A "net";
	An "ium";
    A "saur";
    An "odon";
    A "normativity";
    A "typicality";
    A "doxy";
|]
let adjsuffixes = [|
	An "itic";
	An "ose";
	An "id";
	A "tic";
	A "rrheic";
	A "tive";
	An "iconic";
	A "phoric";
	A "cidal";
	An "ologic";
	An "ological";
	An "ologistic";
	A "phobic";
	A "spheric";
	A "gonal";
	A "tronic";
	A "metric";
	A "metrical";
	A "noiac";
	A "noid";
	A "cratic";
	A "mantic";
	An "ist";
	An "istic";
	An "ismic";
	An "ismatic";
	A "scopic";
	A "ject";
	A "jective";
	A "missive";
	A "ceptive";
	An "archic";
	A "turbatory";
	A "plasmic";
	A "plastic";
	A "manic";
	A "maniacal";
	An "ish";
	A "dendrite";
	A "gasmic";
	A "philic";
	A "sexual";
	A "romantic";
	A "legal";
	A "normative";
	A "typical";
|]
let (^^) w s = match w with
	An x -> An (x^s) | A x -> A (x^s);;
let pick (r : 'a array) : 'a = r.(Random.int(Array.length r))
let chance i = (Random.int i) = 0
let cform root = match root with
	| Edy x -> x^^"edo" | Xy x -> x^^"cto" | Ation x -> x^^"o"
	| Rous x -> x^^"ro" | Le x -> x^^"ulo" | A x -> x^^"o"
	| Cy x -> x^^"tico" | Ics x | Ics2 x -> x^^(if chance 2 then "i" else "o")
	| Sis x -> x^^"to" | Ine x -> x^^"o"
	| X x -> x^^"co" | Ality x -> x^^"o" | Ty x -> x^^"to"
	| Ication x -> x^^"o" | Tion x -> x^^"to" | Arity x -> x^^"a"
	| Sm x -> x^^(if chance 2 then "smo" else "sto")
let bareform root = match root with
	| Edy x -> (if chance 2 then x else x^^"ed") | Xy x -> x^^"ct" | Ation x -> x
	| Rous x -> x^^"r" | Le x -> x^^"ul" | A x -> x
	| Cy x -> x^^"tic" | Ics x -> x^^"ic" | Ics2 x -> x | Sis x -> x^^"t"
	| X x -> x^^"c" | Ality x -> x | Ty x -> x^^"t"
	| Ication x -> x | Tion x -> x^^"t" | Arity x -> x
	| Sm x -> x^^"st" | Ine x -> x
let adjform root = match root with
	| Edy x -> x^^"ic" | Xy x -> x^^"ctic" | Ation x -> x^^"ic"
	| Rous x -> x^^"rous" | Le x -> x^^"ulous" | A x -> x^^"e"
	| Cy x -> x^^"tical" | Ics x -> x^^"ical" | Ics2 x -> x^^"ic" | Sis x -> x^^"tic"
	| X x -> x^^"cal" | Ality x -> x^^"al" | Ty x -> x^^"tical"
	| Ication x -> x^^(if chance 3 then "itious" else "icate")
	| Tion x -> x^^(match Random.int 4 with
		| 0 -> "tive" | 1 -> "ted" | 2 -> "cious" | 3 -> "tory" | _ -> assert false)
	| Arity x -> x^^"ary" | Sm x -> x^^(if chance 2 then "stic" else "smic")
    | Ine x -> x^^"ine"
let nform root = if chance 7 then (adjform root) ^^ "ness" else match root with
	| Edy x -> x^^"edy" | Xy x -> x^^"xy" | Ation x -> x^^(if chance 3 then "itor" else "ation")
	| Rous x -> x^^"er" | Le x -> x^^"le" | A x -> x^^"a"
	| Cy x -> x^^"cy" | Ics x -> x^^(if chance 3 then "ician" else "ics") | Sis x -> x^^"sis"
	| Ics2 x -> x^^(if chance 3 then "ician" else "ics")
	| X x -> x^^"x" | Ality x -> x^^"ality" | Ty x -> x^^"ty"
	| Ication x -> x^^"ication" | Tion x -> x^^"tion" | Arity x -> x^^"arity"
	| Sm x -> x^^(if chance 2 then "st" else "sm") | Ine x -> x
let abs (w:word) = match w with A x | An x -> x
let append pref w = match pref with
		| Inv x -> x ^^ (abs w)
		| Vf(body,v) ->	 match w with
			| An x -> body^^x
			| A x -> (body^^v)^^x
let rec word () : word = match Random.int 7 with
	| 0 -> nform (pick roots)
	| 1 -> (match pick nsuffixes with
		| An x -> (bareform (pick roots)) ^^ x
		| A x -> (cform (pick roots)) ^^ x)
	| 2 -> ((adjform (pick roots)) ^^ " ") ^^ (abs(word ()))
	| 3 -> ((match pick adjsuffixes with
		| An x -> (bareform (pick roots)) ^^ x
		| A x -> (cform (pick roots)) ^^ x) ^^ " ") ^^ (abs(word ()))
	| 4 -> append (pick prefixes) (word ())
	| 5 -> append (pick prefixes) (pick nsuffixes)
	| 6 -> ((append (pick prefixes) (pick adjsuffixes)) ^^ " ") ^^ (abs (word()))
	| _ -> assert false
let () = Random.self_init (); print_string (abs (word ())); ()