"Any Perlmonk could write a sentence using four a's, one b, three c's, three d's, thirty-one e's, six f's, two g's, five h's, ten i's, one j, two k's, four l's, two m's, twenty-three n's, sixteen o's, two p's, one q, eleven r's, twenty-nine s's, twenty t's, seven u's, four v's, nine w's, four x's, six y's, and one z."
Hopefully the code is straight forward. Each letter has a {claim}, {count} and {score} field. A {claim} is made. The sentence is analyzed, updating the {count} fields. {score} = {claim} - {count}. If {score} is nonzero it is added to 'broke' list. Adjustments are make to the broke letters by changing their {claim} fields and the process repeats.
I'd be glad to clarify any questions about the code and feedback is welcome.
To improve the algorithm, I need more sentence beginnings that I know have a resolution, for analysis. So please let me know of any successes you have.
YuckFoo
#!/usr/bin/perl use strict; my $GERM = "Any Perlmonk could write a sentence using\n"; my $RESET = 4096; my $PROB = .5; my $words = makewords(); my $letts = makeletters(); my ($sent, $iter, $best); while (1) { $sent = makesentence($GERM, $words, $letts); updatecounts($letts, $sent); my ($broke, $score) = scoreclaim($letts); if ($iter++ % $RESET == 0) { $best = $score; print "\n"; } if ($score == 0) { last; } elsif ($score < $best) { $best = join('', @{$broke}); $best = "$score-$best"; print "$iter $best\n"; $best = $score; } for my $letter (@{$broke}) { if (rand() < $PROB) { my $amount = int(rand(abs($letts->{$letter}{score}+1)))+1; if ($letts->{$letter}{score} > 0) { $amount *= -1; } $letts->{$letter}{claim} += $amount; } } } print "\n$sent\n"; #----------------------------------------------------------- sub scoreclaim { my ($letts) = @_; my ($total, @broke); for my $ch ('a'..'z') { my $score = $letts->{$ch}{claim} - $letts->{$ch}{count}; $letts->{$ch}{score} = $score; $total += abs($score); if (abs($letts->{$ch}{score}) > 0) { push(@broke, $ch); } } return (\@broke, $total); } #----------------------------------------------------------- sub updatecounts { my ($letts, $sent) = @_; for my $ch ('a'..'z') { $letts->{$ch}{count} = (() = $sent =~ m{$ch}ig); } } #----------------------------------------------------------- sub makesentence { my ($sent, $words, $letts) = @_; my ($num); for my $ch ('a'..'y') { $num = $letts->{$ch}{claim}; if ($num != 1) { $sent .= " $words->{$num} ${ch}'s,\n"; } else { $sent .= " $words->{$num} $ch,\n"; } } $num = $letts->{z}{claim}; $sent .= " and $words->{$num} z"; if ($num != 1) { $sent .= "'s"; } $sent .= '.'; return $sent; } #----------------------------------------------------------- sub makeletters { my $letters = {}; for my $ch ('a'..'z') { $letters->{$ch} = {}; $letters->{$ch}{claim} = 1; $letters->{$ch}{count} = 0; $letters->{$ch}{score} = 0; } return $letters; } #----------------------------------------------------------- sub makewords { my (%words, $line); while (chomp ($line = <DATA>)) { my ($key, $val) = split(' ', $line); $words{$key} = $val; } for ($line = 0; $line < 100; $line++) { if (!defined($words{$line})) { my $tens = int($line / 10); my $ones = $line - ($tens * 10); $tens .= '0'; $words{$line} = "$words{$tens}-$words{$ones}"; } } return \%words; } __DATA__ 0 no 1 one 2 two 3 three 4 four 5 five 6 six 7 seven 8 eight 9 nine 10 ten 11 eleven 12 twelve 13 thirteen 14 fourteen 15 fifteen 16 sixteen 17 seventeen 18 eighteen 19 nineteen 20 twenty 30 thirty 40 forty 50 fifty 60 sixty 70 seventy 80 eighty 90 ninety
Edit kudra, 2002-05-30 Added readmore
|
---|
Replies are listed 'Best First'. | |
---|---|
Re: Solving Meta Sentences
by Abigail-II (Bishop) on May 30, 2002 at 14:30 UTC | |
Re: Solving Meta Sentences
by jarich (Curate) on May 30, 2002 at 02:53 UTC | |
by Molt (Chaplain) on May 30, 2002 at 09:58 UTC | |
by YuckFoo (Abbot) on May 30, 2002 at 06:52 UTC | |
Re: Solving Meta Sentences
by abstracts (Hermit) on Jun 05, 2002 at 05:52 UTC | |
by gumby (Scribe) on Jun 12, 2002 at 22:21 UTC |