type word = R of string | I of string * string
type apos = Obs | Size | Attrib | Shape | Age | Mid | Color | Origin | Material | Qual
let order adj = match (let _,a = adj in a) with
	| Obs -> 0 | Size -> 1 | Attrib -> 2 | Shape -> 3 | Age -> 4
	| Mid -> 5 | Color -> 6 | Origin -> 7 | Material -> 8 | Qual -> 9
type adj = string * apos
let adjs : adj array = [|
	"Sanctified", Obs; "Blasphemous", Obs; "Red", Color; "Yellow", Color;
	"Ebon", Color; "Ochre", Color; "Eternal", Age; "Perpetual", Age;
	"Everlasting", Age; "Black", Color; "White", Color; "Mad", Obs;
	"Infinite", Attrib; "Timeless", Age;  "Terrible", Obs; "Sightless", Obs;
	"All-Seeing", Mid; "Third", Obs;  "Second", Obs;  "Endless", Obs;
	"Reviled", Obs; "Absolute", Obs; "Damned", Obs; "Cursed", Obs;
	"Blessed", Obs; "Lucid", Obs; "Unthinkable", Obs; "Nameless", Obs;
	"Unspeakable", Obs; "Glorious", Obs; "Cold", Obs; "Burning", Obs;
	"Shapeless", Shape;  "Formless", Shape; "Unknowable", Obs; "Lifeless", Obs;
	"Fatal", Attrib; "Infernal", Origin; "Abyssal", Origin; "Celestial", Origin;
	"Implacable", Obs; "Dark", Color; "Resolute", Obs; "Resplendant", Color;
	"Unstoppable", Obs; "Blood-Soaked", Material; "Endless", Size;
	"Forgotten", Obs; "Iron", Material; "Bronze", Material; "Steel", Material;
	"Secret", Obs; "Hidden", Obs; "Fiery", Color; "Ancient", Age;
	"Silver", Material; "Silver", Color; "Screaming", Mid; "Mighty", Mid;
	"Thousand-Year", Qual; "Jewelled", Material; "Damnable", Mid; 
	"Creeping", Mid; "All-Knowing", Mid; "All-Hearing", Mid; "Holy", Mid;
	"Global", Mid; "Leering", Mid; "Forty-Second", Obs; "Divine", Mid;
	"Faithful", Mid; "Ageless", Age; "Steadfast", Attrib; "Cruel", Attrib;
	"Sapphire", Material; "Sapphic", Origin; "Secluded", Mid; "Scarlet", Color;
	"Shrieking", Mid; "Hollow", Mid; "Mild", Mid; "Wondrous", Obs;
|]
let subjects = [|
	"Order"; "Cult"; "Temple"; "Church"; "Hand"; "Eyes";
	"Source"; "Keepers"; "Maidens"; "Servants"; "Templars";
	"Followers"; "Celebrants"; "Rite"; "Sect"; "Guild";
	"Society"; "School"; "Gathering"; "Bearers"; "Guardians";
	
|]
let definite_objects = [|
	"Prince"; "King"; "Master"; "Princess"; "Queen"; "Mistress";
	"Devourer"; "Obliterator"; "Destroyer"; "Portal";
	"Serpent"; "Moon"; "One"; "Two"; "Three"; "Four";
	"Five"; "Six"; "Seven"; "Eight"; "Nine"; "Ten"; "Twelve";
	"Eye"; "God"; "Horror"; "Thing"; "Flames"; "Night"; "Day";
	"Year"; "Years"; "Way"; "Realm"; "Path"; "Light"; "Fire";
	"Door"; "Gate"; "Plan"; "Terror"; "Staff"; "Window";
	"Road"; "Spire"; "Beast"; "Flesh"; "Sword"; "Mountain";
	"River";"Crown";"Scepter"; "Desecrator";"Defiler";
	"Despoiler"; "Ravager"; "Rite"; "Sea"; "Ocean"; "Chaos";
	"Goat"; "Legion"; "Pyramid"; "Dragon"; "Hand"; "Pantheon";
	"Spirit"; "Devil"; "Gods"; "Rod"; "Glitch"; "Error";
	"Perversion";
|]
let zero_objects = [|
	"Doom"; "Death"; "Torment"; "Fires"; "Pain"; "Screams";
	"Fear"; "Terror"; "Whispers"; "Failure"; "Perversion";
|]

let pick (r : 'a array) : 'a = r.(Random.int(Array.length r))
let picks (r : ('b * ('a array)) list) : ('b * 'a) =
	let sum = List.fold_left (fun c (_,a) -> c + Array.length a) 0 r in
	let id = Random.int sum in
	let rec find i (l : (bool * ('a array)) list) =
		match l with (tag,a)::tl ->
		let sz = Array.length a in
			if sz > i then (tag, a.(i))
			else find (i-sz) tl
		| _ -> assert false
	in find id r;;
	
let adjp () =
	let flatten l = List.fold_left (fun a (s,_) -> a ^ " " ^ s) "" l in
	let rec pos adj (phr : adj list) =
		if (phr = []) then [adj]
		else if (order adj) > order (List.hd phr) then
			(List.hd phr) :: (pos adj (List.tl phr))
		else adj :: (List.tl phr)
	in let rec loop phr ct =
		if ct = 0 then pos (pick adjs) phr
		else loop (pos (pick adjs) phr) (ct-1)
	in flatten (loop [] (Random.int 4));;
	
let objp () = picks [(true, definite_objects); (false, zero_objects)]
let sect () = let a = adjp() in
	let a' = adjp() in
	let def,o = objp() in
	match Random.int 7 with		(* haaack *)
		| 0 -> "The " ^ (pick subjects) ^ " of the " ^ (let a,_ = pick adjs in a)
		| 1 -> "The " ^ (pick subjects) ^ " of " ^ (if def then "the " else "") ^ o
		| 2 -> "The" ^ a' ^ " " ^ (pick subjects) ^ " of " ^ (if def then "the " else "") ^ o
		| 3 -> "The" ^ a' ^ " " ^ (pick subjects) ^ " of the " ^ (let a,_ = pick adjs in a)
		| _ ->  "The" ^ a' ^ " " ^ (pick subjects) ^ " of" ^ (if def then " the" else "") ^ a ^ " " ^ o
		
let () = Random.self_init ();
	print_string (sect())
