What: Gaming Generators in Tcl Description: A program for generating text description and sound-alike wordlists given syntactical or examplary input. A useful technique for [Procedural Generation|http://en.wikipedia.org/wiki/Procedural_generation ] to store a lot of content in little space. See also [Procedural Generation Wiki|http://pcg.wikidot.com/ ].
Many people are familiar with [MadLibs|http://en.wikipedia.org/wiki/Mad_Libs ] which generate funny stories given set syntactical elements such as "insulting adjective" or "odd activity". These are actually a subset of much more powerful Generators or the type that are useful in Gaming -- both [pencil and paper|http://www.seventhsanctum.com/ ] and in computers with [Procedural Generation Wiki|http://pcg.wikidot.com/ ].
Tcl is ideally suited to this as it is essentially a macro language designed for text substitution. Unfortunately, Tcl has built-in recursion limits|interp recursionlimit which you need to adjust or use a Non-Recursive Interpreter Engine|NRE to circumvent. Because of this, I actually implemented a little language to do the job with a non-recursive engine in Tcl. I also combined this with the Markov Chains from Create words from a text file (list) to generate sound-alike words for names and the like. The resulting system is very useful.
Essentially, you define a series of tables, where each table has a list of potential replacements chosen at random, each of which may include references to the same or another table.
table first second third result { {Use the <table> table.>} }
This is two tables, the second of which has only one choice (hence the double brackets -- anything with embedded spaces will need brackets). Evaluating: <result> might give you: "Use the third table." Another evaluation might give the same, or one of the alternatives.
This in itself is not so interesting, the fun part comes in when you start combining productions and nesting tables very deeply. Here is an insult generator written using this same system:
insultadj {
aberrant abhorrent abject abnormal abominable abrupt absurd abusive acerebral addled addlepated afflictive agelastic aggressive agonizing airheaded anarcho-syndicalist anchronistic angry annoying antiquated apish appalling arrogant artless assinine atrocious audacious avaricious awful babbling back-biting back-handed back-stabbing backward bald baleful balmy banal baneful barbaric barbarous barmy barnacled base base-court bat-fowling batty bawdy beastly bedevilled beef-brained beef-witted beer-swilling beetle-headed beetleheaded befooled beggerly beguiled belligerent belly-aching benighted beslubbering besotted bestial bewildered bilgey bilious bitter black black-hearted blameable blameworthy blaspheming blasted bleak blear-eyed blear-witted bleeding blinkered blistered blithering block blockheaded blockish bloodthirsty bloody-minded blundering boastful Boeotian boil-brained boneheaded boorish bootlegging bootless boring born bottom-of-the-barrel bovine bragging brainless brazen bribable brutal brutalized brutalizing brute brutish buffoonish bullying bumptious bullheaded burdensome cage-rattling calculating calumnious cankerous cannibalistic cantankerous capricious careless catty cave-crawling cave-dwelling charmless cheap cheating cheeky cheesy chicken-hearted chuckleheaded chumpish churlish clabber-brained clammy clapper-clawed clay-brained clod cloddish close-minded clot clouted cluck clumsy coarse cockamamie cockered cockeyed cocky cold common-kissing conceited congenital conniving contemptible contemptuous contrary contumelious corrupt cotton-picking couthless cowardly cowish crafty crass craven crawling crazy credulous creeping creepy cretinous criminal critical crook-pated crude cruel crummy crying cuckoo culpable cunning currish cursed cusswocomplaining cynical daffy daft damnable damned dankish dark dazed deadbeat debased debauched deceitful decrepit defaulting defective deficient degraded degrading deleterious delinquent demoniacal demonic dense deplorable depraved depressing derelict derisive derogatory desolate desperate despicable detestable deviant devilish devoid diabolical dilapidated dim dim-witted dimwit dimwitted dingbat dingy dire dirty dirty-rotten disappointing discontented discreditable discredited disgraceful disgusting dishonest disloyal dismal dismal-dreaming disobliging disparaging displeasing disreputable dissembling distasteful distressing dizzy dizzy-eyed dodgy doghearted dogmatic dolt doltish donkey dope dopey dorky doting dozy drab draconian dread-bolted dreadful dreary droning drooling drunken dubious dull dull-witted dullard dullhead dumb dumbbell dummkopf dummy dunce duncical duncish dunderheaded dweebish dysfunctional earth-vexing egg-sucking egregious elf-skinned empty-headed erinaceous errant erratic eructating evil evil-smelling exasperating excessive excoriating excruciating execrable exhausting expendable false fat fat-kidneyed fatheaded fatuitous fatuous fault-finding fawning fear-mongering feckless feculent feeble feeble-minded fell felonious fen-sucked feral ferine ferocious festering fetid fickle fiendish fifth-rate filthy fishy flagitious flagrant flakey flaky flap-mouthed flat-beer-drinking flat-lined flea-bitten flea-ridden flint-chipping fly-bitten fobbing folly-fallen fool-born foolhardy foolheaded foolish forgetful forgettable forlorn forward foul foul-tongued fourth-rate freakish freaky french-blabbing frightening frightful frivolous frothy frog-eating froward frustrated fuddled full-gorged fuming futile gaga geeky genocidal ghastly gimlet-eyed glaring gleeking glib gnawing goatish goblinoid god-cursed golem good-for-nothing goofy goosey gorbellied gormless gossiping gowk greedy grevous grim griping grisly gross grotesque grotty grovelling grudging gruesome grumpy guff-spewing gulled gutless guts-gripin hadean half-assed half-baked half-faced half-wit half-witted halitotic hard harebrained harmful harrowing harsh hasty-witted hateful heartless hedge-born heinous hell-hated hellish heretical hideous high-maintenance ho-hum honeyfugling horrendous horrible horrid horrific horrifying hubristic humdrum humiliating hurtful hyperbolic hypocritical icky idiot idiotic idle-headed ignoble ignominious ignoramus ignorant ill-advised ill-bred ill-humored ill-informed ill-nurtured illegal illegitimate illiterate imbecile imbecilic immature immoral impertinent impotent improbable improper impudent impure inaccurate inane inaniloquent inappropriate inarticulate inauspicious incapable incompetent incomprehensible inconceivable incorrect incorrigible incredible indecorous indefensible indiscreet indolent ineducable ineffectual inept inexcusable inexpressable infamous infantile infatuated infectious inferior infernal inglorious inhospitable inhuman inhumane iniquitous initiativeless insalubrious insane insensate insensitive insignificant insincere insipid insolent insufferable insulting intolerable intolerant irrational irrelevant irresponsible jarring jealous jejune jerky jobbernowl judgemental juggins jumped-up kleptomaniacal klutzy knavish knee-knocking knockkneed knotty-pated knuckle-dragging kooky lackwit lame lamebrain lamentable laughable lazy learing left-handed leprous libelous lickspittle lightweight lily-livered listless loathsome loggerheaded looby loon loony lousy low low-born low-down ludicrous lugubrious lumbering lumpen lumpish lurid lying macabre mad malarious maleficent malevolent malicious malign malignant malingering maloderous mammering mangled mangy manipulative manky maudlin mean measily megalomaniacal mendacious mephitic merciless mewling microcephalic mildewed milk-livered mindless misbegotten miserable miserly misogynistic misshapen mollycoddled mongoloid monotonous monstrous morbid moribund moron moronic motley motley-minded mouldering mundane murderous mutinous naffy namby-pamby narcoleptic nasty nattering natural natural-born naughty nauseating nefarious neglectful negligent niais nincompoop ninny ninnyhammer nit-picking nitwit no-account no-good noddy noisome nonsensical notorious nugatory numskulled nutty oafish obnoxious obscene obstreperous obtrusive obtuse odious off-base off-color off-putting offensive onerous onion-eyed opaque opprobrious orcish outrageous over-bearing over-weening painful paltry paranoid paroxysmal pasty-faced pathetic paunchy peccant perverted pestilential petty petty-fogging petulant philistine piercing pinhead piratical pishy pitiable pitiful pitiless plume-plucked plundering pokey poor porcine possessed pottle-deep powerless pox-marked poxy predictable preposterous presuming presumptuous pretentious prevaricating pribbling prickly prideful primitive procrastinating profane prosaic proud puerile puking puling pungent puny pushy pusillanimous pustulent putrid quailing racking rambunctious rancid rancorous rank ranting ratty recreant reeky reeling-ripe regrettable renownless repetitive reprehensible reproachful reprobate reptilian repugnant repulsive resentful retarded revolting ridiculous risible rock-headed roguish rotten rough rough-hewn rude rude-growing rummy ruthless ruttish sacrilegious sad sadistic sappy satanic saucy savage scabby scabrous scandal-mongering scandalous scatterbrained scheming schlocky scrawny screwy scrubby scruffy scummy scurrile scurrilous scurvy second-rate self-absorbed selfish senseless sentimental septic severe sewer-crawling shabby shallow shameful shameless shard-borne sharkish sheep-biting shiftless shifty shocking shoddy sickening silly simp simple simpleton simplistic sinful sinister skanky slack-jawed slandering slavering slimey slinking slobbering slothful slovenly slow slow-witted sluggish slum-born sly small smirking smutty sneaking snearing snooty snotty snotty-faced soiled sophomoric sordid sorry sottish spasmatic spineless spivy spleeny spoiled spongy spotty spur-gall spurious squalid squandering stabbing sticky-fingered stinging stingy stinking stolid stoney strange stubborn stumbling stupid subhuman subnormal sun-burned superficial surly swabby swag-bellied sweaty swindling swinish syphilitic tacitern tardy-gaited tarnished tasteless tedious terrible testudineous thick thick-skulled thick-witted thickheaded thickwit thieving third-rate thoughtless tickle-brained timid tiresome toad-spotted tormenting torpid tortuous tottering toxic tragic traitorous treacherous trouble-making truculent twerpy two-faced two-timing ugly ump-fed unappreciative unbearable unbelievable unchristian uncivilized unclean uncomely unconvincing uncouth underhanded undue unenlightened unfit unfitting unfocused unforgivable unforgiving ungentle ungrateful unimaginative uninspired unintelligent uninteresting unjust unkempt unlawful unlikely unmentionable unmuzzled unpardonable unpleasant unprincipled unrealistic unreasonable unreliable unrighteous unruly unsanitary unsavoury unscrupulous unseemly unsound unspeakable unsuitable untamed unteachable unthinking untrustworthy unvirtuous unwarranted unworthy uppish uppity urchin-snouted uremic useless vacuous vain vainglorious vapid varicose venal venomed venomous vicious vile villainous vindictive violent virtueless vitriolic vituperative vomitous vulgar vulpine wacky warped wasteful wayward weak-minded weather-bitten weedy weeping weevil-crunching weird wet whining whore-mongering wicked widdiful wild wimpish witless witling wobbly woeful woggish wolfish worm-eaten worst worthless wretched wrong wrongful wrongheaded yeasty yellow-bellied zany
}
insultnoun {
addlepate affliction airhead anarcho-syndicalist apple-john back-stabber baggage bane barnacle barbarian beatnik biddy bimbo bird-brain bladder blatherskite blockhead boar-pig bollock bonehead boob boor bounder bow-wow braggart broad brute budgerigar buffoon bugbear bully bum-bailey bungler bushwhacker cad canine canker-blossom castigating caveman chicken clack-dish clod clotpole clown cockalorum cockroach codpiece conman cow coxcomb creep cretin cur curmudgeon deadbeat death-token deck-ape derelict dewberry dickwad dimwit dingbat dodger dog dolt doorknob dope dork dowdy dullard dumbbell dummy dunce dweeb filly flake flap-dragon flax-wench flirt-gill floozy fool foot-licker freak fruitcake frump fuss-budget fustilarian gallows-bait gasbag geek geezer giglet git goblin goldbrick goof goose goth gourd gudgeon gutter-snipe gyp gypsy haggard halfwit hamster harlot harpy harridan headache heathen hedge-pig heifer hen hick hind hippy hobbledehoy hobgoblin hockey-puck hog hooker horn-beast hornswoggler horror hugger-mugger hussy hysteromaniac idiot idler ignoramus ignorer imbecile insect jackanape jade jellyfish jenny jerk jerkface jezebel jobbernowl Joe jolthead klutz knuckle-dragger kook lamebrain lap lewdster lickspittle litterbug lollygagger loon loser loudmouth louse lout lunatic madman maggot maggot-pie maladroit malapert malingerer malkin malt-worm mammet mare measle meathead milksop milquetoast minnow minx miscreant moldwarp mollusk monkey-masher mooch mook moron muggle mumble-news nanny ne'er-do-well neanderthal nerd nincompoop nitwit novice nut nut-hook nutter omadhaun orc pagan pansy pantywaist peahen parrot peasant pedestrian pervert petty-fogger phlegmball pickup pig pigeon-egg pignut piker Philistine plebe plebian poltroon pooch popinjay poser prat primate procrastinator psycho pumpion pup puppy pustule puttock putz Quasimodo quisling ragamuffin rat rat-bag ratsbane reprobate reptile rotter rubbernecker saliva-breath saucebox savage scallway scarecrow schlemiel schlep schlimazzel schlump schnook scollywop scoundrel scrub scum scut she-bear she-goat shih-tzu shirker shlep shmuck showboat shyster sicko simian simpleton skainsmate skinflint slacker slangwanger slattern slob sloppy sloven slubberdegullion slut smart-ass snake snake-in-the-grass snip snollygoster sow squash street-rat streetwalker strumpet stumblebum swine tart toady traipse tramp trife troglodyte troll trollop trull turd-burgler twerp twit ultracrepidarian vamp vandal varlet vassal visigoth vixen waffleboy wagtail wanker wart weaselboy weenie weevil weirdo wench whelp whey-face whore whoreson wimp wisenheimer wog woman wuss yahoo yob yokel zero {ambulance chaser} {banana biter} {beaver bugger} {bottle cap} {broccoli banger} {brood mare} {candidate for retroactive birth control} {carpet crawler} {chicken chomper} {chowder head} {clod hopper} {cob gobbler} {crumb cruncher} {dip stick} {dodgy duck} {fraidy cat} {frog feeler} {gizzard grinder} {guinea fowl} {guinea hen} {hay baler} {heap of parrot droppings} {hog caller} {horn honker} {kennel keeper} {lint licker} {mental case} {mental defective} {monkey moocher} {mouth breather} {muckraking mallard} {mush-for-brains} {nanny goat} {nerf herder} {offspring of a dog} {pork chop} {pus bucket} {rug rat} {sleeze bag} {snooty poot} {snot snooter} {steaming pile of droppings} {trouble-maker} {turkey taster} {walking belly-cramp} {weiner waster} {yeasty codpiece}
}
comment -x {
@10<{}>
{...you, AND the horse you rode in on}
{...you, and ANYBODY who LOOKS LIKE you}
{, <simpleinsult>! <insultadj>, <insultadj>, <simpleinsult>}
{, and the offspring of <!a-or-an <simpleinsult>>}
{- you're the GOLD STANDARD for it}
{, and your MOTHER's ANOTHER one!}
{, I hope your <insultadj>, <insultadj> DOG dies}
{, you, AND your WHOLE GRADUATING CLASS}
}
simpleinsult {
@3<{<insultadj> <insultnoun>}>
{<insultnoun>}
{<insultadj>, <insultadj> <insultnoun>}
}
insult {
@10<{YOU are <!a-or-an <simpleinsult>><comment>!}>
{Your MOTHER is <!a-or-an <simpleinsult>>!}
}This gem spits out insults such as:
YOU are a gimlet-eyed, awful pignut, and your MOTHER's ANOTHER one!! YOU are a filthy jobbernowl...you, AND the horse you rode in on! YOU are an evil-smelling petty-fogger, and the offspring of a cockeyed turd-burgler! YOU are a spur-gall braggart! YOU are a barmy fraidy cat- you're the GOLD STANDARD for it! YOU are a stabbing wagtail, I hope your venomous, dazed DOG dies! YOU are an exasperating knuckle-dragger, you, AND your WHOLE GRADUATING CLASS! YOU are a cuckoo peahen! YOU are a venomed, traitorous candidate for retroactive birth control! YOU are a shlep!
With a large vocabulary and several different productions available, it actually generates quite a wide selection of insults.
To use this thing you need generate.tcl (listed below), the above specification (in Insult.txt) and a program that will produce and use the output.
source generate.tcl initgen demo desc "Insult.txt" This creates generator "demo" from "Insult.txt" -- a desc"ription" generator. To get an insult, you evaluate: demo gen <insult> Notice the object-orientedness here. Once initialized, the generator becomes self-contained and accessed by name using a normal ensemble command. You can ask for any production by naming the table in <...> to evaluate it. In the event that you would like to be able to repeat a sequence (to reconstruct a description, say) you can use a "tape". demo record demo gen <insult> set history [demo gettape] demo loadtape $history demo reset demo playback demo gen <insult>
...should produce the same result as the first run. At least, if there are no bugs. The insult generator does this to avoid using the same comment in one run.
There are two types of table, the normal, inexhaustable table that may return anything, or an exhaustable table that will not repeat itself until it runs out of options and resets. You specify which a table is using the "-x" switch as the first table entry.
You can tune the probability of a given result in a table by repeating it. If you have two entries and you want one of them to be chosen 90% of the time:
table {
@9<{choose me}>
{or choose me}
}Is equivalent to:
table {
{choose me}
{choose me}
{choose me}
{choose me}
{choose me}
{choose me}
{choose me}
{choose me}
{choose me}
{or choose me}
}So you get {choose me} nine times - on average - for every time you get {or choose me}.
If your generator uses another generator, you can include it with "uses":
uses RacialEpithet.txt
You can use the generator with the production:
<RacialEpithet*epithet>
and it will (presumably) insert some politically incorrect insult from the specified generator).
The word generator swiped wholesale from Create words from a text file (list) takes in input list of words that sound similar to the kind of word you want. For example:
Elfish-f.txt
Aelrue Aelynthi Aerilaya Ahrendue Ahskahala Alaglossa Alais Alavara Alea Alerathla Allannia Allisa Alloralla Allynna Almithara Alvaerele Alyndra Amara Amaranthae Amkissra Amlaruil Amnestria Amra Anarzee Aneirin Anhaern Ara Araushnee Aravae Arcaena Arielimnda Arlayna Arnarra Artin Auluua Aurae Ava Axilya Azariah Blythswana Bonnalurie Braerindra Caerthynna Calarel Chaenath Chalsarda Chandrelle Chasianna Chomylla Cilivren Ciyradyl Claire Daratrine Darshee Dasyra Dathlue Delimbiyra Delshandra Deularla Duilya Eallyrl Ecaeris Edraele Elanalue Elanil Elasha Elenaril Eletha Ellarian Eloen Elora Eshenesra Essaerae Esta Esyae Faunalyn Fhaertala Fieryat Filaurel Filauria Fildaerae Gaelira Gaerradh Gaylia Gemstarzah Ghilanna Glynnii Gweyr Gwynnestri Gylledha Hacathra Halaema Halanaestra Hamalitia Haramara Helartha Holone Huquethae Hycis Ialantha Ikeshia Ildilyntra Ilmadia Ilsevel Ilyrana Ilythyrra Imizael Immianthe Imra Imryll Ioelena Irhaal Isilfarrel Itiireae Itylra Jastra Jeardra Jhanandra Jhaumrithe Jhiilsraa Kavrala Kaylessa Keerla Keishara Kethryllia Keya Kythaela Laamtora Laerdya Lazziar Leilatha Liluth Llamryl Lorelei Maelyrra Maeralya Makaela Malruthiia Mariona Martainn Meira Melarue Merethyl Merialeth Meriel Merlara Mladris Mnuvae Morgwais Moryggan Muerlara Mylaela Mylaerla Myriani Naevys Nakiasha Nambra Nanthleene Naumys Nlaea Nuala Nueleth Nuovis Nushala Nylaathria Ochyllyss Phaerl Phelorna Phuingara Phyrra Quamara Raejiisa Raerauntha Rathiain Renestrae Rubrae Ryllae Saélihn Saelihn Saida Sakaala Sariandi Sarya Seirye Seldanna Selussa Shadowmoon Shalana Shalendra Shalheira Shandalar Shanyrria Sharaera Sheedra Sheera Shialaevar Shyael Sinnafain Soliania Soora Sorsasta Susklahava Sylmae Symrustar Syndra Syviis Taenya Talanashta Talila Talindra Tarasynora Teharissa Teryani Thaola Thasitalia Tiatha Tiriara Tisharu Tsarra Ulelesse Urmicca Uschymna Valindra Vashti Velatha Verrona Vestele Viansola Yaereene Yalanilue Yathlanae Ygrainne Ynshael Yrlissa Yrneha Yrthraethra Ysmyrlda Yulmanda Zoastria
Using:
initgen demo word "Elfish-f.txt"
You get a generator where calls of:
demo gen
Can produce results like:
Allorala Makaelyrra Ghilaya Arnarrel Elanna Filatha Amarantha Leila Nylaathrian Hacathlue
However, the system can be more sophisticated than this. A production <...> can include a number of different operations.
For example:
<save:table>
Will evaluate <table> and save the result in "save". Further evaluations of <save:Table> will always return the saved result in "save". You can have any number of stored variables from a table. <save2:Table> will do the same thing, thereafter <save:Table> will give you the first result and <save2:Table> the second. This is useful to save state from productions in process to alter productions yet in the cue. In my spell ingredients table, there is <save:critter> which will save the name of critter which is called for first. Later on, I call: <<save:critter>-bits> where I have a series of tables fish-bits, mammal-bits, bat-bits and so on, so the system will never call for the wing of a fish or a scale of a cow.
You can access Tcl functions using "!". <!a-or-an <critter>> will return "a bat" or "an eland" according to the first letter of the critter. Any Tcl function can be accessed this way. Some other built-ins include, "nth" which will give you "First, Second, Third..." or "1st, 2nd, 3rd..." followed by "Level" or "Circle" to give you a rank. <!range 5 9> will give you a random number in the specified range. <!cap <critter>> would give you "Cow" or "Eland" instead of "cow" or "eland".
You can check strings for equality or inequality -- notice that since this is a text substitution engine, you need extra levels of <> to evaluate variables -- for example:
<<save:critter>=cow:moo>
Will give you "moo" if <save:critter> evaluates to "cow". You can do else clauses too:
<<save:critter>=cow:moo/baa>
You will get "baa" if <critter> is NOT cow.
You can invert this operator:
<<critter>#cow:baa/moo>
And, since I swapped the then for the else, you will still get "baa" if <critter> is NOT cow.
There is a shorthand for accessing variables. You can check the save variable directly using a prefixed "@":
<<@save=cow:moo>
...assumes "save" is already set and bypasses the table entirely.
As mentioned earlier, you can access another generator you have added with "uses"
Racialepithet.txt:
race Elf Human Dwarf Elf-epithet tiny points Spock Human-epithet dummy round-ear Dwarf-epithet shorty grumpy
soemthingelse.txt
uses RacialEpithet.txt
racechoice {
{ You're a <species:race>, <RacialEpithet*@species-epithet> }
}
<racechoice>
You're an Elf, Spock!You can directly consult the dice generator without variable with "|"
<tablename|> Here is the actual code for the generator:
generate.tcl:
proc vars { args } {
foreach var $args {
uplevel "variable $var"
}
}
proc import { args } {
foreach var $args {
set t [split $var >]
if {[llength $t] == 2} {
set left [lindex $t 0]
set right [lindex $t 1]
} else {
set left $var
set right $var
}
set temp "[uplevel uplevel set $left]"
regsub -all {\"} $temp {\"} temp
set cmd "set $right \"$temp\""
uplevel $cmd
}
}
set curgen ""
set stack {}
proc initgen { self type file } {
lappend $::stack $::curgen
lappend ::genlist $self
set ::curgen $self
set body {
set cmd [ lindex $args 0 ]
set args [ lrange $args 1 end ]
if { $args eq "" } {
namespace eval $self $cmd
} else {
namespace eval $self $cmd {*}$args
}
}
set body "set self $self\n$body"
proc $self { args } $body
namespace eval $self {
import self>myself type>mytype file>fname
variable name $myself
variable type $mytype
variable file $fname
variable play 0
variable rec 0
variable tape {}
variable readhd 0
variable filelist {}
proc include { fname } {
vars filelist
if {[string first "." $fname] == -1} {
set fname ${fname}.txt
}
if { [lsearch $filelist $fname] != -1 } {
lappend filelist $fname
namespace eval [namespace current] { source $fname }
}
}
proc reset { } {
vars readhd rec play tablelist save type
set readhd 0
set rec 0
set play 0
if { $type eq "word" } return
foreach thetable $tablelist {
if [info exists save($thetable)] {
set table($thetable) $save($thetable)
}
}
}
proc gettape { } {
vars tape
return $tape
}
proc loadtape { s } {
vars tape readhd rec play
set tape $s
set readhd 0
set rec 0
set play 0
}
proc showtape { } {
vars tape
puts "gen: [namespace current] tape is:\n$tape"
}
proc record { } {
vars play tape readhd rec
set play 0
set tape {}
set readhd 0
set rec 1
}
proc playback { } {
vars play
reset
set play 1
}
proc playrec { varname {norec 0} } {
vars rec tape play readhd
upvar $varname var
if { $rec && !$norec } { lappend tape $var
} elseif $play {
set recval [lindex $tape $readhd] ; incr readhd
set var $recval
if { $readhd > [ llength $tape ] } { set play 0 }
return 1
}
return 0
}
if { $type eq {desc} } {
variable used {}
variable table ; set table() 0
variable save ; set save() 0
variable memory ; set memory() 0
variable tablelist ; set tablelist {}
proc clear { varname } {
vars memory
catch {unset memory($varname)}
return ""
}
proc dice { tablename } {
vars table save
if { [catch {set choices $table($tablename)} err ] != 0 } {
puts "no such table $tablename"
set choices { %unknown1 %unknown2 %unknown3 %unknown4 %unknown5 %unknown6 }
}
set numchoices [ llength $choices ]
set index [ expr {int(rand()*$numchoices)} ]
playrec index
set value [ lindex $choices $index ]
if { [info exists save($tablename)]
&& ([ llength $save($tablename) ] != 0) } {
#puts "table $tablename is exhaustable"
set table($tablename) [ lreplace $table($tablename) $index $index ]
if { [ llength $table($tablename) ] == 0 } {
set table($tablename) $save($tablename)
}
#puts "table $tablename: $table($tablename)"
#catch { puts "save $tablename: $save($tablename)" }
}
return $value
}
proc scanfunc { str delimiter } {
upvar from from ; upvar to to ; upvar replace replace
set from $to
incr from -1
set replace ""
while 1 {
set ch [ string index $str $from ]
if { $ch eq $delimiter } break
if { $from < 0 } { puts "> without < in '$replace'"; exit }
incr from -1
set replace $ch$replace
}
}
proc usegen { left right } {
if { $right eq "" } { set right pattern }
return [ $left gen <$right> ]
}
proc dofunc { str } {
vars memory
while { [ set to [ string first > $str ] ] != -1 } {
scanfunc $str <
set varname ""
set value "%NONE%"
set colon [ string first : $replace ]
if { $colon != -1 } {
set varname [ string range $replace 0 $colon-1 ]
set replace [ string range $replace $colon+1 end ]
if {$varname ne ""} {
if [info exists memory($varname)] {
set value $memory($varname)
}
}
}
if {$value eq "%NONE%"} {
foreach cmd { * ! ? = # | } {
set cmdidx [ string first $cmd $replace ]
if { $cmdidx != -1 } break
}
set left $replace
set right ""
set result ""
if { $cmdidx != -1 } {
set left [ string range $replace 0 $cmdidx-1 ]
set right [ string range $replace $cmdidx+1 end ]
}
set t [ string first "/" $right ]
if { $t != -1 } {
set right [ string range $right 0 $t-1 ]
set result [ string range $right $t+1 end ]
set result [ split $result / ]
}
foreach var { left right } {
set tmp [ set $var ]
if { [ string index $tmp 0 ] eq "@" } {
set v [string range $tmp 1 end]
set $var ""
catch {set $var $memory($v)}
}
}
for { set j 0 } { $j < [llength $result] } {incr j} {
set tmp [ lindex $result $j ]
if { [ string index $tmp 0 ] eq "@" } {
set v [string range $tmp 1 end]
lset result $j ""
catch {lset result $j $memory($v)}
}
}
switch $cmd { ! { set value [ subst \[$right\]] }
? { set n [llength $result]
set which [expr {int(rand()*$n)}]
playrec which
set value [lindex $result $which]
}
= { set value [lindex $result 0]
if { $left eq $right } {
set value [lindex $result 1]
}
}
# { set value [lindex $result 0]
if { $left ne $right } {
set value [lindex $result 1]
}
}
| { set value [ dice $left ] }
default { puts "unknown operator $cmd"; exit }
}
}
set str [ string replace $str $from $to $value ]
#puts ">$str"
#gets stdin
set was ""
if {[info exists memory(varname)]} {set was $memory($varname)}
if { $varname ne "" } {
set memory($varname) $value
# puts "set $varname = $value (was: $was)"
}
}
return $str
}
proc substitute { str } {
set passlimit 10
while 1 {
set oldstr $str
set str [ dofunc $str ]
if { $oldstr eq $str } {
return $str
}
incr passlimit -1
if {$passlimit == 0} {
puts "endless substitution $str"
exit
}
}
}
proc gen { {result <pattern>} } {
set result [ substitute $result ]
regsub -all " " $result " " result
regsub -all \{ $result "" result
regsub -all \} $result "" result
regsub -all { \.} $result "." result
return $result
}
source $file
} else {
variable new
variable line
variable startline 1
proc K {x y} {set x}
proc shuffle4 { list } {
set n [llength $list]
while {$n>0} {
set j [expr {int(rand()*$n)}]
lappend slist [lindex $list $j]
incr n -1
set temp [lindex $list $n]
set list [lreplace [K $list [set list {}]] $j $j $temp]
}
return $slist
}
proc gen { { linklength 3 } } {
vars new line
set new ""
if {[playrec new 1]} { return $new }
set startline 1
set line [shuffle4 $line]
# pick the first word on the textfile
while 1 {
set pick [lindex $line $startline+2]; set idx 0
set pos -1
# loop: word length
for {set i 1} {$i<=100} {incr i} {
# take the first [linklength] letters of the word picked
set chain [string range $pick $pos+1 $pos+$linklength]
# idx is the variable that contains the line of the current word
set idx [lsearch $line $pick]
# find another word that matches the first [linklength] letters of the word
# set pick [lsearch -start $idx+1 -inline $line *$chain*]
set pick [lsearch -inline $line *$chain*]
# save the position of the matched letters
set pos [string first $chain $pick]
# get the letters of the current word
set add [string index $pick $pos+$linklength]
if {$i==1} {set new $chain}
set new $new$add
if {$add eq ""} break
}
# if the created word is in the textfile don't print and make another one
if { ([lsearch $line $new] == -1) & ([string length $new] < 15) } {
playrec new
return $new
} else {
incr j -1; incr startline
}
}
}
set f [open $file r]
set line [split [read -nonewline $f] \n]
close $f
}
}
set $::curgen [ lindex $::stack end ]
set $::stack [ lreplace $::stack end end ]
}
rename unknown prev_unknown
proc unknown { tablename args } {
if {$tablename eq "\}"} { puts "unbalanced braces" }
#puts "unknown: $tablename"
if { [llength $args] == 1 } {
set args [ lindex $args 0 ]
} elseif { ([ lindex $args 0 ] eq "-x") && ([llength $args] == 2) } {
set args [ lindex $args 1 ]
set args [ linsert $args 0 -x ]
}
if {$tablename eq "uses"} {
foreach file $args {
source ${file}.txt
}
return
}
namespace eval $::curgen {
vars tablelist table save
import tablename args
if { [lsearch $tablelist $tablename] != -1 } {
puts "Warning, redefinition of $tablename"
} else {
lappend tablelist $tablename
}
while { [ set idx [ string first "@" $args ] ] != -1 } {
set from $idx
incr idx
set reps ""
while 1 {
set ch [ string index $args $idx]
if { [ string first $ch "0123456789" ] >= 0 } {
set reps $reps$ch
incr idx
} else {
break
}
}
set depth 1
set repeat ""
while { $depth > 0 } {
incr idx
set ch [ string index $args $idx]
if { $ch eq "<" } then { incr depth } elseif { $ch eq ">" } then { incr depth -1 }
if { $depth <= 0 } break
set repeat "$repeat$ch"
}
set to $idx
set repeatstr [ string repeat "$repeat " $reps ]
set args [ string replace $args $from $to $repeatstr ]
}
set needsave 0
if { ([set flag [lsearch $args "-x"]]) != -1 } {
set needsave 1
set args [lreplace $args $flag $flag ]
}
set table($tablename) $args
set save($tablename) {}
if { $needsave } {
set save($tablename) $args
}
}
}
proc a-or-an { args } {
set word [ lindex $args 0 ]
set args [ lrange $args 1 end ]
if {$word eq ""} { return "a-or-an null args" }
#puts "a-or-an $word"
set 1stltr [ string index $word 0 ]
set result ""
if { [ string first $1stltr "aeiouAEIOU" ] == -1 } {
set result "a"
} else {
set result "an"
}
set text [ join $args " " ]
return [string trim "$result $word $text" ]
}
proc cap { args } {
set str [string trim [ join $args " " ]]
if { $str ne "" } {
set str [string replace $str 0 0 [string toupper [string index $str 0]]]
}
return $str
}
proc range { from to } {
set myrange [ expr { $to - $from } ]
set result [ expr {$from + (int( rand() * $myrange)) } ]
$::curgen playrec result
return $result
}
proc nth { { num "" } } {
if { $num eq "" } { return "" }
set xth { First Second Third Fourth Fifth Sixth Seventh Eighth Ninth }
set sfx { st nd rd th th th th th th }
set how { xth sfx }
set circle { Circle Level Round Step }
set label [ lindex $circle [ expr int(rand()*4) ] ]
$::curgen playrec label
set which [ lindex $how [ expr int(rand()*2) ] ]
$::curgen playrec which
if { $which eq "xth" } { set num [ lindex $xth [ expr $num-1 ] ]
} else { set num "${num}[ lindex $sfx [expr $num-1] ]" }
set result "$num $label"
return $result
}
proc print { width args } {
puts ""
set args [ join $args " " ]
while 1 {
if { $width >= [string length $args] } {
puts [string trim $args]
break
} else {
set idx $width
while { [ string index $args $idx ] ne " " } {
incr idx -1
if { $idx <= 0 } { puts [ string trim $args] ; return }
}
puts [string trim [ string range $args 0 $idx ] ]
set args [ string range $args $idx end ]
}
}
puts ""
}
And the moronic test harness:testgen.tcl:
source generate.tcl
set dotests 2
set replay 0
foreach test $dotests {
switch $test {
1 { initgen test3 desc "Insult.txt"
if $replay { test3 record }
for { set j 0 } { $j < 10 } {incr j } { puts "[ test3 gen <insult> ]" }
if $replay {
test3 showtape
test3 playback
for { set j 0 } { $j < 10 } {incr j } { puts "[ test3 gen <insult> ]" }
}
}
2 { initgen test2 word "Elfish-f.txt"
if $replay { test2 record }
for { set j 0 } { $j < 10 } {incr j } { puts "[ test2 gen ]" }
if $replay {
test2 showtape
test2 playback
for { set j 0 } { $j < 10 } {incr j } { puts "[ test2 gen ]" }
}
}
3 { initgen test1 desc "Alchemy.txt"
if $replay { test1 record }
print 75 [ test1 gen <tostart> ]
for { set j 0 } { $j < 5 } { incr j } {print 75 [ test1 gen ] }
print 75 [ test1 gen <tofinish> ]
if $replay {
puts "--------------------------------"
test1 showtape
test1 playback
print 75 [ test1 gen <tostart> ]
for { set j 0 } { $j < 5 } { incr j } {print 75 [ test1 gen ] }
print 75 [ test1 gen <tofinish> ]
}
}
4 { initgen test4 desc "Pets.txt"
if $replay { test4 record }
for {set j 0} {$j <10} {incr j} {puts "$j [ test4 gen <pet> ]"}
if $replay {
puts "--------------------------------"
test4 showtape
test4 playback
for {set j 0} {$j <10} {incr j} {puts [ test4 gen <pet> ]}
}
}
5 { initgen test5 desc "Colors.txt"
if $replay { test5 record }
for {set j 0} {$j <10} {incr j} {puts [ test5 gen <color> ]}
if $replay {
puts "--------------------------------"
test5 showtape
test5 playback
for {set j 0} {$j <10} {incr j} {puts [ test5 gen <color> ]}
}
}
6 { initgen test6 desc "Dragon.txt"
if $replay { test6 record }
for {set j 0} {$j <10} {incr j} {puts [ test6 gen ]}
if $replay {
puts "--------------------------------"
test6 showtape
test6 playback
for {set j 0} {$j <10} {incr j} {puts [ test6 gen ]}
}
}
7 { initgen test7 desc "AcademicDisciplines.txt"
if $replay { test7 record }
for {set j 0} {$j <10} {incr j} {puts [ test7 gen ]}
if $replay {
puts "--------------------------------"
test7 showtape
test7 playback
for {set j 0} {$j <10} {incr j} {puts [ test7 gen ]}
}
}
8 { initgen test8 desc "RadPartField.txt"
for {set j 0} {$j < 4} {incr j} {puts [ test8 gen <radiation> ]}
for {set j 0} {$j < 4} {incr j} {puts [ test8 gen <particle> ]}
for {set j 0} {$j < 4} {incr j} {puts [ test8 gen <field> ]}
for {set j 0} {$j < 4} {incr j} {puts [ test8 gen <material> ]}
}
}
}