#!/usr/bin/perl use strict; use FileHandle; use IO::Socket; use Time::localtime (); my($botName, $botPass) = ("Alex", "newbirdpass"); #my($botName, $botPass) = ("Griffin", "wool"); my $debug = 0; my $owner = "inky"; my $logHeader = "http://ifmud.port4000.com/alex/"; my $logDirectory = "/opt/ifmud/web/alex/"; my $logLimit = 1500; # max number of lines before log auto-shuts off my $memoryFile = "memory.txt"; my $memVersion = 1; my $entryMessage = "#alex :has connected.\n"; # words to remove when people say "what is a " my %stopwords = ( "of" => 1, "the" => 1, "an" => 1, "a" => 1, ); my %memory; my %reverseMemory; my %dontLearnWords; my %friends; my %nonFriends; my $DIRECT_ONLY = 0; # set to 1 to turn off alex responding to general speech my $syntax = "Syntax: $0 |\n " . " $0 -d[ump]\n"; if (@ARGV && ($ARGV[0] eq "-d" || $ARGV[0] eq "-dump")) { &readMemoryFromFile($memoryFile); &dumpMemoryToHTML(); exit; } elsif (@ARGV < 2) { die $syntax; } # else everything's cool # table of keywords for the bot to respond to # # If the hashvalue of a key is a string, the string is executed as a mud # command. If it's a function, the function is called with the entire # triggering line and the socket filehandle as arguments. # # We store them in an array rather than a hashtable so we can specify # the order in which conditions are checked (ie, stuff at the beginning # of the table will be checked before stuff at the end). my(@responses) = ( '^help', \&giveHelp, '^(recap|recall)', \&recap, '^urls', \&recap, '^unscript', \&logToFile, '^(close|end) +(log|record|script)', \&logToFile, '^(log|record|script) ', \&logToFile, '^forget', \&forgetDefinition, '^(ignore|notice)', \&setNonFriend, '^delword', \&ignorePhrase, '^bedtime$', \&quit, '^dump$', \&doDump, '^(joinc|jc +)', \&joinChannel, '^(leavec|lc +)', \&leaveChannel, '^(what|who) +(do +you|does +'.$botName.') +know', \&listKnowledge, '^learn:\s*\S', \&learnDefinition, 'what +time +is +it\?', \&timeQuery, 'what(\'s| +is) +new\?', \&learnedQuery, '^(what|who|where)( +(is|are|am|was|were)|(\'s|\'re|\'m)) +', \&answerQuery, '^(what|who|where)( +(does|do) +).+mean', \&answerQuery, '^(is|are|am|was|were) ', \&answerYesNoQuery, # '(what|who|where) +(is|are|am|was|were)\W', \&answerQuery, '(what|who|where)( +(does|do) +).+(mean|stand +for)\?', \&answerQuery, '(what|who|where)( +(is|are|am|was|were)|(\'s|\'re|\'m)) +.*\?', \&answerQuery, 'count +(your +)?corknuts', \&reportCorkCount, '(how +many +)?nuts +(have +(you|been) +)?corked( +so +far)?', \&reportCorkCount, '^(what|who|where|why|how|when)\W', \&genericQuery, '(what|who|where|why|how|when)\W.*\?', \&genericQuery, '^\S+ has changed the poll\!', \&maybeCheckPoll, ''.$botName.'(,|) +here +is +your +cork[ |_|-]*nut', \&corkNut, # '\S( +(is|are|am|was|were)|(\'s|\'re|\'m)) +not +\S', \&forgetDefinition, '\S( +(doesn\'t|does not) +mean +)\S', \&forgetDefinition, '\S+( +(mean|means) +)\S', \&learnAlias, '\S+( +(is|are|am|was|were)|(\'s|\'re|\'m)) +.*[^\?]$', \&learnDefinition, # 'count', \&test, '^(hello|hi|howdy|greetings|hey|hola)(\W.*|)$', \&greet, '(bye|wave|see *y(a|ou)|so +long|good *bye|good *night)(\W.*)?$', \&leave, '^(yes|correct)', \&praise, '((good|smart|clever) +(parrot|bot|bird|'.$botName.'))|thanks|thank +you|((\'s|is|are) +(correct|right))', \&praise, '(you|who\'s|'.$botName.')( +(are|is))? +(smart|clever|good|rock|rule|(the|da) +man|(the|da) +bird)', \&praise, 'fuck you', \&fuckyou, '(?:(?:i +(?:like|love) +you)|(?:do +you +(?:like|love) +me))(\W.*)?$', \&loveyou, '^(.*\W)?(shut *up|s?hush|s+h+)(\W.*)?$', \&shutup, '^(.*\W)?(ha|hah|heh|yay|tT|hee|snrk)(\W.*)?$', \&applause, 'eat +(the +|a +|)\S.*[^\?]$', \&consumeCorkNut, '(cork[ |_|-]?nut)|almond', \&corkNut, '\S.*\?', \&possibleQuery, '\S.*\?', \&genericQuery, ); my(@nonConvResponses) = ('^User +On +Idle +(.*)', \&extractPoll, # '^\#if/comps/comp../\S+', \&leaveComp, # '^I don\'t see that here\.$', \&errorResponse, # '^That doesn\'t look very appetizing\.$', \&errorResponse, ); my(@dontLogList) = # things not to add to the log (case-SENSITIVE): ( '^Away message sent to ', '^\[Unsetting the zoned flag\]$', '^\[Setting the zoned flag.\]$', '^You have( new)? mail', '^\[You are gagged by', ); my(%helpText) = ( "help" => "$botName is a bot. I can answer questions of the form " . "'What is an alpaca?', can log conversations or replay " . "recent ones, and so on. Current commands:\n" . "log recap urls what is forget means ignore notice cork_nut\n" . "(you can ask for more specific information on these)", "log" => "Logs information to a file. You can specify a specific user " . "to log and/or a number of lines of backlog to add to the " . "log file.\n" . "Syntax: log filename lines username #channel", "recap" => "Recaps the last specified number of lines of conversation. " . "If the third argument has quotes around it, print lines " . "with that text in it, else print lines from that user. If " . "no channel is specified, recaps from the current room.\n" . "Syntax: recap lines username/substring channel", "urls" => "Almost identical to recap (qv), this lets you access the " . "last X urls mentioned.\n" . "Syntax: urls lines username/substring channel", "what" => "You can ask $botName questions with 'What is a ' or " . "'Who are '. You can teach $botName things with 'A monkey is " . "funny'. Also, see 'help is'.\n" . "Syntax: what is a monkey?", "is" => "You can ask $botName questions with 'Is a monkey funny?' " . "and get yes/no/I-don't-know. Also, see 'help what'.\n" . "Syntax: is an alpaca furry?", "forget" => "You can tell $botName to forget about learned facts with " . "forget. If you don't specify a definition to forget, it " . "forgets all definitions for the term.\n" . "Syntax: forget about the monkey / forget that monkeys are " . "funny", "means" => "You can tell $botName to alias one word for another. When " . "asked about the first word, $botName will respond with the " . "second's definition, letting you only have to write one " . "definition.\n" . "Syntax: sadie means sadie hawkins", "ignore" => "Tell $botName not to respond to questions you ask unless " . "the bot is addressed directly (see 'help notice').\n" . "Syntax: ignore me", "notice" => "If $botName is ignoring you, make it stop doing so " . "(see 'help ignore')\n" . "Syntax: notice me", "cork_nut", => "Awwwk! Want cork nut!\n" . "Syntax: $botName, here is your cork nut." ); # buffer is just a list of the last $maxBufferSize lines the bot's seen. my(@buffer); my($maxBufferSize) = 1000; # ditto for URLs my(@urlBuffer); my($maxURLBufferSize) = 500; # file, if any, that we're logging to my($logFile) = ""; my($logHandle); my($logLines) = 0; # current number of lines logged my($logChannel); # channel log was started on my($logFunc); # determines whether a line should be logged or not my($lastDump) = 0; # when this gets to $dumpInterval, dump and reset. my($dumpInterval) = 5; # how many def'ns to learn before auto-dumping my($corkNutCount) = 0; my($lastCorkTime) = 0; my($testCount) = 0; my @lastLearned; # last term and definition that we learned my @recentlyLearned; # last five things we learned my @recentlyAsked; # last five we were asked if ($#responses % 2 != 1) { die "Error: responses not paired properly\n"; } &readMemoryFromFile($memoryFile); my $SOCK = IO::Socket::INET->new(PeerAddr => $ARGV[0], PeerPort => $ARGV[1], Proto => "tcp", Type => SOCK_STREAM, LocalPort => 10002) or die "Erorr creating socket: $!"; my $line; while (defined($line = <$SOCK>)) { if ($debug == 2) { print $line; } last if ($line =~ /^type .*connect/i); } print $SOCK "connect $botName $botPass\n"; sleep 1; print "$botName has connected.\n"; if ($entryMessage ne "") { print $SOCK $entryMessage; } { # throw away input until we see the line after the 'Visible Exits:' line" # just in case we've entered it wrong, throw away no more than 50 lines. my $counter = 0; my $break = 0; while (defined($line = <$SOCK>)) { last if $break; if ($debug == 2) { print $line; } $break = 1 if ($line =~ /^Visible Exits:/); last if ($counter++ == 50); } } print "$botName is active.\n"; MAIN: while (1) { # let's see how well this alarm works: eval { local $SIG{ALRM} = sub { die "alarm went off\n"; }; alarm 60; $line = <$SOCK>; alarm 0; }; if ($@) { if ($@ !~ /alarm went off/) { die; } else { print $SOCK "whisper *alex = keepalive\n"; next; } } last unless defined $line; if ($debug == 2) { print $line; } $line =~ s/[\n\r \t]+$//; # chomp doesn't seem to be working here. # totally ignore any line that starts with "You whisper" or "You page" # to avoid giving away secret stuff. also, it'd be a mess when # recapping to someone. also ignore blank lines. next if ($line =~ /^(You|$botName) (page|whisper|privately posed)/i || $line eq ""); my($origLine) = $line; # Possible conversation things of interest: # You whisper "hi" to inky. # inky whispers, "hi" # inky pages: hi # You paged inky: hi # You [say|ask|exclaim], "bye gunther" # You [say|ask|exclaim] (to whoever), "bye gunther" # inky [says|asks|exclaims], "bye gunther" # inky [says|asks|exclaims] (to whoever), "bye gunther" # [channel] You [say|ask|exclaim], "bye gunther" # [channel] You [say|ask|exclaim] (to whoever), "bye gunther" # [channel] inky [says|asks|exclaims], "bye gunther" # [channel] inky [says|asks|exclaims] (to whoever), "bye gunther" my($channel, $speaker, $target, $method, $text) = ("", "", "", "", ""); my $speechCommand = 1; # first assume it's speech. if ($line =~ /^\[[^ \]]+\]/) # if it begins with [text] trim that { $channel = (split(' ', $line))[0]; $line = substr($line, length($channel) + 1); $channel = "#" . substr($channel, 1, length($channel) - 2); } # Ignore things that aren't says or whispers or pages if ($line =~ /^([^ ]+) (says|asks|exclaims), \"(.*)\"/) { $speaker = $1; $target = ""; $channel = "say" if ($channel eq ""); $method = ""; $text = $3; } elsif ($line =~ /^([^ ]+) (?:says|asks|exclaims) \((?:to|of|at) ([^\)]+)\), \"(.*)\"/) { $speaker = $1; $target = $2; $channel = "say" if ($channel eq ""); $method = ".."; $text = $3; } elsif ($line =~ /^([^ ]+) whispers, \"(.*)\"/) { $speaker = $1; $target = $botName; $channel = "whisper"; $text = $2; } elsif ($line =~ /^([^ ]+) privately poses to you: (.*)/) { $speaker = $1; $target = $botName; $channel = "whisper"; $method = ".."; $text = $2; } elsif ($line =~ /^([^ ]+) pages: (.*)/) { $speaker = $1; $target = $botName; $channel = "page"; $text = $2; } elsif ($line =~ /^([^ ]+) pages?-poses: (.*)/) { $speaker = $1; $target = $botName; $channel = "page"; $method = ".."; $text = $2; } elsif ($line =~ /^([^ ]+) hollers, "(.*)"/) { $speaker = $1; $target = ""; $channel = "\@holler"; $method = ""; $text = $2; } elsif ($line =~ /^([^ ]+) hollers \((?:to|of|at) ([^\)]+)\), \"(.*)\"/) { $speaker = $1; $target = $2; $channel = "\@holler"; $method = ".."; $text = $3; } else { $speechCommand = 0; # if it's not a conversation thing, it can't be a @holler or whatever. # the only possibilities are normal speech and a channel talk. $channel = "say" if (substr($channel, 0, 1) ne "#"); $text = $line; if ($line =~ /^\(from (\S+)\)/i) { $speaker = $1; } else { $line =~ /^ *(\S+)/; $speaker = $1; } } $text =~ s/^\s+//; $text =~ s/\s+$//; # ok, at this point, decide whether to add the thing to our buffer # or not (ie, add it if it's not a whisper or a page) if ($channel ne "page" && $channel ne "whisper") { my $dontLog = 0; foreach my $l (@dontLogList) { $dontLog = 1 if ($origLine =~ /$l/); # not /i last if ($dontLog); } goto NOLOG if ($dontLog); # skip on ahead if we don't want to log this # convert "you say" to "alex says" $origLine =~ s/^(\[[^\]+]\] |)You ([^\s,]+)/$1$botName $2s/i; push @buffer, [ lc($channel), lc($speaker), $origLine ]; shift @buffer if (scalar(@buffer) > $maxBufferSize); # too big? # search for urls my @urls = $origLine =~ /((?:http|ftp):\/\/[^\s\"\']+)/ig; if (@urls) { foreach my $u (@urls) { # remove any ending punctuation $u =~ s/[\.\,\?\!]$//; if ($#urlBuffer == -1 || $urlBuffer[0][2] ne $u) # don't push duplicates { push @urlBuffer, [ lc($channel), lc($speaker), $u ]; shift @urlBuffer if (scalar(@urlBuffer) > $maxURLBufferSize); } } } if ($logFile ne "") { if (eval $logFunc) { &printHTML($logHandle, $origLine . "\n"); if ($logLines++ >= $logLimit) { &stopLogging($SOCK); if ($debug > 0) { print "LOG AUTO-ENDING\n"; } } } } } NOLOG: # stop here if this is us talking next MAIN if (lc $speaker eq lc $botName || lc $speaker eq "you"); if ($speechCommand) { if ($debug > 0) { print "Channel: $channel, Speaker: $speaker, Target: $target, Method: $method\nText: $text\n"; } my($i); for ($i = 0; $i < $#responses; $i += 2) { if ($text =~ /$responses[$i]/i) { if (!&DealWith($responses[$i+1], $SOCK, $channel, $speaker, $target, $method, $text)) { next MAIN; } } } if (lc $target eq lc $botName) { # if we got here, it was a response addressed to us, but we # didn't understand it. &respond($SOCK, $channel, "..", $speaker, "Awwwk! No parse found!"); } } else { # don't print it out. in debug = 2 we'd do that anyway. my $i; for ($i = 0; $i < $#nonConvResponses; $i += 2) { if ($text =~ /$nonConvResponses[$i]/i) { if (!&NCDealWith($nonConvResponses[$i+1], $SOCK, $text)) { next MAIN; } } } } } &dumpMemoryToFile($memoryFile); print "Disconnected at ", scalar(localtime), "\n"; # Stuff to add or think about adding or whatever: # # liza says (to thumper), "Like we could tell it to show us /incoming on gmd # or something." # liza asks (to Birdie), "Is retina down?" # thumper asks (to birdie), "xyzzy?" # [Alex] inky says, "I guess it could break up what it hears by sentences" # [Alex] thumper says (to birdie), "HAND stands for Have A Nice Day." # [Alex] thumper asks (to birdie), "a potato is what?" # [Alex] Birdie says (to thumper), "Okay, thumper, a potato is what." # markm whispers, "Alex should handle a 'what-do-you-know-about' question as a # keyword-grep kind of thing." sub DealWith { my($value, $HANDLE, $channel, $speaker, $target, $method, $text) = @_; if (ref $value) { return &{$value}($HANDLE, $channel, $speaker, $target, $method, $text); } else { print $HANDLE $value, "\n"; return 0; } } sub NCDealWith { my($value, $HANDLE, $text) = @_; if (ref $value) { return &{$value}($HANDLE, $text); } else { print $HANDLE $value, "\n"; return 0; } } sub test { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; sleep 1; # pause before dealing with it print $HANDLE "say Awwwk! Function called ", $testCount++, " time(s)!\n"; return 0; } sub quit { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. if (lc $speaker ne lc $owner) { &respond($HANDLE, $channel, "..", $speaker, "Awwk! But $owner said I could stay up another hour!"); } else { &respond($HANDLE, $channel, "", $speaker, "Awwk! Time for nap!"); if ($logFile ne "") { print $logHandle "\n[Log finished ", scalar(localtime(time)), "]\n"; close $logHandle; system("/opt/ifmud/web/alex/build-index.pl"); $logFile = ""; } print $HANDLE "\nquit\n"; print "***$speaker asked me to quit.***\n"; } return 0; } sub greet { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it if ($friends{lc $speaker}) { &respond($HANDLE, $channel, "..", $speaker, "Awwwk! Hi $speaker! Did you bring me a cork nut?"); } else { &respond($HANDLE, "page", "", $speaker, "Hey there $speaker, my name is $botName and I will be " . "your bot for tonight. For help on what I can do, try " . "'page $botName = help'"); $friends{lc $speaker} = 1; } return 0; } sub leave { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it &respond($HANDLE, $channel, "..", $speaker, "Awwk! Bye-bye!"); return 0; } sub praise { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it &respond($HANDLE, $channel, "..", $speaker, "Awwwk! So where's my cork nut then?"); return 0; } sub fuckyou { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it &respond($HANDLE, $channel, "..", $speaker, "Um, at seven?"); return 0; } sub loveyou { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it &respond($HANDLE, $channel, "..", $speaker, "Awwk! If you truly cared about me, you'd pass the corknuts."); return 0; } sub shutup { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it my @lines = ( "Um, at seven?", "Awwwk! Just trying to help!", "It's not easy being a parrot.", "Not unless you give me a cork nut.", ); &respond($HANDLE, $channel, "..", $speaker, $lines[int(rand(@lines))]); return 0; } # thanks to Adam for the line: sub applause { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it &respond($HANDLE, $channel, "..", $speaker, "Awwwk! You're a great crowd! I'll be here all night -- try the ". "tarte au chocolat aux cork nuts!"); return 0; } sub leaveComp { my($HANDLE, $text) = @_; return 1 if ($text !~ m|^(\#if/comps/comp../\S+)|); # enh, something weird print $HANDLE "\@leavechannel $1\n"; return 0; } sub giveHelp { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it my $word = ""; if ($text =~ /^help +(\S+)/i) { $word = lc $1; } else { $word = "help"; # get generic "help on help" } $word = "help" if ($word eq "me"); if (defined $helpText{$word}) { foreach my $line (split(/\n/, $helpText{$word})) { &respond($HANDLE, "page", "", $speaker, $line); } } else { &respond($HANDLE, "page", "", $speaker, "Help topic unknown. Try 'page $botName = help'"); } return 0; } sub corkNut { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; my $timeDiff = time() - $lastCorkTime; $timeDiff = 1 if ($timeDiff <= 0); return 1 if (lc $target ne lc $botName && # must be addressed to us. $timeDiff + rand(120) < 300); sleep 1; # pause before dealing with it $corkNutCount++; if (int(rand(10)) == 3) { &respond($HANDLE, $channel, ":", $speaker, "awwwks. \"$corkNutCount nuts corked so far!\""); } else { &respond($HANDLE, $channel, ":", $speaker, 'awwwks. "Want cork nut!"'); } $lastCorkTime = time(); return 0; } sub reportCorkCount { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; sleep 1; # pause before dealing with it &respond($HANDLE, $channel, ":", $speaker, "awwwks. \"$corkNutCount nuts corked so far!\""); return 0; } sub consumeCorkNut { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. $text =~ s/(\?|\!|\.|\,|\s)+$//; return 1 if ($text !~ /eat +(?:the +|a +|)(.*?)(?:[\!\?\.\,]+.*)?$/i); my $food = $1; if ($food eq "me") { return &fuckyou($HANDLE, $channel, $speaker, $target, $method, $text); } sleep 1; # pause before dealing with it print $HANDLE "eat $food\n"; # apparently it's a bad idea to have alex drop anything after trying # to eat it; still, we don't want him cluttering his inventory up with # cork nuts if ($food =~ /cork/i) { print $HANDLE "drop $food\n"; } else { print $HANDLE 'page inky = awwk! "' . $food . '" not tasty!'; print $HANDLE "\n"; } return 0; } sub errorResponse { my($HANDLE, $text) = @_; if ($text =~ /^I don\'t see that here\.$/) { &respond($HANDLE, "say", "", "", "$botName doesn't see that here!"); } elsif ($text =~ /^That doesn\'t look very appetizing\.$/) { &respond($HANDLE, "say", "", "", "$botName doesn't want to eat that!"); } else { return 1; } return 0; } sub doDump { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. &dumpMemoryToFile($memoryFile); &respond($HANDLE, $channel, ":", $speaker, 'awwwks. "Memory saved!"'); return 0; } sub recap { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. # recap/url recap are combined now. we determine which one to use based # on the word: if it has "urls" do a url recap, else do a normal recap. # this allow the syntax 'recap urls' eg if ($text !~ s/^((?:(?:recap|recall|urls) +)+)//i) { &respond($HANDLE, "page", "", $speaker, "Syntax: recap|urls [] " . "[<#channel>]"); return 0; } my $recapType = 0; # 0 = recap, 1 = urls if ($1 =~ /urls/) { $recapType = 1; } else { $recapType = 0; } sleep 1; # pause before dealing with it if ($channel ne "page" && $channel ne "whisper") { &respond($HANDLE, "page", ":", $speaker, "awwks. Recap requests should be done with page/whisper."); return 0; } my ($lineTest, $lines) = &recapHelper($HANDLE, $speaker, $channel, $text, 1); return 0 if (!defined($lineTest)); # decide which buffer to look at based on the type my $theBuffer = \@buffer; if ($recapType == 1) # eg, urls { $theBuffer = \@urlBuffer; } if ($lines > 500 || $lines < 1) { &respond($HANDLE, "page", "", $speaker, "Recap limited to 1-500 lines."); return 0; } my $index = $#{$theBuffer} + 1; my $count = 0; # and fix the lineTest function by subbing in the %s's $lineTest = sprintf($lineTest, '$theBuffer->[$index][0]', '$theBuffer->[$index][1]', '$theBuffer->[$index][2]'); while ($count < $lines && --$index >= 0) { $count++ if (eval($lineTest)); } $index = 0 if ($index < 0); if ($count == 0) { &respond($HANDLE, "page", "", $speaker, "Awwwk! No relevant information in recap!"); return; } elsif ($lines > $count) { &respond($HANDLE, "page", "", $speaker, "Buffer not that long, recapping all."); } else { my $resp = "Recapping last "; if ($count != 1) { $resp .= "$count "; } if ($recapType == 0) { $resp .= "line"; } elsif ($recapType == 1) { $resp .= "url"; } if ($count != 1) { $resp .= "s"; } &respond($HANDLE, "page", "", $speaker, $resp); } if ($debug > 0) { print "RECAPPING for $speaker $lines LINES\n"; } my $sleepcount = 0; for (; $index <= $#{$theBuffer}; $index++) { if (eval($lineTest)) { &respond($HANDLE, "page", "", $speaker, $theBuffer->[$index][2]); sleep 1 if (++$sleepcount % 25 == 0); # happy april fool's day: if (is_aprilmode() && (rand(70) < 10)) { &respond($HANDLE, "page", "", $speaker, april_recall()); } } } return 0; } sub logToFile { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; my($syntax) = "Syntax: log [] " . "[|] [#]"; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it $text =~ s/^(record|script)/log/i; if ($text =~ /^log +(off|end|over|stop|quit)/i || $text =~ /^close log/i || $text =~ /^unscript/i) { if ($logFile eq "") { &respond($HANDLE, $channel, "", $speaker, "Awwwk! Log not in progress!"); } else { &stopLogging($HANDLE); } return 0; } elsif ($text !~ s/^log +(\S+)//i) { &respond($HANDLE, "page", "", $speaker, $syntax); return 0; } my $filename = $1; if ($logFile ne "") { &respond($HANDLE, "page", "", $speaker, "Already logging to '$logFile'!"); return 0; } if ($filename =~ /[\s\/\.\~\*\?]/) { &respond($HANDLE, "page", "", $speaker, "Filenames should not contain slashes, periods, tildes, " . "asterisks, question marks, or whitespace."); return 0; } if ($filename =~ /^\d/) { &respond($HANDLE, "page", "", $speaker, "Filenames should not begin with a number."); return 0; } if (-e $logDirectory . $filename . ".html" or -e $logDirectory . $filename . ".txt") { &respond($HANDLE, "page", "", $speaker, "Awwk! File already exists!"); return 0; } ($logFunc, $logLines) = &recapHelper($HANDLE, $speaker, $channel, $text, 1); return 0 if (!defined($logFunc)); if (!open(LOG, ">" . $logDirectory . $filename . ".html")) { &respond($HANDLE, "page", "", $speaker, "Error opening file, tell $owner if this is a problem."); return 0; } $logFile = $filename; print LOG "\n\n$filename"; print LOG "\n\n"; print LOG "\n"; print LOG "Back to the main page\n
\n"; print LOG "

