#!/usr/bin/perl
###############################################################################
##
## Copyright (C) 2004-2005 Philip Walls (www.rabidgeek.com)
##
## This program is free software; you can redistribute it and/or modify it
## under the terms of the GNU General Public License as published by the
## Free Software Foundation; either version 2, or (at your option) any
## later version.
##
## This program is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
## General Public License for more details.
##
###############################################################################
package Furcadia;
# Disable when stable, slows down application
#use strict;
#use warnings;
my $VERSION = "0.6.45";
use IO::Socket::INET;
use IO::Select;
$| = 1;
my $SELECT = IO::Select->new;
my $STDIN = IO::Handle->new;
# Socket handles
my $FURC_SOCKET = 0;
my $PROXY_SOCKET = 0;
my %ProxyClients = ();
# Debugging options (TODO: move out of here)
my %DebugMessages =
(
"events" => 1, # Debug events (handlers and such)
"social" => 1, # Debug whispers, chat, etc
"goto" => 0, # Debug path finding code
"seen" => 0, # Debug how furres/dreams/etc are found
"objects" => 0, # Debug object movements
"proxy" => 1, # Debug proxy related messages
"print_proxy" => 0, # Debug writing to proxy socket
"proxy_read" => 0, # Debug incoming proxy socket data
"connection" => 1, # Debug Furcadia server connecting/disconnecting
"settings" => 1, # Debug INI loading/writing functions
"read_socket" => 0, # Debug Furcadia server incoming socket data
"read_stdin" => 0, # Debug standard input data
"timers" => 0, # Debug timer creation/execution/removal
);
my $DebugPretend = 0;
# Enable colorful debugging by default except in Win32
my $ConsoleColors = 1;
my $WindowsHost = 0;
my $Win32Tray;
if ($^O eq "MSWin32")
{
$ConsoleColors = 0;
$WindowsHost = 1;
require Win32Tray;
$Win32Tray = new Win32Tray();
$Win32Tray->RunEvents();
}
my (%FurcInfo, %FurcHandlers, @FurcTimers);
my %Temp =
(
"specitag" => undef, # Last displayed specitag
"lookreason" => undef, # Reason for $Furcadia->look()
);
my %FurcData =
(
"xpos" => undef, # Current X position
"ypos" => undef, # Current Y position
"imxpos" => undef, # "In middle" X position
"dir" => undef, # Direction
"frame" => undef, # Current Furc notation frame
"map" => undef, # Current map
"lastx" => undef, # Previous X position
"lasty" => undef, # Previous Y position
);
my ($FurcReaching, %FurcTried, %FurcAvoid, %FurcDreams, %FurreList, %FurrePosList, %MapFurres);
# Explanation of data structures:
#
# %FurreList =
# (
# "Furre|Name" => "colorcode"
# )
#
# %FurrePosList =
# (
# "xpos|ypos" =>
# {
# "color" => ...
# "frame" => ...
# "dir" => ...
# }
# )
#
my %FurcTarget =
(
"xpos" => undef, # Target's X position
"ypos" => undef, # Target's Y position
"imxpos" => undef, # Target's "In middle" X position
"color" => undef, # Target's color
"name" => undef, # Target's name
);
# Direction to number mappings
my %Directions =
(
'sw' => 1,
'se' => 3,
'nw' => 7,
'ne' => 9,
);
# Color codes for error levels
my @DebugLevels =
(
"\e[1;31m", # Red
"\e[1;33m", # Yellow
"\e[1;37m", # White
"\e[1;32m", # Green
"\e[1;34m", # Blue
);
sub new
{
my $self = {};
my $proto = shift;
my $furcdata = shift;
my $handlers = shift;
%FurcInfo = %{$furcdata};
%FurcHandlers = %{$handlers};
bless $self, $proto;
}
# Main event loop
sub event_loop
{
my $self = shift;
$self->debug("events", 4, "Entered event loop\n");
# Handle STDIN data if handler is set up
if (defined $FurcHandlers{"read_stdin"})
{
$self->debug("read_stdin", 4, "Enabling standard input handling\n");
$self->select_stdin();
}
# Handle proxy connections
if (defined $FurcInfo{"proxy"})
{
$self->debug("proxy", 4, "Initializing proxy server\n");
$self->select_proxy($FurcInfo{"proxy_addr"}, $FurcInfo{"proxy_port"});
}
# Add timer to do a who
# FIXME: Is there a better way to pass this function ref?
# Don't add the timer unless they want to see when people join/part
if (defined $FurcHandlers{"list_join"} || defined $FurcHandlers{"list_part"})
{
$self->timer_add_interval(3, \&who, $self);
}
# While the socket is still readable
while ($self->can_read || $FurcInfo{"proxy"})
{
# Check for timers
$self->timer_check;
# Check all read handles (proxy, stdin, socket)
$self->read_handles;
# Update the systray window
if ($WindowsHost)
{
if ($Win32Tray->RunEvents() < 0)
{
exit(0);
}
}
}
$self->debug("events", 4, "Exiting event loop\n");
}
###########################
# Handler related functions
sub handle
{
my $self = shift;
my $handlename = shift;
my $retdata = shift;
# If we've defined a handle, call it with %retdata as an argument
if (defined $handlename && defined $FurcHandlers{$handlename})
{
my $handlerfunction = $FurcHandlers{$handlename};
# Attempt to run the function
eval $handlerfunction->($retdata);
# If unsuccessful
if ($@)
{
$self->debug("events", 2, "Failed to execute handler for $handlename\n");
}
}
}
sub add_handler
{
# Add a new function handler
# First argument should be the handler name
# Second argument should be a function reference
my $self = shift;
my $handler = shift;
my $function = shift;
$self->debug("events", 4, "Added event handler for $handler\n");
if (defined $handler && defined $function)
{
$FurcHandlers{$handler} = $function;
return 1;
}
return 0;
}
sub rem_handler
{
# Remove a handler by name
my $self = shift;
my $handler = shift;
$self->debug("events", 4, "Removed event handler for $handler\n");
if (defined $handler)
{
$FurcHandlers{$handler} = undef;
return 1;
}
return 0;
}
####################################
# Timer control (ripped from Idiots)
sub timer_check
{
my $self = shift;
# Check for waiting timers
for ( my $timer = 1; $timer <= $#FurcTimers; $timer++ )
{
next unless $FurcTimers[$timer][0] && $FurcTimers[$timer][1];
# Check to see if it's past the time when the timer should have run
if ( $FurcTimers[$timer][0] <= time )
{
$self->debug ( "timers", 4, "Timer $timer activated at " . time . "\n" );
# Try to run the function
eval $FurcTimers[$timer][1]->($FurcTimers[$timer][2]);
# If the eval was unsuccessful
if ($@)
{
$self->debug ( "timers", 4, "Couldn't execute timer: $@\n" );
}
else
{
$self->debug ( "timers", 4, "Timer executed successfully\n" );
}
# If there's an interval set up
if ($FurcTimers[$timer][3])
{
# Recreate the timer with the same interval
$self->timer_add_interval
(
$FurcTimers[$timer][3],
$FurcTimers[$timer][1],
$FurcTimers[$timer][2]
);
}
# Remove the old timer
$self->timer_remove ( $timer );
}
}
}
sub timer_add
{
my $self = shift;
my $time = shift;
my $function = shift;
my $arguments = shift;
my $repeat = shift;
my $timer = @FurcTimers + 1;
$FurcTimers[$timer][0] = $time;
$FurcTimers[$timer][1] = $function;
$FurcTimers[$timer][2] = $arguments;
$FurcTimers[$timer][3] = $repeat;
$self->debug ( "timers", 4,"Created timer goes off at $time\n" );
return $timer;
}
sub timer_add_offset
{
my $self = shift;
my $offset = shift;
my $function = shift;
my $arguments = shift;
my $timer = @FurcTimers + 1;
$self->debug("timers", 4, "Created timer with offset of $offset seconds\n");
$self->timer_add ( time + $offset, $function, $arguments );
}
sub timer_add_interval
{
my $self = shift;
my $interval = shift;
my $function = shift;
my $arguments = shift;
my $timer = @FurcTimers + 1;
$self->debug ("timers", 4, "Created timer to go off every $interval seconds\n");
$self->timer_add( time + $interval, $function, $arguments, $interval);
}
sub timer_remove
{
my $self = shift;
my $timer = shift;
$self->debug ( "timers", 4, "Removed timer $timer\n" );
splice ( @FurcTimers, $timer, 1 );
return 1;
}
####################
# Connection related
sub connect
{
my $self = shift;
my $addr = shift;
my $port = shift;
# Use default values if none given
$addr ||= "lightbringer.furcadia.com";
# Pulled from the Furcadia settings editor (Connection tab)
my @portlist = ( 6500, 5000, 2300, 80, 22, 21 );
# If they specified a port, only try that port
if ($port)
{
@portlist = ( $port );
}
$self->debug("connection", 2, "Connecting to Furcadia\n");
# Try connecting to each port in turn
foreach my $tryport (@portlist)
{
if ($WindowsHost)
{
$Win32Tray->RunEvents();
}
#$self->debug ("connection", 2, "Trying server [$addr:$tryport]\n");
# while (!$FURC_SOCKET)
if (!$FURC_SOCKET)
{
$FURC_SOCKET = IO::Socket::INET->new (
PeerAddr => $addr,
PeerPort => $tryport,
Proto => 'tcp'
);
}
if ($FURC_SOCKET)
{
$self->debug
(
"connection", 2,
"Connected successfully.\n"
);
last;
}
else
{
#$self->debug("connection", 0, "Connection to Furcadia server failed.\n");
sleep(1);
}
}
# If we have no connection after all of that...
if (! $FURC_SOCKET)
{
$self->debug("connection", 0, "Unable to connect to Furcadia server!\n");
return 0;
}
# Add the socket into our list of selectable handles
$FURC_SOCKET->autoflush(1);
$SELECT->add($FURC_SOCKET);
return 1;
}
sub disconnect
{
my $self = shift;
# Remove the socket from selectable handles
$SELECT->remove($FURC_SOCKET);
$FURC_SOCKET->close;
$FURC_SOCKET = undef;
$self->debug
(
"connection", 0,
"Connection to Furcadia server closed.\n"
);
$self->handle("disconnect", { } );
}
sub can_read
{
my $self = shift;
# $self->debug("can_read", 4, "$FURC_SOCKET\n");
#if (!$FURC_SOCKET)
#{
# $self->debug
# (
# "connection", 0,
# "Connection to Furcadia server was lost.\n"
# );
#}
return $FURC_SOCKET;
}
sub select_stdin
{
my $self = shift;
if ($^O eq "MSWin32")
{
$self->debug("read_stdin", 0, "Win32 doesn't handle non-blocking IO, disabling keyboard input support\n");
delete $FurcHandlers{"read_stdin"};
return 0;
}
# Open standard input and make selectable
if (! $STDIN->fdopen(fileno(STDIN),"r"))
{
$self->debug("read_stdin", 0, "Couldn't open standard input, disabling support\n");
delete $FurcHandlers{"read_stdin"};
return 0;
}
$STDIN->autoflush(1);
$SELECT->add($STDIN);
return 1;
}
sub select_proxy
{
my $self = shift;
my $bindaddr = shift || "127.0.0.1";
my $port = shift || 6850;
$self->debug("proxy", 2, "Starting proxy listen socket on port $bindaddr:$port\n");
# Open an "accept" socket
if (!$PROXY_SOCKET)
{
$PROXY_SOCKET = IO::Socket::INET->new (
LocalPort => $port,
LocalAddr => $bindaddr,
Listen => 1,
Reuse => 1,
);
}
if ($PROXY_SOCKET)
{
$self->debug
(
"proxy", 2,
"Socket started successfully.\n"
);
}
else
{
$self->debug
(
"proxy", 0,
"Couldn't create proxy socket!\n"
);
return 0;
}
# Add the socket into our list of selectable handles
$PROXY_SOCKET->autoflush(1);
$SELECT->add($PROXY_SOCKET);
return 1;
}
sub print_socket
{
my $self = shift;
$self->debug ("print_socket", 4, "@_");
return 0 unless $FURC_SOCKET;
$FURC_SOCKET->print("@_") if (!$DebugPretend);
}
sub print_proxy
{
my $self = shift;
$self->debug ("print_proxy", 4, "@_");
return 0 unless $PROXY_SOCKET;
# Print to each of the connected proxy clients
foreach my $wh ($SELECT->can_write(0.1))
{
if ($ProxyClients{$wh})
{
$wh->print("@_") if (!$DebugPretend);
}
}
return 1;
}
# FIXME: Merge this into one function with read_socket and read_proxy
sub read_stdin
{
my $self = shift;
# Cycle through selectable handles
foreach my $rh ($SELECT->can_read(0.1))
{
# If the read handle is standard input
if ($rh == $STDIN)
{
if (my $stdin_data = <$STDIN>)
{
$self->debug ("read_stdin", 4, $stdin_data);
# Pass the data on to a handler if one exists
$self->handle ("read_stdin", { "data" => $stdin_data });
# Return the data in case it called directly
return $stdin_data;
}
else
{
# stdin got closed somehow
$SELECT->remove($STDIN);
close($STDIN);
return 0;
}
}
}
}
sub read_socket
{
my $self = shift;
# The argument to can_read tells it how long to block waiting for data
foreach my $rh ($SELECT->can_read(0.1))
{
# If it our Furcadia socket handle
if ($rh == $FURC_SOCKET)
{
my $socket_data;
# Read one character at a time until EOL (non-blocking)
while (sysread ($rh,my $buf,1))
{
$socket_data .= $buf;
last if ($buf eq "\n");
}
if ($socket_data)
{
$self->debug("read_socket", 4, $socket_data);
# Do something with $socket_data
$self->scour_socket($socket_data);
$self->handle("read_socket", { "data" => $socket_data });
return $socket_data;
}
else
{
# The socket was closed
$self->disconnect;
return 0;
}
}
}
}
sub read_proxy
{
my $self = shift;
# The argument to can_read tells it how long to block waiting for data
foreach my $rh ($SELECT->can_read(0.1))
{
# If we have a new proxy connection
if ($rh == $PROXY_SOCKET)
{
# Add this to the select list
my $new = $PROXY_SOCKET->accept;
$SELECT->add($new);
my $host = $new->peerhost;
$ProxyClients{$new} = $host;
$self->debug("proxy", 4, "Received new proxy connection from $host\n");
$self->handle("proxy_connect", { "host" => $host });
}
# If it's an existing proxy connection
elsif ($ProxyClients{$rh})
{
my $socket_data;
# Read one character at a time until EOL (non-blocking)
while (sysread ($rh,my $buf,1))
{
$socket_data .= $buf;
last if ($buf eq "\n");
}
if ($socket_data)
{
# Do something with $socket_data
$self->debug ("proxy_read", 4, $socket_data);
$self->handle ("proxy_read", { "data" => $socket_data });
return $socket_data;
}
else
{
# The socket was closed
$SELECT->remove($rh);
$rh->close;
my $host = $ProxyClients{$rh};
delete($ProxyClients{$rh});
$self->handle("proxy_disconnect", { "host" => $host });
$self->debug("proxy", 0, "Proxy client $host disconnected\n");
return 0;
}
}
}
}
sub read_handles
{
my $self = shift;
# Name of the handle that we read from
my $handle;
# The argument to can_read tells it how long to block waiting for data
foreach my $rh ($SELECT->can_read(0.1))
{
# If it our Furcadia socket handle
if ($rh == $FURC_SOCKET)
{
my $socket_data;
# Read one character at a time until EOL (non-blocking)
while (sysread ($rh,my $buf,1))
{
$socket_data .= $buf;
last if ($buf eq "\n");
}
if ($socket_data)
{
# Do something with $socket_data
$self->debug("read_socket", 4, $socket_data);
$self->scour_socket($socket_data);
$self->handle("read_socket", { "data" => $socket_data });
return $socket_data;
}
else
{
# The socket was closed
$self->disconnect;
return 0;
}
}
# If the read handle is standard input
elsif ($rh == $STDIN)
{
if (my $stdin_data = <$STDIN>)
{
$self->debug ("read_stdin", 4, $stdin_data);
# Pass the data on to a handler if one exists
$self->handle ("read_stdin", { "data" => $stdin_data });
# Return the data in case it called directly
return $stdin_data;
}
else
{
# stdin got closed somehow
$SELECT->remove($STDIN);
close($STDIN);
return 0;
}
}
# If we have a new proxy connection
elsif ($rh == $PROXY_SOCKET)
{
# Add this to the select list
my $new = $PROXY_SOCKET->accept;
$SELECT->add($new);
my $host = $new->peerhost;
$ProxyClients{$new} = $host;
$self->debug("proxy", 4, "Received new proxy connection from $host\n");
$self->handle("proxy_connect", { "host" => $host });
}
# If it's an existing proxy connection
elsif ($ProxyClients{$rh})
{
my $socket_data;
# Read one character at a time until EOL (non-blocking)
while (sysread ($rh,my $buf,1))
{
$socket_data .= $buf;
last if ($buf eq "\n");
}
if ($socket_data)
{
# Do something with $socket_data
$self->debug ("proxy_read", 4, $socket_data);
$self->handle ("proxy_read", { "data" => $socket_data });
return $socket_data;
}
else
{
# The socket was closed
$SELECT->remove($rh);
$rh->close;
my $host = $ProxyClients{$rh};
delete($ProxyClients{$rh});
$self->handle("proxy_disconnect", { "host" => $host });
$self->debug("proxy", 0, "Proxy client $host disconnected\n");
return 0;
}
}
}
}
sub proxy_clients
{
my $self = shift;
# Return the number of connected proxy clients
my $clients;
foreach my $key (keys(%ProxyClients))
{
$clients++;
}
return $clients;
}
sub swallow_socket
{
# This blocks and is in general not good to use unless you know
# EXACTLY what is going to be returned from the socket
# Please see how "seen()" accomplishes safe use of this function
# It's not recommended that you grab more than a single line at
# a time. As it could result in some really nasty problems.
my $self = shift;
my $lines = shift || 1;
my @data;
foreach (1..$lines)
{
my $data = <$FURC_SOCKET>;
push (@data, $data);
# FIXME: This can cause frustration with proxies
# Consider using a different handle name for this?
#$self->handle("read_socket", { "data" => $data });
$self->debug ("swallow_socket", 4, $data);
}
return @data;
}
sub furc_command
{
# Prints all arguments to socket with newline
my $self = shift;
$self->print_socket("@_\n");
}
sub position
{
my $self = shift;
return $FurcData{xpos},$FurcData{ypos},$FurcData{imxpos};
}
sub seen
{
# Find out where someone is
# ((You see Malverian.)
#
# ]f 7 != ===!"!Malverian
my $self = shift;
my $who = shift;
my $color;
# Who is a required argument
if (!$who)
{
return 0;
}
# Turn spaces into | symbol
$who =~ s/\s/\|/g;
# If we've got them in our list already
# With the proper casing
if (defined $FurreList{$who})
{
$color = $FurreList{$who};
}
# If the casing is wrong or we have a partial name
else
{
foreach my $furre (keys %FurreList)
{
if ($furre =~ /^\Q$who\E/i)
{
$color = $FurreList{$furre};
$who = $furre;
}
}
}
####################################################
# Let's really hope we never get here
# Looks at the furre to grab their color code
unless (defined $color)
{
$self->look($who);
my $retrieved = 0;
until ($retrieved)
{
my @data = $self->swallow_socket(1);
my $data = "@data";
if ($data =~ /^\]f(.{10})(.{3})(.*)/)
{
$color = $1;
$who = $3;
$FurreList{$who} = $color;
$retrieved = 1;
}
elsif ($data =~ /^\(\* Sorry, that furre is/)
{
return undef;
}
elsif (/^\(\* More than one furre\'s name begins that way\./)
{
return undef;
}
else
{
# Try to pass unrelated data to the scourer
$self->scour_socket($data);
}
}
}
#####################################################
return unless $color;
# Find the position based on their color code
foreach my $furre (keys (%FurrePosList))
{
next unless defined $furre;
next unless defined $FurrePosList{$furre};
my $fpcolor = $FurrePosList{$furre}{"color"};
if ($fpcolor eq $color && $furre ne "0|0")
{
my @pos = split(/\|/,$furre);
my $xpos = shift @pos;
my $ypos = shift @pos;
my $imxpos = $self->get_imx_pos($xpos,$ypos);
my $frame = $FurrePosList{$furre}{"frame"};
my $dir = $FurrePosList{$furre}{"dir"};
$self->debug("seen", 4, "Found $who in list: $furre ($fpcolor) -- Facing $dir\n");
return ($who, $xpos, $ypos, $dir, $color);
}
}
return undef;
}
sub seen_dream
{
my $self = shift;
my $dream = shift;
foreach my $tdream (keys %FurcDreams)
{
if ($FurcDreams{$tdream} =~ /^\Q$dream\E/i)
{
my $name = $FurcDreams{$tdream};
my ($xpos, $ypos) = split(/\|/, $tdream);
$self->debug("seen", 4, "Found dream $name at $xpos, $ypos\n");
return ($name, $xpos, $ypos);
}
}
}
sub target
{
my $self = shift;
return
(
$FurcTarget{xpos}, $FurcTarget{ypos},
$FurcTarget{imxpos}, $FurcTarget{name}, $FurcTarget{dream}
);
}
sub map
{
my $self = shift;
return $FurcData{map};
}
# FIXME: This is a stupid function
sub status
{
my $self = shift;
my $xpos = shift;
my $ypos = shift;
return $FurcDreams{"$xpos|$ypos"};
}
# TODO: Add handlers for all scour_socket areas..
# Q: What order should the handlers be called in?
# A: Probably after any %FurcData variables have been set
sub scour_socket
{
# Scour the socket data for position codes
# and other persistant data
# Call any function handlers
# Function handler specified in $handlename
# is called with %retdata as an argument
my $self = shift;
my $data = shift;
$_ = $data;
chop;
if (/^\@(.{4})(.{4})?/)
{
# The bot moved (screen recenter)
# @ ( . ) /
# @<new x><new y><old x><old y>
my $position = $1;
my $last = $2;
my ($xpos,$ypos,$imxpos) = $self->furc_to_pos($position);
$FurcData{xpos} = $xpos;
$FurcData{ypos} = $ypos;
$FurcData{imxpos} = $imxpos;
my ($lastxpos, $lastypos, $lastimxpos) = $self->furc_to_pos($last);
$FurcData{lastx} = $lastxpos;
$FurcData{lasty} = $lastypos;
# TODO: Set up other things similar to this
$self->handle("game_screen_move", $lastxpos, $lastypos, $xpos, $ypos);
}
elsif (/^\/(.{10})(.{4})(.{2})(.{4})?/ || /^\<(.{10})(.{4})(.{2})/)
{
# Avatar moves to new location
# /)-B& %!%8- ) / K ) .
# Avatar frame update (sitting, spinning, etc)
# <)-B& %!%8- ) / I
my $color = $1;
my $position = $2;
my $frame = $3;
my $from = $4;
# Convert to human readable positions/directions
my ($xpos,$ypos,$imxpos) = $self->furc_to_pos($position);
my ($oldxpos,$oldypos,$oldimxpos) = $self->furc_to_pos($from);
my $dir = $self->frame_to_dir($frame);
# Determine if it's a movement code
my $movement = /^\//;
# Determine if we were the one that moved
my $wemoved = ($xpos == $FurcData{xpos} && $ypos == $FurcData{ypos});
# Determine if we're seeking some place
my $pathfinding = (defined $FurcTarget{xpos} && defined $FurcTarget{ypos});
# Determine if there is a vector (successful movement)
my $vector = $self->get_vector($oldxpos, $oldypos, $xpos, $ypos);
if ($vector)
{
#$self->debug("goto", 4, "Furre ($color) moved to $xpos [$imxpos], $ypos (direction: $vector)\n");
}
# FIXME: This is so the bot can't follow himself, use a better method
unless ($wemoved)
{
$FurrePosList{"$xpos|$ypos"}{"color"} = $color;
$FurrePosList{"$xpos|$ypos"}{"frame"} = $frame;
$FurrePosList{"$xpos|$ypos"}{"dir"} = $dir;
#$self->handle("game_other_moved", $color, $frame, $dir);
}
$self->handle
(
"move",
{
"color" => $color,
"xpos" => $xpos,
"ypos" => $ypos,
"imxpos" => $imxpos,
"fpos" => $position,
"frame" => $frame,
"from" => $from
}
);
# If the position spoken of is where we stand
if ($wemoved)
{
# If we reached our lock position
if ($FurcReaching eq "$xpos|$ypos")
{
# Remove the lock
$FurcReaching = undef;
}
# Update our current direction and frame
$FurcData{dir} = $dir;
$FurcData{frame} = $frame;
# If it's a movement code (not spinning/sitting/etc)
if ($movement)
{
# If we ran into something
if ($from eq $position)
{
# Figure out where we tried moving to
my ($nxpos, $nypos, $nimxpos) = $self->relative_position($xpos, $ypos, $dir);
$self->debug("goto", 4, "Failed moving $dir from $xpos, $ypos to $nxpos [$nimxpos], $nypos\n");
# If we're currently seeking
if ($pathfinding && ! $self->next_to($FurcTarget{name}))
{
# Don't go there again
$self->avoid($nxpos, $nypos, $xpos, $ypos);
# If we're seeking a person
if ($FurcTarget{name})
{
# Recalculate the "nearest" position to the person we're going to
# FIXME: Should probably only do this if we found out our target
# position is occupied. Also.. this $tdir doesn't work as intended :-P
my ($twho,$txpos,$typos) = $self->seen($FurcTarget{name});
my $tdir = $self->get_vector($txpos,$typos,$xpos,$ypos);
my ($tnx, $tny) = $self->get_nearest($txpos, $typos, $tdir);
$self->goto($tnx, $tny);
}
else
{
# Otherwise just keep trying our current target positions
#$self->goto($FurcTarget{xpos}, $FurcTarget{ypos});
}
}
}
# If it was a successful move
else
{
# "Close" that position we came from so we don't go back there
$self->debug("goto", 4, "Successfully moved from $oldxpos, $oldypos to $xpos, $ypos\n");
if ($pathfinding)
{
$self->tried($oldxpos, $oldypos);
$self->avoid($oldxpos, $oldypos);
}
}
# Once we've moved and recalculated, go again
if ($pathfinding)
{
$self->reach_dest();
}
}
}
# If we are following the furre that moved
elsif (defined $FurcTarget{color} && defined $color && $FurcTarget{color} eq $color)
{
# When we update our target, clear out the avoid list
%FurcAvoid = ();
$FurcTarget{dir} = $dir;
# If we're not already next to our target
if (! $self->next_to($FurcTarget{name}))
{
# Go to the position behind them (or nearest empty place)
my $flip = $self->flip_direction($dir);
my ($goxpos, $goypos, $goimxpos) = $self->get_nearest($xpos, $ypos, $flip);
#$self->debug("goto", 4, "Target is now facing $dir\n");
$self->goto($goxpos,$goypos);
# If we're not already processing movement
if (! $FurcReaching)
{
$self->reach_dest();
}
}
}
}
elsif (/^>(.*)$/)
{
# Tell about an object position
# Usually sent as >XXYYNN
# But on map join, sent as >XXYYNN[XXYYNN[...]]
my $olist = $1;
while ($olist =~ /(.{4})(.{2})/g)
{
my $position = $1;
my $object = $2;
my ($xpos,$ypos,$imxpos) = $self->furc_to_pos($position);
my $onum = $self->furc_to_int($object);
if ($onum)
{
$self->debug("objects", 4, "Placing object $onum at position $xpos, $ypos\n");
}
else
{
$self->debug("objects", 4, "Clearing object at position $xpos, $ypos\n");
}
}
}
elsif (/^\)(.{4})$/)
{
# Clear furre from position
my $position = $1;
my ($xpos,$ypos,$imxpos) = $self->furc_to_pos($position);
#$self->debug("goto", 4, "Clearing furre at position $xpos, $ypos\n");
delete $FurrePosList{"$xpos|$ypos"};
}
elsif (/\]-\#(.)(.{10})(.{3})$/)
{
# Someone spoke or whispered
# Displays specitag before line
my $modifier = $1;
my $color = $2;
my $spec = $3;
$Temp{specitag} = $color;
}
elsif (/^\]s(.{4})(..)(.*?) (.*)?/)
{
# Set up dream list eg: ]s 7 gLost|Lakes
my ($xpos,$ypos,$imxpos) = $self->furc_to_pos($1);
my $sponsored = $2; # FIXME: Just a guess
my $dreamname = $3;
my $title = $4;
$FurcDreams{"$xpos|$ypos"} = $dreamname;
}
elsif (/^\]t(.{4})(.*)/)
{
# When a dream disappears, remove it from the list
my ($xpos,$ypos,$imxpos) = $self->furc_to_pos($1);
$FurcDreams{"$xpos|$ypos"} = undef;
}
elsif (/^]f(.{10})(.)(.)(.)(.*)/)
{
# Looked at someone
my $color = $1;
my $gender = $2;
my $species = $3;
my $form = $4;
my $name = $5;
my $gname = $self->furc_to_gender($gender);
my $sname = $self->furc_to_species($species);
# If we're supposed to be following this person
if (defined $FurcTarget{name} && $FurcTarget{name} eq $name)
{
$self->debug("goto", 4, "Located target $name ($color)\n");
$FurcTarget{color} = $color;
}
$self->handle
(
"look",
{
"color" => $color,
"species" => $species,
"name" => $name,
}
);
$self->debug("goto", 4, "$name is a $gname $sname\n");
}
elsif (/\]cc.+/)
{
# New map / dream
%FurrePosList = ();
%FurreList = ();
%MapFurres = ();
%FurcDreams = ();
# Clear path finding data
$self->stop;
if (! $FurcInfo{"proxy"})
{
$self->furc_command("vascodagama");
}
}
elsif (/^\]q/)
{
# Entered a dream
}
elsif (/^\]\#xxxx 0 Whoops\! The username and password did not match -- please check your spelling\./)
{
# Incorrect login
$self->debug("connection", 2, "Login incorrect, username and password do not match\n");
}
elsif (/^END$/)
{
# If we're not acting as a proxy and aren't reconnecting
if ($FurcInfo{name} && $FurcInfo{password})
{
# Log in the bot
$self->login (
$FurcInfo{name},
$FurcInfo{password},
$FurcInfo{colors},
$FurcInfo{species}
);
# Set the bot's description
$self->desc ($FurcInfo{desc});
}
}
elsif (/^<font/)
{
# Pass data off to handler
$self->handle("social", { "data" => $1 });
$self->debug("social", 4, "$1\n");
if (/^\(\(You enter the dream of (.*)\.\)$/)
{
# Entered a dream
$FurcData{'map'} = "dream_$1";
$self->handle("map", { "map" => "dream_$1" });
}
elsif (/^\(\[\*\] (.*?) asks you to join his \/ her company\./)
{
# Someone summons you
$self->handle ("summon", { "name" => $1 });
}
elsif (/\(\[\%\] (.*?) just gave you a cookie\!/)
{
$self->handle("gift", { "name" => $1, "type" => "cookie" });
}
elsif (/\(\[\*\] (.*?) requests permission to join your company\./)
{
$self->handle("join", { "name" => $1 });
}
elsif (/\(\* Current players: (.*)/)
{
my @players = split(/,\s|\./, $1);
my %newfurres;
foreach my $player (@players)
{
$newfurres{$player} = 1;
if (!$MapFurres{$player} && %MapFurres != ())
{
# New Furre arrived
$self->handle("list_join", { "name" => $player });
}
}
foreach my $player (keys(%MapFurres))
{
if (!$newfurres{$player})
{
# Player left
$self->handle("list_part", { "name" => $player });
}
}
%MapFurres = %newfurres;
}
elsif (/^<font color='whisper'>\[ <name shortname='(.*?)' src='whisper\-from'>(.*)<\/name> whispers, "(.*?)" to you\. \]<\/font>$/)
{
# Someone whispered you
$FurreList{$1} = $Temp{specitag};
$self->handle
(
"whisper",
{
"from" => $1,
"message" => $3,
}
);
$self->debug("social", 4, "$1 whispered \"$2\"\n");
}
elsif (/^\((\S*?): (.*)/)
{
# Someone spoke
$FurreList{$1} = $Temp{specitag};
$self->handle
(
"say",
{
"from" => $1,
"message" => $2,
}
);
#$self->debug("social", 4, "$1 said \"$2\"\n");
}
}
elsif (/^;(.+)\.map$/)
{
# Changed maps
my $mapname = $1;
$FurcData{'map'} = $mapname;
$self->handle("map", { "map" => $mapname });
$self->stop;
# Hardcoded dreams to avoid in certain maps -- lame!
# FIXME: Once map parsing is done, I can do this by object type
if ($mapname eq "allegria")
{
$FurcDreams{"50|59"} = "Sponsor dream";
}
}
return 1;
}
sub get_heuristic
{
my $self = shift;
my $startx = shift;
my $starty = shift;
my $startimx = $self->get_imx_pos($startx, $starty);
my $endx = shift;
my $endy = shift;
my $endimx = $self->get_imx_pos($endx, $endy);
# Use the smallest possible heuristic value
my $heuristic = abs($startx - $endx) + abs($starty - $endy);
my $imheuristic = abs($startimx - $endimx) + abs($starty - $endy);
if ($imheuristic < $heuristic) { $heuristic = $imheuristic }
$self->debug("goto", 4, "Heuristic for ($startx [$startimx], $starty -- $endx [$endimx], $endy) is $heuristic\n");
return $heuristic;
}
sub calculate_next_move
{
my $self = shift;
my $startx = shift;
my $starty = shift;
my $endx = shift;
my $endy = shift;
my $lowest = undef;
my $nextx = undef;
my $nexty = undef;
foreach my $tdir ($self->each_direction())
{
my ($xpos, $ypos, $imxpos) = $self->relative_position($startx,$starty,$tdir);
if ($self->occupied($xpos, $ypos))
{
$self->debug("goto", 4, "Next position is occupied: $xpos, $ypos [D=$tdir]\n");
next;
}
my $heuristic = $self->get_heuristic($xpos, $ypos, $endx, $endy);
my $tried1 = $FurcTried{"$xpos|$ypos"};
my $tried2 = $FurcTried{"$nextx|$nexty"};
if (! defined $lowest || $heuristic < $lowest)
{
$self->debug("goto", 4, "Found better move to $xpos, $ypos [H=$heuristic, T=$tried1]\n");
#$self->debug("goto", 4, "New move replaces $nextx, $nexty [H=$lowest, T=$tried2]\n");
$nextx = $xpos;
$nexty = $ypos;
$lowest = $heuristic;
#$self->tried($xpos,$ypos);
}
}
$self->debug("goto", 4, "Found best move ($nextx, $nexty)\n");
return ($nextx, $nexty);
}
sub reach_dest
{
my $self = shift;
my $botx = $FurcData{xpos};
my $boty = $FurcData{ypos};
my $targetx = $FurcTarget{xpos};
my $targety = $FurcTarget{ypos};
my $distance = $self->get_heuristic($botx,$boty,$targetx,$targety);
# If we've reached our destination pause/stop
if (($FurcTarget{name} && $self->next_to($FurcTarget{name})) || $distance < 1)
{
# If we're following someone
if ($FurcTarget{color})
{
$self->debug("goto", 4, "Reached target, pausing next to them\n");
$self->pause;
}
# If we were seeking to someone
elsif ($FurcTarget{name})
{
$self->debug("goto", 4, "Reached furre, stopping next to them\n");
# Sit and face them
$self->sit;
my ($name,$xpos,$ypos) = $self->seen($FurcTarget{name});
$self->face($xpos, $ypos);
$self->stop;
}
# If we're seeking to a position
else
{
$self->debug("goto", 4, "Reached position, stopping here\n");
$self->stop;
$self->twitch;
}
return;
}
my $maxtries = 3;
my ($nextx, $nexty);
for (my $i = 0; $i <= $maxtries; $i++)
{
($nextx,$nexty) = $self->calculate_next_move($botx,$boty,$targetx,$targety);
if ($nextx && $nexty)
{
last;
}
else
{
$self->debug("goto", 4, "Couldn't determine next move\n");
$self->pause;
}
}
my $direction = $self->get_vector($botx,$boty,$nextx,$nexty);
# If we've got a direction
if (defined $direction)
{
$self->debug("goto", 4, "Moving toward target ($targetx, $targety): $direction\n");
$FurcReaching = "$nextx|$nexty";
$self->godir($direction);
}
# We couldn't find a direction
else
{
$self->debug("goto", 4, "Giving up, couldn't find our target after $maxtries tries\n");
$self->stop;
$self->twitch;
}
}
sub tried
{
my $self = shift;
my $xpos = shift;
my $ypos = shift;
$FurcTried{"$xpos|$ypos"}++;
#$self->debug("goto", 4, "Adding $xpos, $ypos to tried list (Tried: " . $FurcTried{"$xpos|$ypos"} . ")\n");
}
sub avoid
{
# Tell the bot to avoid a specific position
my $self = shift;
my $xpos = shift;
my $ypos = shift;
my $lastx = shift;
my $lasty = shift;
# Determine which way we failed going
# TODO: Read in map data, propogate this list with object locations
# Also, set "value" to be the direction from which you can't move to that
# location (needed eg. for walls..)
$FurcAvoid{"$xpos|$ypos"} = 1;
if ($lastx && $lasty)
{
$FurcAvoid{"$xpos|$ypos"} = "$lastx|$lasty";
}
#$self->debug("goto", 4, "Adding $xpos, $ypos to avoid list (from $lastx, $lasty)\n");
}
sub occupied
{
# Determines if a position is occupied
my $self = shift;
my $xpos = shift;
my $ypos = shift;
my $occupied = 0;
if ($FurcDreams{"$xpos|$ypos"})
{
# If it's not the dream we're seeking
if ($FurcTarget{dream} ne $FurcDreams{"$xpos|$ypos"})
{
$occupied = 1;
}
}
if ($FurrePosList{"$xpos|$ypos"})
{
$occupied = 1;
}
if ($FurcAvoid{"$xpos|$ypos"})
{
my $botx = $FurcData{xpos};
my $boty = $FurcData{ypos};
if ($FurcAvoid{"$xpos|$ypos"} eq "$botx|$boty")
{
$self->debug("goto", 4, "Can't move to $xpos, $ypos from $botx, $boty\n");
$occupied = 1;
}
elsif ($FurcAvoid{"$xpos|$ypos"} == 1)
{
$occupied = 1;
}
}
#$self->debug("goto", 4, "Checking if $xpos, $ypos is occupied (O=$occupied)\n");
return $occupied;
}
sub get_vector
{
# Determine direction of movement
my $self = shift;
my $xpos1 = shift;
my $ypos1 = shift;
my $xpos2 = shift;
my $ypos2 = shift;
# Use the "in middle" X position for vectorizing
my $imxpos1 = $self->get_imx_pos($xpos1, $ypos1);
my $imxpos2 = $self->get_imx_pos($xpos2, $ypos2);
# Get the real distance on each axis
#my $xdist = sqrt(($xpos1 - $xpos2) ** 2);
#my $ydist = sqrt(($ypos1 - $ypos2) ** 2);
my $direction;
# If we haven't defined both, there is no vector
unless ($imxpos1 && $ypos1 && $imxpos2 && $ypos2)
{
return undef;
}
# If they're the same, we have no vector
if ($imxpos1 == $imxpos2 && $ypos1 == $ypos2)
{
return undef;
}
# X Axis different (Furre directly east or west)
if ($imxpos2 > $imxpos1 && $ypos2 == $ypos1)
{
# Furre directly east
#$direction = "e";
$direction = "ne";
}
elsif ($imxpos2 < $imxpos1 && $ypos2 == $ypos1)
{
# Furre directly west
#$direction = "w";
$direction = "sw";
}
# Y Axis different (Furre directly north or south)
elsif ($imxpos2 == $imxpos1 && $ypos2 > $ypos1)
{
# Furre directly south
#$direction = "s";
$direction = "se";
}
elsif ($imxpos2 == $imxpos1 && $ypos2 < $ypos1)
{
# Furre directly north
#$direction = "n";
$direction = "nw";
}
# Both axis different
elsif ($imxpos2 > $imxpos1 && $ypos2 < $ypos1)
{
$direction = "ne";
}
elsif ($imxpos2 < $imxpos1 && $ypos2 > $ypos1)
{
$direction = "sw";
}
elsif ($imxpos2 > $imxpos1 && $ypos2 > $ypos1)
{
$direction = "se";
}
elsif ($imxpos2 < $imxpos1 && $ypos2 < $ypos1)
{
$direction = "nw";
}
#$self->debug("goto", 4, "Vector for ($xpos1 [$imxpos1], $ypos1) to ($xpos2 [$imxpos2], $ypos2) is $direction\n");
return $direction;
}
sub get_nearest
{
# Return nearest clear position
my $self = shift;
my $xpos = shift;
my $ypos = shift;
my $dir = shift;
foreach my $tdir ($dir, $self->each_direction)
{
my ($goxpos,$goypos,$goimxpos) = $self->relative_position($xpos,$ypos,$tdir);
if (! $self->occupied($goxpos, $goypos))
{
return ($goxpos, $goypos);
}
# Eeeeeek.. recursive function with no maximum depth!
# FIXME: Enable this after depth checks added
#return $self->get_nearest($goxpos, $goypos, $tdir);
}
$self->debug("goto", 2, "Couldn't find an open spot near $xpos, $ypos\n");
return undef;
}
sub each_direction
{
# Return an array of all directions
my $self = shift;
return ("se", "sw", "nw", "ne");
}
sub direction_to
{
my $self = shift;
my $targetx = shift;
my $targety = shift;
my $botx = $FurcData{xpos};
my $boty = $FurcData{ypos};
my $vector = $self->get_vector($botx,$boty,$targetx,$targety);
return $vector;
}
sub direction
{
# Return the direction I'm facing
my $self = shift;
return $FurcData{dir};
}
sub relative_position
{
# Get the relative position based on a position and direction
my $self = shift;
my $xpos = shift;
my $ypos = shift;
my $direction = shift;
my $imxpos = $self->get_imx_pos($xpos, $ypos);
if ($direction eq "nw")
{
$imxpos--;
$ypos--;
}
elsif ($direction eq "ne")
{
$imxpos++;
$ypos--;
}
elsif ($direction eq "se")
{
$imxpos++;
$ypos++;
}
elsif ($direction eq "sw")
{
$imxpos--;
$ypos++;
}
else
{
$self->debug("goto", 1, "Unhandled direction: $direction\n");
}
# FIXME: WTF is going on in this function? Use get_imx_pos?
$xpos = $imxpos;
# If the Y position is even, add 1 to the y position
if ($ypos & 1) { $xpos++ }
return ($xpos, $ypos, $imxpos);
}
sub flip_direction
{
my $self = shift;
my $direction = shift;
my %flips = (
"nw" => "se",
"se" => "nw",
"ne" => "sw",
"sw" => "ne"
);
return $flips{$direction};
}
sub flip_axis
{
my $self = shift;
my $axis = shift;
my %faxis = (
"x" => "y",
"y" => "x",
);
return $faxis{$axis};
}
sub get_axis
{
my $self = shift;
my $direction = shift;
my %axis = (
"nw" => "x",
"se" => "x",
"ne" => "y",
"sw" => "y"
);
return $axis{$direction};
}
sub distance_to
{
my $self = shift;
my $name = shift;
# Get the position of the person
my ($tname,$xpos,$ypos) = $self->seen($name);
my $distance = $self->distance_to_pos($xpos,$ypos);
return $distance;
}
sub distance_to_pos
{
my $self = shift;
my $targetx = shift;
my $targety = shift;
my $botx = $FurcData{xpos};
my $boty = $FurcData{ypos};
my $distance = $self->get_heuristic($botx, $boty, $targetx, $targety);
return $distance;
}
sub next_to
{
my $self = shift;
my $name = shift;
# FIXME: If name is blank, hangs forever. Could have further implications.
if (!$name)
{
return 0;
}
# Get the position of the person
my ($tname,$xpos,$ypos) = $self->seen($name);
my $nextto = $self->next_to_pos($xpos,$ypos);
$self->debug("goto", 4, "Checking if we're next to $name: $nextto\n");
return $nextto;
}
sub next_to_pos
{
my $self = shift;
my $targetx = shift;
my $targety = shift;
my $nextto = 0;
my $distance = $self->distance_to_pos($targetx, $targety);
if ($distance <= 1)
{
$nextto = 1;
}
$self->debug("goto", 4, "Checking if we're next to $targetx, $targety [D=$distance R=$nextto]\n");
return $nextto;
}
#####################
# Furcadia specific #
sub login
{
my $self = shift;
my $name = shift;
my $pass = shift;
my $colors = shift;
my $species = shift;
my $speccode;
if ($species)
{
my @spec = split(//,$species);
foreach my $num (@spec)
{
$speccode .= chr($num + 32);
}
}
$self->debug("connection", 2, "Logging in with username $name\n");
$self->furc_command("connect $name $pass");
$self->furc_command("color $colors$speccode");
}
sub desc
{
my $self = shift;
my $desc = shift;
$self->furc_command("desc $desc [<a href=\"http://trac.rabidgeek.com/wiki/RGLibFurc\">RG</a>]");
}
# Append "tags" to end of %FurcInfo description
sub desc_tag
{
my $self = shift;
my $tag = shift;
my $desc = $FurcInfo{"desc"};
$self->desc("$desc $tag");
}
sub who
{
my $self = shift;
$self->furc_command("who");
}
sub whisper
{
my $self = shift;
my $furre = shift;
my $message = shift;
$furre = $self->pipe_space($furre);
$self->furc_command("wh $furre $message");
}
sub say
{
my $self = shift;
my $message = shift;
$self->furc_command("\"$message");
}
sub emote
{
my $self = shift;
my $emote = shift;
$self->furc_command(":$emote");
}
sub look
{
my $self = shift;
my $look = shift;
return unless $look;
$self->furc_command("\"look $look");
}
sub online
{
my $self = shift;
my $name = shift;
return unless $name;
$self->furc_command("onln $name");
while (1)
{
my @data = $self->swallow_socket(1);
my $data = "@data";
if ($data =~ /^\]\%(\d)/)
{
my $online = $1;
return $online;
}
else
{
# Try to pass unrelated data to the scourer
$self->scour_socket($data);
}
}
}
sub gomap
{
my $self = shift;
my $map = shift;
$self->furc_command("gomap $map");
}
sub goto
{
my $self = shift;
my $xpos = shift;
my $ypos = shift;
# If the target hasn't changed, don't bother trying to reach it again
if ($FurcTarget{xpos} eq $xpos && $FurcTarget{ypos} == $ypos) { return }
$FurcTarget{xpos} = $xpos;
$FurcTarget{imxpos} = $self->get_imx_pos($xpos,$ypos);
$FurcTarget{ypos} = $ypos;
$self->debug("goto", 4, "Updated target location: $xpos [$FurcTarget{imxpos}], $ypos\n");
}
sub follow
{
my $self = shift;
my $who = shift;
my ($name,$xpos,$ypos) = $self->seen($who);
return undef unless ($name && $xpos && $ypos);
$self->stop;
$FurcTarget{name} = $name;
$Temp{lookreason} = "follow";
$self->look($name);
return $name;
}
sub seek
{
my $self = shift;
my $who = shift;
my ($name,$xpos,$ypos,$dir) = $self->seen($who);
return undef unless ($name && $xpos && $ypos);
if($self->seek_pos($xpos,$ypos,$dir))
{
$FurcTarget{name} = $name;
return $name;
}
}
sub seek_dream
{
my $self = shift;
my $dream = shift;
my ($name,$xpos,$ypos) = $self->seen_dream($dream);
return undef unless ($name && $xpos && $ypos);
$self->goto($xpos,$ypos);
$self->reach_dest();
$FurcTarget{dream} = $name;
return $name;
}
sub seek_pos
{
my $self = shift;
my $xpos = shift;
my $ypos = shift;
my $dir = shift;
$self->stop;
my ($goxpos,$goypos) = $self->get_nearest($xpos,$ypos,$dir);
if ($goxpos && $goypos)
{
$self->goto($goxpos,$goypos);
$self->reach_dest();
return 1;
}
# Give up if there are no open spots near them :-/
return 0;
}
sub face
{
my $self = shift;
my $xpos = shift;
my $ypos = shift;
my $botd = $FurcData{dir};
my $targetd = $self->direction_to($xpos,$ypos);
my %dirs = ('nw' => 1,'ne' => 2, 'se' => 3,'sw' => 4);
my $difference = $dirs{$targetd} - $dirs{$botd};
my $times;
my $direction;
if ($difference > 0)
{
$times = $difference;
$direction = 0;
}
elsif ($difference < 0)
{
$times = $difference * -1;
$direction = 1;
}
if ($times == 3)
{
$times = 1;
$direction = $direction ^ 1;
}
return unless $times;
foreach my $i (1 .. $times)
{
if ($direction == 0)
{
$self->right;
}
if ($direction == 1)
{
$self->left;
}
}
}
sub stop
{
my $self = shift;
$self->debug("goto", 4, "Stopping path finding\n");
$self->pause;
%FurcTarget = ();
#$self->twitch;
}
sub pause
{
my $self = shift;
%FurcAvoid = ();
%FurcTried = ();
$FurcReaching = undef;
#$self->twitch;
}
sub join
{
my $self = shift;
my $name = shift;
$self->furc_command("join $name");
}
sub summon
{
my $self = shift;
my $name = shift;
$self->furc_command("summon $name");
}
sub left
{
my $self = shift;
$self->furc_command("<");
}
sub right
{
my $self = shift;
$self->furc_command(">");
}
sub nw
{
my $self = shift;
$self->furc_command("m 7");
}
sub ne
{
my $self = shift;
$self->furc_command("m 9");
}
sub sw
{
my $self = shift;
$self->furc_command("m 1");
}
sub se
{
my $self = shift;
$self->furc_command("m 3");
}
sub godir
{
my $self = shift;
my $direction = shift;
return unless defined $Directions{$direction};
$direction = $Directions{$direction};
$self->furc_command("m $direction");
}
sub twitch
{
my $self = shift;
$self->left;
$self->right;
}
sub stand
{
my $self = shift;
$self->furc_command("stand");
}
sub sit
{
my $self = shift;
$self->furc_command("sit");
}
sub lie
{
my $self = shift;
$self->furc_command("lie");
}
sub liedown
{
my $self = shift;
$self->furc_command("liedown");
}
sub quit
{
my $self = shift;
$self->furc_command("quit");
}
# FIXME: Pointless?
sub exit
{
my $self = shift;
$self->quit;
}
###############################
# Furcadia Conversion related #
sub pipe_space
{
# Convert whitespace to pipes
my $self = shift;
my $conv = shift;
$conv =~ s/\s/|/g;
return $conv;
}
sub int_to_furc
{
# Convert single integer to Furc
my $self = shift;
my $int = shift;
my $tmp1 = (int($int / 95)) + 32;
my $tmp2 = (int($int % 95)) + 32;
return (chr($tmp1) . chr($tmp2));
}
sub furc_to_int
{
# Convert Furc to integer
my $self = shift;
my $furc = shift;
# FIXME: This is probably a hack ("0" pads Furc numbers)
if (length($furc) == 1)
{
$furc = " $furc";
}
my $tmp1 = substr($furc, 0,1);
my $tmp2 = substr($furc, 1,1);
return ((ord($tmp1) - 32) * 95) + (ord($tmp2) - 32);
}
sub furc_to_dir
{
# Convert m 1/3/7/9 to dir
my $self = shift;
my $m = shift;
foreach my $dir (keys %Directions)
{
if ($Directions{$dir} == $m)
{
return $dir;
}
}
return undef;
}
sub furc_to_gender
{
my $self = shift;
my $gender = shift;
my $gint = $self->furc_to_int($gender);
# FIXME: Make these global!
my @glist =
(
"female",
"male",
"unspecified"
);
my $gname = $glist[$gint];
if (! $gname)
{
$self->debug("goto", 4, "Couldn't find gender name from '$gint' ($gender)\n");
}
return $gname;
}
sub furc_to_species
{
my $self = shift;
my $species = shift;
my $sint = $self->furc_to_int($species);
# FIXME: Make these global!
my @slist =
(
"rodent",
"equine",
"feline",
"canine",
"musteline",
"lapine",
);
my $sname = $slist[$sint];
if (! $sname)
{
$self->debug("goto", 4, "Couldn't find species name from '$sint' ($species)\n");
}
return $sname;
}
sub furc_to_pos
{
# Convert full Furc coordinate to x,y
my $self = shift;
my $furc = shift;
if (!$furc) { return undef }
my $furcx = substr($furc,0,2);
my $furcy = substr($furc,2,2);
my $intx = $self->furc_to_int($furcx) * 2;
my $inty = $self->furc_to_int($furcy);
my $imagx = $self->get_imx_pos($intx,$inty);
#$self->debug("goto", 4, "Converting '$furc' to position: $intx, $inty\n");
return ($intx, $inty, $imagx);
}
sub pos_to_furc
{
# Convert x,y to Furc coordinate
my $self = shift;
my $xpos = shift;
my $ypos = shift;
my $furc = $self->int_to_furc($xpos/2) .
$self->int_to_furc($ypos);
return $furc;
}
sub get_imx_pos
{
my $self = shift;
my $xpos = shift;
my $ypos = shift;
my $imagx = $xpos;
# If Y is odd number, subtract one from "in middle" number
if ($ypos & 1) { $imagx-- }
return $imagx;
}
sub near_furres
{
my @result;
foreach my $furre (keys %FurreList)
{
push (@result, $furre);
}
return @result;
}
sub frame_to_dir
{
my $self = shift;
my $frame = shift;
my $fint = $self->furc_to_int($frame);
my $direction;
# Ignore "frameless" furres
if ($fint == 0)
{
return undef;
}
# Propagate this using lowest SW frame
#my @species =
#(
# "1", # Standard rodent
# "41", # Standard feline
# "161", # Winged feline
# "261", # Dragon
# "781", # Gryphin
# "941", # Squirrel
#);
my @frames =
(
"sw",
"se",
"nw",
"ne",
);
# Example matrix (feline standard)
# 41-44,57 -- SW
# 45-48,58 -- SE
# 49-52,59 -- NW
# 53-56,60 -- NE
# Determine the correct bracket
my $bracket = int ($fint / 10) * 10;
if ($bracket % 20 == 0 && $bracket > 0)
{
if ($bracket == $fint)
{
$bracket -= 20;
}
}
elsif ($bracket > 0)
{
$bracket -= 10;
}
my $min = $bracket + 1;
my $max = $min + 3;
my $lie = $min + 16;
# Loop through and find the appropriate frame
foreach my $i (0..3)
{
if ($fint >= $min && $fint <= $max || $fint == $lie)
{
$direction = $frames[$i];
# Doesn't make any sense... They swapped NE and NW
if ($fint == $lie)
{
if ($direction eq "ne")
{
$direction = "nw";
}
elsif ($direction eq "nw")
{
$direction = "ne";
}
}
#$self->debug("goto", 4, "Calculated direction ($min - $max, $lie) from frame '$frame' [F=$fint,B=$bracket]: $direction\n");
last;
}
$lie++;
$min += 4;
$max = $min + 3;
}
if (! $direction)
{
$self->debug("goto", 1, "Couldn't find direction from frame '$frame' [$fint] -- ($_)\n");
}
return $direction;
}
# Read in Furcadia INI file
sub load_ini
{
my $self = shift;
my $file = shift;
my %conf;
if (!open (CONF, $file))
{
$self->debug("settings", 0, "Error parsing INI file $file: $!\n");
return 0;
}
while (<CONF>)
{
if (/(.*?)=(.*)/)
{
my $key = lc($1);
my $val = $2;
# Enable "hash" style configuration options
# Eg: owners@=Malverian
# owners@=Cinder|Bear
if ($key =~ /(.*?)\@/)
{
$key = $1;
$conf{$key}{$val} = 1;
}
else
{
$conf{$key} = $val;
}
}
}
return %conf;
}
sub write_ini
{
my $self = shift;
my $file = shift;
my %conf = @_;
if (!open (CONF, ">$file"))
{
$self->debug("settings", 0, "Couldn't open INI file $file for writing: $!\n");
return 0;
}
foreach my $key (keys (%conf))
{
my $val = $conf{$key};
$key = "\u$key";
next unless defined($val);
# If it's an array, print it out with foo@
if (ref($val) eq 'ARRAY')
{
foreach my $sub (@{$val})
{
print CONF "$key\@=$sub\n";
}
}
# Same thing for hashes.. so that write_ini(load_ini('some.ini')) will work :-P
elsif (ref($val) eq 'HASH')
{
foreach my $sub (keys %{$val})
{
print CONF "$key\@=$sub\n";
}
}
# Anything else should be printed as flat value
else
{
print CONF "$key=$val\n";
}
}
close(CONF);
return 1;
}
####################
# Accessor Methods #
sub ret_pos_list
{
my $self = shift;
return (%FurrePosList);
}
sub ret_furc_data
{
my $self = shift;
return (%FurcData);
}
##################
# DEBUGGING ONLY #
sub debugmessages
{
my $self = shift;
my @messages = @_;
foreach my $debugmsg (@messages)
{
if ($debugmsg =~ /^\-(.*)/)
{
$DebugMessages{$1} = -1;
}
elsif ($debugmsg =~ /^\+?(.*)/)
{
$DebugMessages{$1} = 1;
}
}
return (%DebugMessages);
}
sub debug
{
my $self = shift;
my $package = shift;
my $level = shift;
my $data = shift;
my $nlevel = $DebugLevels[$level];
return 0 if (defined $DebugMessages{'all'} && $DebugMessages{'all'} < 0);
if ($DebugMessages{$package} || $DebugMessages{'all'})
{
if (!defined $DebugMessages{$package} || $DebugMessages{$package} >= 0)
{
if ($WindowsHost)
{
$Win32Tray->WriteDebug("[Furcadia->${package}] $data");
}
else
{
print STDERR "[${nlevel}Furcadia->${package}\e[m] $data";
#print STDERR "[($$) ${nlevel}Furcadia->${package}\e[m] $data";
}
}
#cluck;
}
}
sub pretend
{
my $self = shift;
$DebugPretend = shift;
}
sub dump_hash
{
my $hashref = shift;
foreach my $key ( keys %{$hashref} )
{
if ( ref ($hashref->{$key} ) )
{
print STDOUT "!! '$key' !!\n";
dump_hash($hashref->{$key});
}
else
{
print STDOUT "'$key' = '".$hashref->{$key}."'\n";
}
}
}
sub version
{
# Return the module version
my $self = shift;
return $VERSION;
}
1;