|What:| '''generator''' - Gaming Generators in Tcl|
|Description:| A program for generating text description and sound-alike wordlists given syntactical or examplary input. A technique for Procedural Generation.|
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 of 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/] and Procedural Generation[http://en.wikipedia.org/wiki/Procedural_generation].
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.>} }
This is two tables, the second of which has only one choice (hence the double brackets -- anything with embedded spaces will need brackets). Evaluating: 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}
{, ! , , }
{, and the offspring of >}
{- you're the GOLD STANDARD for it}
{, and your MOTHER's ANOTHER one!}
{, I hope your , DOG dies}
{, you, AND your WHOLE GRADUATING CLASS}
}
simpleinsult {
@3<{ }>
{}
{, }
}
insult {
@10<{YOU are >!}>
{Your MOTHER is >!}
}
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
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
set history [demo gettape]
demo loadtape $history
demo reset
demo playback
demo gen
...''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:
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:
Will evaluate and save the result in "save". Further evaluations of will always return the saved result in "save". You can have any number of stored variables from a table. will do the same thing, thereafter will give you the first result and 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 which will save the name of critter which is called for first. Later on, I call: <-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 "!". > 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. will give you a random number in the specified range. > 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:
<=cow:moo>
Will give you "moo" if evaluates to "cow". You can do else clauses too:
<=cow:moo/baa>
You will get "baa" if is NOT cow.
You can invert this operator:
<#cow:baa/moo>
And, since I swapped the then for the else, you will ''still'' get "baa" if 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
somethingelse.txt
uses RacialEpithet.txt
racechoice {
{ You're a , }
}
You're an Elf, Spock!
You can directly consult the dice generator without variable with "|"
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 [ usegen $left $right ] }
! { 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 } } {
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 ]" }
if $replay {
test3 showtape
test3 playback
for { set j 0 } { $j < 10 } {incr j } { puts "[ test3 gen ]" }
}
}
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 ]
for { set j 0 } { $j < 5 } { incr j } {print 75 [ test1 gen ] }
print 75 [ test1 gen ]
if $replay {
puts "--------------------------------"
test1 showtape
test1 playback
print 75 [ test1 gen ]
for { set j 0 } { $j < 5 } { incr j } {print 75 [ test1 gen ] }
print 75 [ test1 gen ]
}
}
4 { initgen test4 desc "Pets.txt"
if $replay { test4 record }
for {set j 0} {$j <10} {incr j} {puts "$j [ test4 gen ]"}
if $replay {
puts "--------------------------------"
test4 showtape
test4 playback
for {set j 0} {$j <10} {incr j} {puts [ test4 gen ]}
}
}
5 { initgen test5 desc "Colors.txt"
if $replay { test5 record }
for {set j 0} {$j <10} {incr j} {puts [ test5 gen ]}
if $replay {
puts "--------------------------------"
test5 showtape
test5 playback
for {set j 0} {$j <10} {incr j} {puts [ test5 gen ]}
}
}
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 ]}
for {set j 0} {$j < 4} {incr j} {puts [ test8 gen ]}
for {set j 0} {$j < 4} {incr j} {puts [ test8 gen ]}
for {set j 0} {$j < 4} {incr j} {puts [ test8 gen ]}
}
}
}
<> Toys |Gaming|Tcl for Kids