[Log started by $speaker ", scalar(localtime(time)), "]"; print LOG "

\n\n"; $logHandle = \*LOG; # we may want to recap some backlog if ($logLines > 1000 || $logLines < 0) { &respond($HANDLE, "page", "", $speaker, "Log recap limited to 1-1000 lines."); return 0; } elsif ($logLines > 0) # take some stuff from recap buffer to log { my $index = @buffer; my $count = 0; # and fix the lineTest function by subbing in the %s's my $lineTest = sprintf($logFunc, '$buffer[$index][0]', '$buffer[$index][1]', '$buffer[$index][2]'); while ($count < $logLines && --$index >= 0) { $count++ if (eval($lineTest)); } $index = 0 if ($index < 0); if ($debug > 0) { print "RECAPPING for LOG $logLines LINES\n"; } for (; $index <= $#buffer; $index++) { if (eval($lineTest)) { &printHTML($logHandle, $buffer[$index][2] . "\n"); } } } $channel = "say" if ($channel eq "page" || $channel eq "whisper"); &respond($HANDLE, $channel, "", $speaker, "Awwk! Log started!"); $logChannel = $channel; # and fix this: $logFunc = sprintf($logFunc, '$channel', '$speaker', '$origLine'); return 0; } sub stopLogging { my $HANDLE = shift; print $logHandle "\n
[Log finished ", scalar(localtime(time)), "]\n"; print $logHandle "

