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())