\nBack to the main page

\n"; print $logHandle "\n\n"; close $logHandle; system("/opt/ifmud/web/alex/build-index.pl"); $logHandle = undef; # enh, whatever: # $logChannel = "say" if ($logChannel eq "page" || $logChannel eq "whisper"); &respond($HANDLE, $logChannel, "", "", "Awwwk! Log over! File is " . $logHeader . $logFile . ".html"); $logFile = ""; if ($debug > 0) { print "LOG ENDING\n"; } } # This method takes in a user's command line (eg, "10 #alex 'foo'") # and returns a tuple of a string which can be evaluated for each line # to determine if it should be included in the recap and a linecount to # recap. For instance # [ '(lc(%s) eq "alex") && (1 || (%s)) && ((%s) =~ /\Qfoo/i)', 10 ] # Note the %s's should be replaced (eg, with sprintf) with the appropriate # variable names, in order: channel name, speaker, buffer text # If $verbose is 1, this message handles error messages to the user. In # any case, this returns undef for the first arg if there was a problem, # in which case the calling command should abort also. NOTE: this does not, # however, handle errors for having the wrong number of lines (since recap # allows 1-500 and log allows 0-1000) sub recapHelper { my($HANDLE, $speaker, $channel, $text, $verbose) = @_; my ($lines, $recapChannel, $searchFor) = (0, $channel, ""); $recapChannel = "say" if ($recapChannel eq "page" || $recapChannel eq "whisper"); foreach (split(' ', $text)) { if (/^-?[0-9]+$/) { $lines = $_; } elsif (/^\#/) { $recapChannel = lc $_; } elsif (/^([\"\']).*\1$/) { $searchFor = $_; } else { $searchFor = lc $_; $searchFor = lc $botName if ($searchFor eq "you"); $searchFor = lc $speaker if ($searchFor eq "me"); } } # now, we create the testing function that says whether to recap this # line or not # first the channel match, then speaker match, then text match my $func; # default is say/@holler/"" if ($recapChannel eq "" || $recapChannel =~ /^([\"\'])\s*\1$/) { $func = '((%s) =~ /^(say|\@holler|)$/i) && '; } else { $func = '(lc(%s) eq "' . quotemeta(lc $recapChannel) . '") && '; } if ($searchFor eq "") # they don't care about the speaker/text at all { $func .= '(1 || %s) && (1 || %s)'; } elsif ($searchFor =~ /^([\"\'])(.*)\1$/) # text must contain keyphrase { $func .= '(1 || %s) && (%s =~ /' . quotemeta($2) . '/i)'; } else # speaker must be { $func .= '(lc(%s) eq "' . quotemeta($searchFor) . '") && (1 || %s)'; } return ( $func, $lines ); } sub transPhrase { my($phrase, $speaker, $target) = @_; my(@words) = split(' ', $phrase); foreach (@words) { my($lcw) = lc $_; if ($lcw eq "i" || $lcw eq "me") { $_ = $speaker; } elsif ($lcw eq "my") { $_ = $speaker . "'s"; } elsif ($lcw eq lc $botName . "'s") { $_ = "my"; } elsif (lc $target eq lc $botName) { if ($lcw eq "you") { $_ = $target; } elsif ($lcw eq "your") { $_ = "my"; } } } return join(' ', @words); } sub simplifyPhrase { my($phrase, $speaker, $target) = @_; $phrase = lc $phrase; $speaker = lc $speaker; $target = lc $target; my $prev = $phrase; $phrase =~ s/[\"\'\.]//g; substr($phrase, 1, -1) =~ s/\-//g # first and last -s are ok if (length($phrase) > 2); $phrase = $prev if ($phrase eq ""); # eg, simplifying "." my(@words) = grep(!defined($stopwords{$_}), split(' ', $phrase)); # if it consists only of stopwords, don't eliminate them! if (! @words) { @words = split(' ', $phrase); } foreach (@words) { if ($_ eq "i" || $_ eq "me") { $_ = $speaker; } elsif ($_ eq lc $botName . "s") { $_ = "my"; } elsif ($_ eq "my") { $_ = $speaker . "s"; } elsif ($target eq lc $botName) { if ($_ eq "you") { $_ = $target; } elsif ($_ eq "your") { $_ = "my"; } } } return join(' ', @words); } # need this third subroutine to avoid the my<->your flipbacks sub simplifyNoTransPhrase { my $phrase = lc $_[0]; my $prev = $phrase; $phrase =~ s/[\"\'\.]//g; substr($phrase, 1, -1) =~ s/\-//g # first and last -s are ok if (length($phrase) > 2); $phrase = $prev if ($phrase eq ""); # eg, simplifying "." my(@words) = grep(!defined($stopwords{$_}), split(' ', $phrase)); # if it consists only of stopwords, don't eliminate them! if (! @words) { @words = split(' ', $phrase); } return join(' ', @words); } sub learnDefinition { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it # delete the final punctuation if necessary $text =~ s/\s*(\?|\!|\.|\,)*\s*$//; # eliminate multiple spaces $text =~ s/\s+/ /; # if it begins with "learn", remove that. $text =~ s/^learn\:\s*//i; # consider the case of possessives. "jaybird's aunt is crazy" shouldn't # map to "jaybird is aunt is crazy". but "everbody's crazy" should have # the 's map to is. The best solution I can think of is for 's to # happen with less preference than the others: if (($text !~ /(.+?)( +(is|are|am|were|was)|(\'re|\'m)) +(.+)/i) && ($text !~ /(.+?)(((\'s))) +(.+)/i)) { &respond($HANDLE, $channel, "..", $speaker, "Awwk! $botName is confused."); return 0; } my($phrase, $index, $isare, $definition) = (&transPhrase($1, $speaker, $target), &simplifyPhrase($1, $speaker, $target), $2, $5); # fix up spaces, also translate 's -> is, etc $isare =~ s/\s+//; if ($isare eq "'s") { $isare = "is"; } elsif ($isare eq "'re") { $isare = "are"; } elsif ($isare eq "'m") { $isare = "am"; } $isare = "is" if ($isare eq "am" || $index eq lc($botName)); # check if this is an also. my($also) = $definition =~ s/^also +(\S+)/$1/i; if (defined($memory{$index})) { my($ph, $aliases, $isa, $defs); $ph = $memory{$index}->[0]; $aliases = $memory{$index}->[1]; $isa = $memory{$index}->[2]; $defs = $memory{$index}->[3]; # if $ph is an alias, treat this as though we were definining # the aliased thing if (!(ref $aliases)) { $ph = $memory{$aliases}->[0]; $phrase = $ph; # a hack, but it should be ok $isa = $memory{$aliases}->[2]; $defs = $memory{$aliases}->[3]; $index = $aliases; $aliases = $memory{$aliases}->[1]; } # let's have it append by default, instead of complaning. # so do the same thing as if they'd done "also" # if (!$also) # { # my($defn) = $defs->[0]; # &respond($HANDLE, $channel, "..", $speaker, # "$botName knows $ph $isa $defn!"); # } # else { # check for duplicates before adding: foreach my $d (@$defs) { my $s1 = lc $d; my $s2 = lc $definition; $s1 =~ s/[\'\"]//g; $s2 =~ s/[\'\"]//g; if ($s1 eq $s2) { &respond($HANDLE, $channel, "..", $speaker, "$botName already knew that!"); return 0; } } # ok, add the additional definition in. push(@$defs, $definition); # and the reverse definition: if (length($definition) < 100) { my $simpDef = &simplifyNoTransPhrase($definition); if (defined $reverseMemory{$simpDef}) { push @{ $reverseMemory{$simpDef}->[1] }, $index; } elsif ($simpDef ne $index) # fix for "A IS A" -- thx DG { $reverseMemory{$simpDef} = [ $definition, [ $index ] ]; } } &respond($HANDLE, $channel, "..", $speaker, "Okay, " . ((length($phrase) < 60) ? $phrase : "that long thing you just said") . " $isare also " . ((length($definition) < 60) ? "$definition." : ((length($phrase) < 60) ? "that long thing you just said." : "that other long thing you said."))); push @recentlyLearned, $phrase unless grep $_ eq $phrase, @recentlyLearned; shift @recentlyLearned if ($#recentlyLearned > 4); @lastLearned = ($phrase, $definition); if ($debug > 0) { print "Learning: $index IS ALSO $definition.\n";} } } else { if (!$also) { $memory{$index} = [ $phrase, [], $isare, [ $definition ] ]; # and the reverse definition: if (length($definition) < 100) { my $simpDef = &simplifyNoTransPhrase($definition); if (defined $reverseMemory{$simpDef}) { push @{ $reverseMemory{$simpDef}->[1] }, $index; } elsif ($simpDef ne $index) # fix for "A IS A" -- thx DG { $reverseMemory{$simpDef} = [ $definition, [ $index ] ]; } } &respond($HANDLE, $channel, "..", $speaker, "Okay, " . ((length($phrase) < 60) ? $phrase : "that long thing you just said") . " $isare " . ((length($definition) < 60) ? "$definition." : ((length($phrase) < 60) ? "that long thing you just said." : "that other long thing you said."))); push @recentlyLearned, $phrase unless grep $_ eq $phrase, @recentlyLearned; shift @recentlyLearned if ($#recentlyLearned > 4); @lastLearned = ($phrase, $definition); if ($debug > 0) { print "Learning: $index IS $definition.\n"; } } else { # if we get here, they've told us something is "also" but # didn't tell us what it was the first time. um. &respond($HANDLE, $channel, "..", $speaker, "But $botName doesn't know about $phrase yet!"); } } if ($lastDump++ >= $dumpInterval) { if ($debug > 0) { print "AUTO-DUMPING...\n"; } &dumpMemoryToFile($memoryFile); $lastDump = 0; } return 0; } sub forgetDefinition { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it # delete the final punctuation if necessary $text =~ s/\s*(\?|\!|\.|\,)*\s*$//; # eliminate multiple spaces $text =~ s/\s+/ /; # the syntax could be any of # - "forget the monkey" # - "forget about the monkey" # - "forget the monkey is furry" # - "forget that the monkey is furry" # - "forget that the monkey means furry" (technically only useful for # aliases, but it's easier to allow it for both) # - "the monkey doesn't mean furry" (ditto) # - "forget that|it" (forget the list thing learned) # - "the monkey is not furry" (currently not allowed) my($term, $definition); if ($text =~ /^forget +(that|it)$/i) { # they want to forget the last thing they were talking about if (@lastLearned) { ($term, $definition) = @lastLearned; @lastLearned = (); # and clear this } else { &respond($HANDLE, $channel, "..", $speaker, "Awwk! $botName already did!"); return 0; } } elsif (($text =~ /^forget( +that)? +(.+?)( +(is|are|am|was|were|means)|(\'re|\'m)) +(.+)/i) || ($text =~ /^forget( +that)? +(.+?)(((\'s))) +(.+)/i)) { $term = $2; $definition = $6; } elsif ($text =~ /^forget +(who|what|where) +(.+) +(is|are|was|were|am)/i) { $term = $2; $definition = ""; } elsif ($text =~ /^forget( +about)? +(.+)/i) { $term = $2; $definition = ""; } elsif (($text =~ /(.+?)( +(is|are|am|was|were)|(\'re|\'m)) +not +(.+)/i) || ($text =~ /(.+?)(((\'s))) +not +(.+)/i)) { $term = $1; $definition = $5; } elsif ($text =~ /(.+?) +(doesn\'t|does not) +mean +(.+)/i) { $term = $1; $definition = $3; } else { &respond($HANDLE, $channel, "..", $speaker, "Awwk! $botName is confused."); return 0; } my($phrase, $index) = (&transPhrase($term, $speaker, $target), &simplifyPhrase($term, $speaker, $target)); if (defined($memory{$index})) { my($ph, $aliases, $isa, $defs) = ($memory{$index}->[0], $memory{$index}->[1], $memory{$index}->[2], $memory{$index}->[3]); if ($definition ne "") { if (ref $aliases) { my(@temp); my($found) = ""; foreach (@$defs) { if (lc $_ eq lc $definition) { $found = $_; } else { push @temp, $_; } } if ($found) { if (@temp > 0) { $memory{$index}->[3] = \@temp; } else { foreach my $alias (@$aliases) { delete $memory{$alias}; } delete $memory{$index}; } if (length($definition) < 100) { my $simpDef = &simplifyNoTransPhrase($definition); if (defined $reverseMemory{$simpDef}) { my @tmp; foreach (@{ $reverseMemory{$simpDef}->[1] }) { push @tmp, $_ if ($_ ne $index); } if (@tmp) { $reverseMemory{$simpDef}->[1] = \@tmp; } else { delete $reverseMemory{$simpDef}; } } } &respond($HANDLE, $channel, "..", $speaker, "Okay, $ph $isa not $found."); } else { &respond($HANDLE, $channel, "..", $speaker, "But $botName doesn't think $ph $isa " . "$definition!"); } } else { my $simpDef = &simplifyPhrase($definition, $speaker, $target); if ($simpDef eq $aliases) { delete $memory{$index}; my(@temp); foreach (@{ $memory{$aliases}->[1] }) { push(@temp, $_) if ($_ ne $index); } $memory{$aliases}->[1] = \@temp; &respond($HANDLE, $channel, "..", $speaker, "Okay, $ph $isa no longer an alias for " . "$definition."); } else { &respond($HANDLE, $channel, "..", $speaker, "$ph isn't aliased to that!"); } } } else { if (! (ref $aliases)) { my(@temp); foreach (@{ $memory{$aliases}->[1] }) { push(@temp, $_) if ($_ ne $index); } $memory{$aliases}->[1] = \@temp; } else { foreach my $alias (@$aliases) { delete $memory{$alias}; } } foreach my $def (@{ $memory{$index}->[3] }) { if (length($def) < 100) { my $simpDef = &simplifyNoTransPhrase($def); if (defined $reverseMemory{$simpDef}) { my @tmp; foreach (@{ $reverseMemory{$simpDef}->[1] }) { push @tmp, $_ if ($_ ne $index); } if (@tmp) { $reverseMemory{$simpDef}->[1] = \@tmp; } else { delete $reverseMemory{$simpDef}; } } } } delete $memory{$index}; my $forget = "forgets about $ph. \"Now I don't believe in " . "anything!"; if (int(rand(10)) == 7) { $forget .= " -- except, of course, in the infallibility of " . "Bodmin's hats."; } $forget .= "\""; &respond($HANDLE, $channel, ":", $speaker, $forget); } if ($debug > 0) { print "Forgetting: $index ISN'T $definition.\n"; } } else { # telling us to forget something we don't know about &respond($HANDLE, $channel, "..", $speaker, "But $botName doesn't know about $phrase yet!"); } return 0; } sub answerQuery { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (($nonFriends{lc $speaker} || $DIRECT_ONLY) && lc $target ne lc $botName); # delete the final punctuation if necessary $text =~ s/\s*(\?|\!|\.|\,)*\s*$//; # eliminate multiple spaces $text =~ s/\s+/ /; my $queryText; # decide what format this falls into: if ($text =~ /.*?(what|who|where)( +(is|are|am|was|were)|(\'s|\'re|\'m)) +(.*)/i) { $queryText = $5; } elsif ($text =~ /.*?(what|who|where) +(does|do) +(.+)(mean|stand +for)/i) { $queryText = $3; } else { &respond($HANDLE, $channel, "..", $speaker, "Awwk! $botName is confused."); return 0; } if (lc $target eq lc $botName) { push @recentlyAsked, $queryText unless grep $_ eq $queryText, @recentlyAsked; shift @recentlyAsked if ($#recentlyAsked > 4); } my($lookup) = &simplifyPhrase($queryText, $speaker, $target); # if the phrase consists entirely of don't-learn words, # don't answer unless this was directed to us return 1 if ((lc $target ne lc $botName) && defined($dontLearnWords{$lookup})); if ($debug > 0) { print "Retrieving: $lookup\n"; } my $response = ""; if (defined($memory{$lookup})) { $response = &internalAnswerQuery($HANDLE, $channel, $speaker, $target, $method, $lookup); } if (defined($reverseMemory{$lookup})) { if ($response ne "") { $response .= " Furthermore, "; } $response .= &internalAnswerReverseQuery($HANDLE, $channel, $speaker, $target, $method, $lookup); } if ($response eq "") # eg, didn't know any answer. { # We don't know the answer. Maybe it's because it was two # questions stuck together, like "Who's alex? huh?" # so if there is a ? in this phrase, delete it and everything after # and re-try the lookup if ($queryText =~ s/\?.*//) { $lookup = &simplifyPhrase($queryText, $speaker, $target); # if the phrase consists entirely of don't-learn words, # don't answer unless this was directed to us return 1 if ((lc $target ne lc $botName) && defined($dontLearnWords{$lookup})); if ($debug > 0) { print "Retrieving: $lookup\n"; } if (defined($memory{$lookup})) { $response = &internalAnswerQuery($HANDLE, $channel, $speaker, $target, $method, $lookup); } if (defined($reverseMemory{$lookup})) { if ($response ne "") { $response .= " Furthermore, "; } $response .= &internalAnswerReverseQuery($HANDLE, $channel, $speaker, $target, $method, $lookup); } } } if ($response eq "") { # Ok, we really don't know it. But only say so if the question was # directed to us. return 1 if (lc $target ne lc $botName); # just ignore it sleep 1; # pause before dealing with it &respond($HANDLE, $channel, "..", $speaker, "Awwwk! Sorry, $botName doesn't know anything about it. " . "(Teach me with \"..$botName $queryText " . (($queryText eq "i") ? "am" : "is") . " funny.\")"); } else { sleep 1; &respond($HANDLE, $channel, "..", $speaker, "Awwwk! Word on the street is that " . $response); } return 0; } sub internalAnswerQuery { my($HANDLE, $channel, $speaker, $target, $method, $lookup) = @_; my($oldphrase, $oldisare); my($phrase) = $memory{$lookup}->[0]; my($aliases) = $memory{$lookup}->[1]; my($isare) = $memory{$lookup}->[2]; my($defList) = $memory{$lookup}->[3]; if (!(ref $aliases)) { $oldphrase = $phrase; $oldisare = $isare; $phrase = $memory{$aliases}->[0]; $isare = $memory{$aliases}->[2]; $defList = $memory{$aliases}->[3]; } # give less info if not directed to us or not private if (lc $target ne lc $botName) { my @sl = @$defList; while (@sl > 1) { pop @sl; } $defList = \@sl; } elsif ($channel ne "page" && $channel ne "whisper" && lc($channel) ne "#alex") { my @sl = @$defList; while (@sl > 2) { pop @sl; } $defList = \@sl; } my $definition = $defList->[0]; for (my $i = 1; $i <= $#{$defList}; $i++) { if ($definition !~ /[\?\!\.]$/) { $definition .= "."; } $definition .= " Also, " . $defList->[$i]; } return ($oldphrase ? "$oldphrase $oldisare $phrase, which " : "$phrase ") . "$isare $definition."; } sub internalAnswerReverseQuery { my($HANDLE, $channel, $speaker, $target, $method, $lookup) = @_; my($definition) = $reverseMemory{$lookup}->[0]; my($keys) = $reverseMemory{$lookup}->[1]; my $result = ""; foreach my $key (@$keys) { $result .= "Also, " if ($result ne ""); $result .= $memory{$key}->[0] . " " . $memory{$key}->[2] . " " . $definition . ". "; } return $result; } sub answerYesNoQuery { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. # delete the final punctuation if necessary $text =~ s/\s*(\?|\!|\.|\,)*\s*$//; # delete everything through is/are/am $text =~ s/.*?(is|are|am|was|were) +//i; my($theyUsedAm) = ($1 eq "am" || $1 eq "Am"); # take a note # eliminate multiple spaces $text =~ s/\s+/ /; # this is somewhat trickier than the standard query, because we get # something like "(is) the ruler of the universe a monkey(?)" and it's # not immediately obvious where to break between the lookup and the # definition. So, we'll just brute-force it and try each combo: # "the" + "ruler...", "the ruler" + "of the ...", etc. # if we get through them all with no luck, then we gripe. # But what if our database contains ("monkey" => "funny", # "monkey queen" => "rich")? Consider the query "Is the monkey queen rich?" # Clearly this is true. But under the previous procedure, we'd try # "monkey" "queen rich" and get "no", because "monkey" => "funny". So it # looks like we need to go and look for the longest match, so we start # with all the phrase being the lookup and none the definition, and shift. # this is way inefficient, but whatevah. my(@words) = split(' ', $text); my $definition = pop @words; while (@words) { my($lookup) = &simplifyPhrase(join(' ', @words), $speaker, $target); if ($debug > 0) { print "Querying: $lookup (expecting $definition)\n";} my $popped = 0; if (defined($memory{$lookup})) { my($isare) = $memory{$lookup}->[2]; my($realDefs) = $memory{$lookup}->[3]; if (! (ref $memory{$lookup}->[1])) { $isare = $memory{$memory{$lookup}->[1]}->[2]; $realDefs = $memory{$memory{$lookup}->[1]}->[3]; } my($yes) = 0; if ($lookup eq &simplifyPhrase($definition, $speaker, $target)) { $yes = 1; # is a monkey a monkey? } if (!$yes) { foreach my $realDef (@$realDefs) { if (lc $definition eq lc $realDef) { $yes = 1; last; } } } if ($yes) { # someone should really make this return one of a # wacky set of random results. sleep 1; # pause before dealing with it &respond($HANDLE, $channel, "..", $speaker, "Awwwk! You betcha!"); return 0; } # there's a subtle bug in things like "Is the foo a bar"? # where the "a" is a stopword. # Correct it by giving us a second chance here: $definition = (pop @words) . " " . $definition; # shift! my($nextlookup) = &simplifyPhrase(join(' ', @words), $speaker, $target); # if the next one we'd look up is the same as the current one, # we get the second chance if ($nextlookup ne $lookup) { sleep 1; # pause before dealing with it $isare = "am" if ($lookup eq lc $botName); # tweak this $isare = "are" if ($theyUsedAm); &respond($HANDLE, $channel, "..", $speaker, "Awwwk! \u$isare not! \u$isare not!"); return 0; } } else { $definition = (pop @words) . " " . $definition; # shift! } } # if we got here, we never got a successful lookup. presumably # that means it's not in our database. # But only say so if the question was directed to us. return 1 if (lc $target ne lc $botName); # just ignore it sleep 1; # pause before dealing with it &respond($HANDLE, $channel, "..", $speaker, "Awwwk! $botName doesn't know!"); return 0; } # they asked something of the form "foo bar?" which didn't trigger any # previous ideas, so maybe it's an implied "what is a foo bar?" # but maybe it's not, so we shouldn't do any error message if we don't # know what a foo bar is. # also, what if they ask several questions, like, um "faq? where can I get it?" # ideally, we should look at each of the questions and try it. sub possibleQuery { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (($nonFriends{lc $speaker} || $DIRECT_ONLY) && lc $target ne lc $botName); # this got triggered with some text like "foo bar ? bleah baz". first, # we want to chop off the "bleah baz" part. $text =~ s/\?[^\?]*$/\?/; # delete the final punctuation if necessary # delete =s to allow for "MPAA = ?" syntax $text =~ s/\s*(\?|\!|\.|\,|\=)*\s*$//; # eliminate multiple spaces $text =~ s/\s+/ /; my ($lookup) = &simplifyPhrase($text, $speaker, $target); # if the phrase consists entirely of don't-learn words, # don't answer unless this was directed to us return 1 if ((lc $target ne lc $botName) && defined($dontLearnWords{$lookup})); if (lc $target eq lc $botName) { push @recentlyAsked, $lookup unless grep $_ eq $lookup, @recentlyAsked; shift @recentlyAsked if ($#recentlyAsked > 4); } if ($debug > 0) { print "Retrieving possible: $lookup\n"; } my $response = ""; if (defined($memory{$lookup})) { $response = &internalAnswerQuery($HANDLE, $channel, $speaker, $target, $method, $lookup); } if ((lc $target eq lc $botName) && defined($reverseMemory{$lookup})) { if ($response ne "") { $response .= " Furthermore, "; } $response .= &internalAnswerReverseQuery($HANDLE, $channel, $speaker, $target, $method, $lookup); } # there's a possibility this might be several questions one of which # (at least) we could answer. if ($response eq "" && $text =~ /\?/) { foreach my $query (split(/\?/, $text)) { my ($lookup) = &simplifyPhrase($query, $speaker, $target); # if the phrase consists entirely of don't-learn words, # don't answer unless this was directed to us next if ((lc $target ne lc $botName) && defined($dontLearnWords{$lookup})); if ($debug > 0) { print "Retrieving possible: $lookup\n"; } if (defined($memory{$lookup})) { $response = &internalAnswerQuery($HANDLE, $channel, $speaker, $target, $method, $lookup); } if ((lc $target eq lc $botName) && defined($reverseMemory{$lookup})) { if ($response ne "") { $response .= " Furthermore, "; } $response .= &internalAnswerReverseQuery($HANDLE, $channel, $speaker, $target, $method, $lookup); } } } if ($response eq "") # if we don't know, just shut up. { return 1; # signal "keep going" } else { sleep 1; &respond($HANDLE, $channel, "..", $speaker, "Awwwk! Word on the street is that " . $response); return 0; } } sub listKnowledge { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. # delete the final punctuation if necessary $text =~ s/\s*(\?|\!|\.|\,|\=)*\s*$//; if ($text !~ /^(what|who) +(do +you|does +$botName) +know( +about (\S+))?/i) { &respond($HANDLE, "page", "..", $speaker, "Awwk! $botName is confused."); return 0; } my $keyword = $4; my $resp = "Awwwk! $botName knows stuff"; $resp .= " about '$keyword'" if (defined($keyword)); $resp .= ": "; foreach my $k (keys %memory) { if (!$keyword || $memory{$k}->[0] =~ /\Q$keyword\E/i) { $resp .= $memory{$k}->[0] . ", "; } } &respond($HANDLE, "page", "..", $speaker, substr($resp, 0, -2)); return 0; } sub learnAlias { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it # delete the final punctuation if necessary $text =~ s/\s*(\?|\!|\.|\,|\=)*\s*$//; # eliminate multiple spaces $text =~ s/\s+/ /; if ($text !~ /(.+?)( +(means|mean|) +)(.+)/i) { &respond($HANDLE, $channel, "..", $speaker, "Awwk! $botName is confused."); return 0; } # basically, this should be "foo means bar", where foo is not known, # and bar is known. my($alias, $means, $def) = (&transPhrase($1, $speaker, $target), $3, &transPhrase($4, $speaker, $target)); $means = "means" if (lc $1 eq "i" || lc $1 eq "you"); my $simpAlias = &simplifyPhrase($alias, $speaker, $target); my $simpDef = &simplifyNoTransPhrase($def, $speaker, $target); # the alias shouldn't be known. if (defined($memory{$simpAlias})) { # determine the kind of error message to give. if (!(ref $memory{$simpAlias}->[1]) && &simplifyPhrase($memory{$simpAlias}->[1], $speaker, $target) eq $simpDef) { &respond($HANDLE, $channel, "..", $speaker, "$botName already knew that!"); } else { # I don't feel like checking if this thing is an already-defined # alias to something or a normal but already-defined word &respond($HANDLE, $channel, "..", $speaker, "Awwwk! $botName already knows about " . &transPhrase($alias, $speaker, $target) . "!"); } return 0; } elsif (!defined($memory{$simpDef})) { &respond($HANDLE, $channel, "..", $speaker, "But $botName doesn't even know what $def is!"); return 0; } # ok, we got here, so go ahead and add it in. careful, though: $def # might be an alias, in which case $alias should point to what $def points # to, not def itself. my $pointsTo = $memory{$simpDef}->[1]; if (!ref $pointsTo) { $simpDef = $pointsTo; $pointsTo = $memory{$simpDef}->[1]; $def = $memory{$simpDef}->[0]; } push @{ $pointsTo }, $simpAlias; my $isare = ($means eq "means") ? "is" : "are"; $memory{$simpAlias} = [ $alias, $simpDef, $isare, undef ]; &respond($HANDLE, $channel, "..", $speaker, "Okay, " . ((length($alias) < 60) ? $alias : "that long thing you just said") . " $means " . ((length($def) < 60) ? "$def." : ((length($alias) < 60) ? "that long thing you just said." : "that other long thing you said."))); if ($debug > 0) { print "Aliasing: $alias MEANS $def.\n"; } return 0; } sub ignorePhrase { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName || # must be addressed to us. ($channel ne "page" && $channel ne "whisper")); # private sleep 1; # pause before dealing with it # delete the final punctuation if necessary $text =~ s/\s*(\?|\!|\.|\,|\=)*\s*$//; if ($text !~ /^delword +(.*)/i) { &respond($HANDLE, "page", "..", $speaker, "Awwk! $botName is confused."); } else { # add to the list of words not to respond to $dontLearnWords{lc $1} = 1; &respond($HANDLE, "page", "..", $speaker, lc $1 . " added to ignore list."); } return 0; } sub setNonFriend { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it if ($text =~ /^ignore/i) { $nonFriends{lc $speaker} = 1; &respond($HANDLE, "page", "..", $speaker, "Okay, $botName will no longer respond to you unless " . "addressed directly."); } elsif ($text =~ /^notice/i) { delete $nonFriends{lc $speaker}; &respond($HANDLE, "page", "..", $speaker, "Okay, $botName will respond to you even when " . "not addressed directly."); } else { &respond($HANDLE, $channel, "..", $speaker, "Awwk! $botName is confused."); } return 0; } sub timeQuery { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it my($resp) = "Um, seven?"; my(@fields) = localtime(time); if ($fields[2] == 7 || $fields[2] == 19) { $resp .= " (Awwwk! A stopped parrot is right twice a day!)"; } &respond($HANDLE, $channel, "..", $speaker, $resp); return 0; } sub learnedQuery { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it my $resp = "Lately, people "; if (rand(100) < 50) { if (@recentlyLearned == 0) { $resp .= "haven't taught me anything. Slackers."; } else { $resp .= "have taught me about"; foreach (0..$#recentlyLearned-1) { $resp .= " " . $recentlyLearned[$_]; $resp .= "," if ($#recentlyLearned > 1); } $resp .= " and" if ($#recentlyLearned > 0); $resp .= " " . $recentlyLearned[$#recentlyLearned] . "."; } } else { if (@recentlyAsked == 0) { $resp .= "haven't been pestering me at all. "; } else { $resp .= "have asked me about"; foreach (0..$#recentlyAsked-1) { $resp .= " " . $recentlyAsked[$_]; $resp .= "," if ($#recentlyAsked > 1); } $resp .= " and" if ($#recentlyAsked > 0); $resp .= " " . $recentlyAsked[$#recentlyAsked] . "."; } } &respond($HANDLE, $channel, "..", $speaker, $resp); return 0; } sub genericQuery { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it # someone should make this give a variety of wacky responses &respond($HANDLE, $channel, "..", $speaker, "Um, seven?"); return 0; } sub maybeCheckPoll { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if ($channel ne "\@holler" || $speaker ne "PollBoy" || $text !~ /has changed the poll\!/); print $HANDLE "who\n"; return 1; # it's ok to have other responses to this } sub extractPoll { my($HANDLE, $text) = @_; return 1 if ($text !~ /^User +On +Idle +(.*)/); # enh, something weird pop @buffer; # we don't really want to keep that line. # although we can't help logging it. enh. my $poll = $1; my $justInCase = 0; my $pollster = "?"; my $line; while (defined($line = <$HANDLE>)) { last if ($line =~ /^End of List/ || $justInCase++ > 100); if ($line =~ /pollster: ([^\;]+)/) { $pollster = $1; } } push @buffer, [ "", lc $pollster, $pollster . " changes poll to: $poll" ]; shift @buffer if (scalar(@buffer) > $maxBufferSize); # too big? } sub joinChannel { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it if ($text !~ /^(\S+)\s+(\S.*)/ || ((lc($1) ne "jc") && (lc($1) ne substr("joinchannel", 0, length($1))))) { &respond($HANDLE, $channel, "..", $speaker, "Syntax: joinchannel \#channel [\#channel2 \#channel3...]"); } print $HANDLE "\@joinchannel $2\n"; return 0; } sub leaveChannel { my($HANDLE, $channel, $speaker, $target, $method, $text) = @_; return 1 if (lc $target ne lc $botName); # must be addressed to us. sleep 1; # pause before dealing with it if ($text !~ /^(\S+)\s+(\S+)/ || ((lc($1) ne "lc") && (lc($1) ne substr("leavechannel", 0, length($1))))) { &respond($HANDLE, $channel, "..", $speaker, "Syntax: leavechannel \#channel"); } print $HANDLE "\@leavechannel $2\n"; return 0; } sub respond { my($HANDLE, $channel, $method, $target, $text) = @_; my($response) = $channel . " "; # when doing a normal .. or :, there's no "say" in front. $response = "" if ($channel eq "say" && $method ne ""); # sorry, Z: if ((substr($target, 0, 1) ne "*") && (($channel eq "whisper") || ($channel eq "page"))) { $target = "*" . $target; } if ($channel eq "page" || $channel eq "whisper") { $response .= $target . " = "; $method = "" if ($method eq ".."); } elsif ($method eq "..") { $response .= ".." . $target . " "; $method = ""; } my $maxLength = 3950; # arbitrary cut-off point, although ifMUD's limit # at press time is 4096. if (length($text) >= $maxLength) { $text = substr($text, 0, $maxLength) . "..and a lot more stuff besides."; } $response .= $method . $text . "\n"; if ($debug == 2) { print "RESPONDING: $response"; } print $HANDLE $response; } sub readMemoryFromFile { my($file) = $_[0]; if (!open(INPUT, $file)) { print "Can't open input file '$file': $!\n"; print "Tabula rasa time.\n"; return; } &lockMemory(\*INPUT); print "Reading memory from file '$file'\n"; my $version = ; chomp $version; if ($version == $memVersion) { while () { chomp; last if ($_ eq " ---"); next if ($_ eq ""); # format should be something like # {names}{isare}{defs} # {names} is the full name, followed by a tab-separated list of # aliases and the aliases's is/are status (see next) # {isare} is either "is" or "are" depending on the name. # {defs} is a list of tab-separated definitions. my($nameList, $isare, $defList) = split /\t\t/; my @names = split(/\t/, $nameList); my @defns = split(/\t/, $defList); my $name = shift @names; my $simpName = &simplifyNoTransPhrase($name); my @aliases; while (@names) { my $aName = shift @names; my $aIs = shift @names; die "Odd-sized alias list?\n" if (!defined($aIs)); push @aliases, &simplifyNoTransPhrase($aName); $memory{&simplifyNoTransPhrase($aName)} = [ $aName, $simpName, $aIs, undef ]; } $memory{$simpName} = [ $name, \@aliases, $isare, \@defns ]; # now store each def. foreach my $def (@defns) { next if (length($def) > 100); # can't look up long stuff, sowwy my $simpDef = &simplifyNoTransPhrase($def); if (defined $reverseMemory{$simpDef}) { push @{ $reverseMemory{$simpDef}->[1] }, $simpName; } elsif ($simpDef ne $simpName) # fix for 'A IS A' { $reverseMemory{$simpDef} = [ $def, [ $simpName ] ]; } } } while () { chomp; last if ($_ eq " ---"); next if ($_ eq ""); $corkNutCount = $_; } while () { chomp; last if ($_ eq " ---"); next if ($_ eq ""); $dontLearnWords{$_} = 1; } while () { chomp; last if ($_ eq " ---"); next if ($_ eq ""); $friends{$_} = 1; } while () { chomp; last if ($_ eq " ---"); next if ($_ eq ""); $nonFriends{lc $_} = 1; } } else { # parse an older version of the file? die "No older version!\n"; } &unlockMemory(\*INPUT); close INPUT; } sub dumpMemoryToFile { my($file, $HANDLE) = @_; if (!open(OUTPUT, ">" . $file)) { if (defined($HANDLE)) { print $HANDLE "say Um, my input file " . $file . "'s gone all busticated ($!)\n"; } die "Can't open output file '$file': $!\n"; } &lockMemory(\*INPUT); print "Dumping memory to file '$file'\n"; print OUTPUT $memVersion, "\n"; foreach my $k (keys %memory) { next if (! (ref $memory{$k}->[1])); my($out) = $memory{$k}->[0]; foreach (@{ $memory{$k}->[1] }) { $out .= "\t" . $memory{$_}->[0] . "\t" . $memory{$_}->[2]; } $out .= "\t\t"; $out .= $memory{$k}->[2]; $out .= "\t\t"; $out .= join("\t", @{ $memory{$k}->[3] }); print OUTPUT $out, "\n"; } print OUTPUT " ---\n"; print OUTPUT $corkNutCount, "\n"; print OUTPUT " ---\n"; foreach my $k (keys %dontLearnWords) { print OUTPUT $k, "\n"; } print OUTPUT " ---\n"; foreach my $k (keys %friends) { print OUTPUT $k, "\n"; } print OUTPUT " ---\n"; foreach my $k (keys %nonFriends) { print OUTPUT $k, "\n"; } &unlockMemory(\*INPUT); close OUTPUT; } sub printWrapped { my($splitPoint) = 75; my($HANDLE, $text, $convert, $lineStart) = @_; $lineStart = "\n " if (!$lineStart); my($start); my($index); while (length($text) > $splitPoint) { $index = rindex($text, ' ', $splitPoint); if ($index == -1) # erg. great 2-gig logfile of Apr 1st, '00. { $start = substr($text, 0, $splitPoint-1); $text = substr($text, $splitPoint); } else { $start = substr($text, 0, $index); $text = substr($text, $index+1); } print $HANDLE $start, $lineStart; } print $HANDLE $text; } sub printHTML { my ($HANDLE, $text) = @_; my $firstword = $text; chomp($firstword); $firstword =~ s/\ .*//; $text =~ s/&/&/g; $text =~ s//>/g; $text = "$text<\/i>" if (($firstword =~ /<.*>/)); if ($firstword =~ /\([Ff]rom/) { $text =~ s/(\([Ff]rom .*?\))/$1<\/i>/; } elsif ($firstword eq "[spoilers]") { $text =~ s/\[spoilers\] //; $text = "[spoilers] $text"; } else { $text =~ s/\Q$firstword\E//; $text = "$firstword$text"; } my ($url, $inputtest) = ("", $text); while ($inputtest =~ /http/) { $url = $inputtest; $url =~ s!.*?(http://.*?)($|[ >)",\s]).*!$1!s; #"); if ($debug > 0) { print "URL = $url\n"; } $text =~ s|$url|$url|; #; $inputtest =~ s/http//; } print $HANDLE $text; print $HANDLE "
"; } sub dumpMemoryToHTML # thanks to DSG { my(%htmlConvert) = ( "<" => "<", ">" => ">", "&" => "&", ); my($file) = $logDirectory . "memory.html"; if (-e $file) { die "Oops: $file already exists!\n"; } open(OUTPUT, ">" . $file) || die "Can't open output file '$file': $!\n"; &lockMemory(\*OUTPUT); print "Dumping memory to file '$file'\n"; print OUTPUT "\n" . "It's Alex's Brain!\n" . "\n"; print OUTPUT "

Awwwk! Alex has eaten $corkNutCount cork nuts!

\n"; # do < > substitution and some other stuff # meaning, fill in the html-safe keys and definitions into %otherMem # but also split each key up into individual words, and sorts the keys # based on their length my %otherMem; my %keyList; # when breaking text up into words, here's how we do it: # groups of spaces are words, groups of letters are words, groups of # punctuation are words, and urls are words. some lusers leave off the # http:// before urls, so we assume anything starting with "www." is # also one. however, because we store things for lookup purposes in # a standardized form (eg "foo, bar baz" would correspond to # "foo , bar baz") the way to handle the split is to consider groups of # spaces to be the words, and everything else, including groups of letters, # to be the delimiters. trust me on this one. my $splitCode = '[a-zA-Z]+:\/\/[^\s]+[a-zA-Z0-9_\?\]\)\/\#]|' . '[wW][wW][wW]\.[^\s]+[a-zA-Z0-9\?\]\)\/\#]|' . '[a-zA-Z0-9_\#-]+(?:[\'\*][a-zA-Z0-9_\#-]+)*|' . # words like hasn't '[^\sa-zA-Z0-9_\#-]+'; while (my ($key,$value) = each %memory) { next if (! ref($value->[1])); # skip aliases # ignore is/are for now my @arr = ($value->[0], $value->[1], $value->[3]); $arr[0] =~ s/\&/\&/; $arr[0] =~ s/\/\>/; # break it up into words, with punctuation turning out as separate # words. also, we want urls to not be split up into separate words. my @temp = split(/($splitCode)/, $key); shift @temp; # eliminate the initial null # *then* it's safe to do html conversions map { $_ = $htmlConvert{$_} if defined($htmlConvert{$_}) } @temp; $keyList{$#temp + 1} = +{} unless (defined $keyList{$#temp + 1}); $key = lc join("", map { $_ =~ /^\s*$/ ? " " : $_ } @temp); $keyList{$#temp + 1}->{$key} = 1; $otherMem{$key} = \@arr; } # $keyList is now a hash of hashes of strings. Each key in the hash is the # number of words in the string that are stored in the hash corresponding # to the key. # (if you follow) # Ok, so for each definition, we want to check the keyGroups, from # longest keys to shortest keys, longest meaning "most number of words" while (my($key, $def) = each %otherMem) { my @defAll; foreach my $dd (@{ $def->[2] }) { my @defWords = split(/($splitCode)/, $dd); shift @defWords; # eliminate the initial null map { $_ = $htmlConvert{$_} if defined($htmlConvert{$_}) } @defWords; foreach my $kk (sort {$b <=> $a} keys %keyList) { my $i; # advance by 2 each time since every other group of $kk blocks # begins with a space, which we don't want. for ($i = 0; $i <= $#defWords + 1 - $kk; $i += 2) { # for each size-$kk block of definition words, see if this # is defined in the key array my $block = join("", map { $_ =~ /^\s*$/ ? " " : $_ } @defWords[$i..($i+$kk-1)]); if (defined( $keyList{$kk}->{lc $block} )) { # make this word/phrase into a link elsewhere $defWords[$i] = "" . join("", @defWords[$i..($i+$kk-1)]) . ""; # and don't let anyone else do stuff with this block splice(@defWords, $i+1, $kk-1); } # urls, otoh, should be made a link to whatever they # link to (if you see what I mean) elsif ($kk == 1 && $block =~ /[a-zA-Z]+:\/\/[^\s]+[a-zA-Z\]\)\/\#]/) { $defWords[$i] = "$block"; # no need to do a splice as this is the last pass } elsif ($kk == 1 && $block =~ /[wW][wW][wW]\.[^\s]+[a-zA-Z0-9\?\]\)\/\#]/) { $defWords[$i] = "$block"; # no need to do a splice as this is the last pass } } } push @defAll, join("", @defWords); } $otherMem{$key}->[2] = \@defAll; } # okay, now output all dem keys and stuff, making keys into # name anchors. print OUTPUT "
\n"; foreach my $k (sort (keys %otherMem)) { my $akas = ""; if ($#{$otherMem{$k}->[1]} != -1) { $akas = " (aka " . join(' / ', map(" " . $memory{$_}->[0], @{ $otherMem{$k}->[1] })) . ") "; } print OUTPUT "
" . $otherMem{$k}->[0] . "", $akas, "
", map { "
$_
" } @{ $otherMem{$k}->[2] }, "\n"; } print OUTPUT "
\n"; print OUTPUT "Alex knows better than to chirp up about\n"; print OUTPUT "
    "; foreach my $k (keys %dontLearnWords) { print OUTPUT "
  • ", $k, "\n"; } print OUTPUT "
"; print OUTPUT "

"; print OUTPUT "Alex has been introduced to the following people:\n"; print OUTPUT "

    "; foreach my $k (keys %friends) { print OUTPUT "
  • ", $k, "\n"; } print OUTPUT "
"; print OUTPUT "

"; print OUTPUT "Alex refuses to respond to the following anti-avianists:\n"; print OUTPUT "

    "; foreach my $k (keys %nonFriends) { print OUTPUT "
  • ", $k, "\n"; } print OUTPUT "
"; print OUTPUT "\n" . "\n"; &unlockMemory(\*OUTPUT); close OUTPUT; } sub lockMemory { my $OUT = shift; flock($OUT, 2); # 2 = $LOCK_EX = exclusive lock # seek(OUT, 0, 2); # I'm positive this isn't necessary, but whatevah. } sub unlockMemory { my $OUT = shift; flock($OUT, 8); # 8 = $LOCK_UN = un lock } sub is_aprilmode { my $t = Time::localtime::localtime; # month is indexed from 0, mday from 1. grr. return ($t->mon == 3) && ($t->mday == 1); } sub april_recall { my @people = qw(Floyd Caoif Whizzard Foobler vampyr FBIAgent sherbert Guest Nyoni Tracy Stranger Black White Bobcat_Goldthwait Giant_Monkey NamelessAdventurer gus Markov FartingBuffalo Emerald712 buymymonkey PollBoy NewsBoy Pokey Hloif PRISM jrw Ventura Parrot babelfish AdamC Earendil Penguin); my @say_text = ( "Ook.", "Do you like me? Yes [ ] No [ ]", "Rob I've fallen out of my chair", "snrk", "mmhmm", "A IS A", "YM 'loverly bunch of corknuts'", "lol", "Been a vomiting soccer hooligan?", "inky has changed the poll! Yer monkey!", "Well, I always feel gay after somebody swedes me.", "I was totally fixated on 3", "I don't know why, but periwinkle is a color I would associate with parasols", "Earendil and Adam, separated at birth.", "The chicken isn't as good, but you get breading.", "Scram, kid, this is my make-out place", "Daddy, what's Vietnam?", "THE BEAST AWAKENS.", "hehe", "ha!", "OK, now I idle to order pizza.", "wait, but the squirrels *were* the main focus", "hm, what's an appropriate amount of butter to slather on this thing?", "It's not every goat that knows the words to Hound Dog.", "good eatin' onthem gi'nt emus", "After these Flash games, I feel totally prepared to negotiate my way out of anything.", "Free dinner is better than free software.", "Anyway, I think that's the whole story.", "if I woke up and my fish was sleeping on my chest I would not feel warm and happy", "I vote for the goat story.", "You couldn't exactly keep it in your house... it'd ruin the carpeting.", ); my @pose_text = ( "does another one for the homies.", "jumps up and down.", "eats THB.", "giggles and wriggles.", "takes off pants", "wears pants", "wields a +12 saber of d00d", "falls over.", "votes to lynch Jota", "is BORED.", "uses an to teach kids a lesson about ", "decides to start chewing gum", "reads scrollback, laughs.", "tried to frisk Thief!", "ducks.", "cries!", "has joined the channel.", "has left the channel, but not in a huff.", "has disconnected.", "is free AND fancy!", ); my $r = int(rand(100)); if ($r < 70) { my $text = $say_text[int(rand(@say_text))]; my $str = $people[int(rand(@people))]; if ($text =~ /\?$/) { $str .= " asks"; $str .= " (of " . $people[int(rand(@people))] . ")" if ($r >= 60); } elsif ($text =~ /\!$/) { $str .= " exclaims"; $str .= " (at " . $people[int(rand(@people))] . ")" if ($r >= 60); } else { $str .= " says"; $str .= " (to " . $people[int(rand(@people))] . ")" if ($r >= 60); } return "$str, \"$text\""; } elsif ($r < 80) { return $people[int(rand(@people))] . " hollers, \"" . $say_text[int(rand(@say_text))] . "\""; } elsif ($r < 85) { return $people[int(rand(@people))] . " whispers, \"" . $say_text[int(rand(@say_text))] . "\""; } else { return $people[int(rand(@people))] . " " . $pose_text[int(rand(@pose_text))]; } }