### piespy.pl (c) 2004 Petr Baudis <pasky@ucw.cz>
#
## Keep track of a channel's social network.
#
## See http://pasky.ji.cz/~pasky/dev/irssi/ for the latest version.
#
## Based on Paul James Mutton's PieSpy in Java (http://www.jibble.org/piespy)
#
## $Id: piespy.pl,v 1.49 2004/06/04 20:36:43 pasky Exp pasky $
#
# $Log: piespy.pl,v $
# Revision 1.49  2004/06/04 20:36:43  pasky
# Fixed talking to nicks containing a dash.
#
# Revision 1.48  2004/05/18 14:32:17  pasky
# Fixed stupid mental typo in the previous patch.
#
# Revision 1.47  2004/05/18 14:26:38  pasky
# Fixed crashes on Bitlbee server, reported by ascent.
#
# Revision 1.46  2004/04/04 20:35:23  pasky
# Fixed bare_nickname() to also remove leading/trailing underscores.
#
# Revision 1.45  2004/03/31 22:58:47  pasky
# Fixed merging not to skip some edges.
#
# Revision 1.44  2004/03/31 22:55:54  pasky
# Fixed channel_allowed() to actually return anything useful.
#
# Revision 1.43  2004/03/31 20:03:54  pasky
# Compilation fixes.
#
# Revision 1.42  2004/03/31 20:02:04  pasky
# Support for piespy_channels_(allow|deny).
#
# Revision 1.41  2004/03/31 18:49:49  pasky
# Added support for aliases and merging (/piespy merge,lsalias,unalias). Still experimental, but looks like it does something.
#
# Revision 1.40  2004/03/31 18:00:08  pasky
# Added piespy_bare_nicknames setting (by default on), it strips all leading/trailing special chars from a nickname (reducing redunant nodes in the social network, hopefully). The old nicks already in social network before the upgrade will not be converted, so you'll have to watch them fade out or convert them manually.
#
# Revision 1.39  2004/03/22 16:32:46  pasky
# Changed piespy_font_dir default from /opt/X11R6/ to /usr/X11/.
#
# Revision 1.38  2004/03/22 16:31:57  pasky
# Raise error if font initialization didn't work out. Thanks to Harri.
#
# Revision 1.37  2004/03/21 14:38:49  pasky
# Make the font directory configurable through piespy_font_dir.
#
# Revision 1.36  2004/03/20 18:57:10  pasky
# Trimmed the revision log to contain only really important changes.
#
# Revision 1.35  2004/03/20 00:05:42  pasky
# $height is now short of 65 pixels, to avoid clashing graph and the bottom text (but the aspect ratio might be skewed now). Introduced piespy_count_mode, controlling whether mode changes should be taken into account, by default OFF.
#
# Revision 1.34  2004/03/19 22:55:33  pasky
# POSIX::_exit(1) instead of die.
#
# Revision 1.32  2004/03/19 22:48:04  pasky
# Tab completion for /piespy sub-commands.
#
# Revision 1.31  2004/03/19 22:43:32  pasky
# On Jibbler's advice, decrease default $iterations value from 5000 to 500.
#
# Revision 1.30  2004/03/16 16:29:18  pasky
# Fixed piespy_debug=0 (updating wouldn't work). Updated the edges drawing so that log[max_weight](weight) is used instead of just edge weight. We'll yet see how well it works, it might need some fine-tuning.
#
# Revision 1.27  2004/03/15 22:40:10  pasky
# You can temporarily disable updating thru piespy_update. If piespy_*_file is empty, the given action is not performed at all.
#
# Revision 1.26  2004/03/15 22:15:49  pasky
# Disable min/max skewing, this should prevent a lot of collapses and overally ensure that the graph is occupying the full pane.
#
# Revision 1.25  2004/03/15 22:14:29  pasky
# Convert edge/node hashes to arrays, gives some speedup. Idea by integral.
#
# Revision 1.23  2004/03/15 19:33:27  pasky
# Watch own messages and /kicks.
#
# Revision 1.22  2004/03/15 18:35:03  pasky
# Take voicing/opping into account as well.
#
# Revision 1.20  2004/03/15 14:58:13  pasky
# Make the brighest edge even 0xee,0xee,0xff.
#
# Revision 1.13  2004/03/15 14:19:20  pasky
# Adjust weight delta when adding an edge accordingly to the context.
#
# Revision 1.10  2004/03/15 12:02:52  pasky
# Mention in /piespy status that we have some updates queued.
#
# Revision 1.8  2004/03/15 11:59:24  pasky
# $graph and @upqueue are now global. Removing an edge is reported by debug(). Disconnected nodes are killed properly.
#
# Revision 1.5  2004/03/14 23:26:32  pasky
# Be much more cautious about running paralel updates - basically always run only one at a time, even if that means we'll have to postpone current update processing to the event of a next update caught.
#
# Revision 1.2  2004/03/14 22:20:04  pasky
# Tons of changes, rewrites, improvements etc. More-or-less finalized first version by now. Next commits will be already focused ;-).
#
# Revision 1.1  2004/03/14 18:18:49  pasky
# First functional version.
#
#
###


# Yes, the code is rather dirty perl, dirtier than I'm used to write. Sorry.
# --pasky

# This is meant just as a kind of proof-of-concept implementation. If you have
# enough free time, great things could be done with this, separating the engine
# to a module, adding interface for other scripts so that you can show some
# interesting info in a whois, color nicks in a channel differently etc. Then
# you can generalize it to ie. mailing lists and so on.
# 
# This is just a start. And only a quite small portion of it is irssi-specific.
# Porting to xchat should be also trivial. The ideal start is to move the
# generic part to a module, then you can reuse it from any IRC clients
# supporting Perl.
# 
# I'm unlikely to get enough time for anything of this, so feel encouraged to
# do it on your own. Just please tell me at <pasky@ucw.cz>.



### Preface



use strict;

use Irssi 20021117; # timeout_add_once
use Irssi::Irc;
use Irssi::TextUI;
use POSIX;

use vars qw ($VERSION %IRSSI $rcsid $graph @upqueue);

$rcsid = '$Id: piespy.pl,v 1.49 2004/06/04 20:36:43 pasky Exp pasky $';
($VERSION) = '$Revision: 1.49 $' =~ / (\d+\.\d+) /;
%IRSSI = (
          name        => 'piespy',
          authors     => 'Petr Baudis',
          contact     => 'pasky@ucw.cz',
          url         => 'http://pasky.or.cz/~pasky/dev/irssi/',
          license     => 'GPL',
          description => 'Model a social network of a channel.',
	  modules     => 'Data::Dumper Imager',
	  commands    => 'piespy'
         );


#use diagnostics;
#local $^W = 1;
#$SIG{__WARN__} = sub { my $w = join (' ', @_); chomp $w; Irssi::print $w; };




### Constants




my $decay = 0.02;

my $iterations = 500;
my $max_repulsive_force_distance = 6;
my $k = 2;
my $c = 0.01;
my $max_node_movement = 0.5;

my $min_diagram_size = 10;

my $border_size = 50;
my $node_radius = 5;
my $edge_threshold = 0;
my $show_edges = 1;


my ($child);



### The support routines



sub debug($) {
  return unless Irssi::settings_get_bool("piespy_debug");
  Irssi::print($_[0]);
}



### The graph manipulation toolkit



sub NODES_X()    { 0; }
sub NODES_Y()    { 1; }
sub NODES_FX()   { 2; }
sub NODES_FY()   { 3; }
sub NODES_NAME() { 4; }

sub EDGES_P1()   { 0; }
sub EDGES_P2()   { 1; }
sub EDGES_WEIGHT(){ 2; }


sub setup_graph($$) {
  my ($msgtarget, $server) = @_;

  $graph->{lc $msgtarget} = { name => $msgtarget, server => $server->{address}, nodes => {}, edges => [], aliases => {} }
    unless $graph->{lc $msgtarget};
}


sub bare_nickname($) {
  $_ = $_[0];
  s/^[^a-zA-Z0-9]+//;
  s/[^a-zA-Z0-9]+$//;
  $_;
}


sub add_edge($$$$) {
  my ($g, $p1, $p2, $weight) = @_;
  my ($lp1, $lp2) = (lc $p1, lc $p2);

  # Get a "bare" nickname if we should - stripping all leading/trailing
  # special characters
  if (Irssi::settings_get_bool("piespy_bare_nicknames")) {
    $lp1 = bare_nickname($lp1);
    $lp2 = bare_nickname($lp2);
  }

  $lp1 = $g->{aliases}->{$lp1} if ($g->{aliases}->{$lp1});
  $lp2 = $g->{aliases}->{$lp2} if ($g->{aliases}->{$lp2});

  # Ensure diversity
  return 0 if ($lp1 eq $lp2);

  # Update their graph records
  unless ($g->{nodes}->{$lp1}) { $g->{nodes}->{$lp1} = [ rand 2, rand 2, 0, 0 ]; }
  unless ($g->{nodes}->{$lp2}) { $g->{nodes}->{$lp2} = [ rand 2, rand 2, 0, 0 ]; }
  $g->{nodes}->{$lp1}->[NODES_NAME] = $p1;
  $g->{nodes}->{$lp2}->[NODES_NAME] = $p2;

  # Connect them

  # First look if the edge isn't there already
  foreach my $edge (@{$g->{edges}}) {
    next unless (($edge->[EDGES_P1] eq $lp1 and $edge->[EDGES_P2] eq $lp2)
		 or ($edge->[EDGES_P1] eq $lp2 and $edge->[EDGES_P2] eq $lp1));
    $edge->[EDGES_WEIGHT] += $weight;
    debug("Enweighted edge $p1 <-> $p2 to $edge->[EDGES_WEIGHT] (+$weight).");
    return 1;
  }

  # New edge
  push (@{$g->{edges}}, [ $lp1, $lp2, $weight ]);
  debug("Created edge $p1 <-> $p2 ($weight).");

  return 1;
}


sub kill_disconnected_node($$) {
  my ($g, $nname) = @_;

  # XXX: This is really stupid. We should just keep a refcount near each node.
  foreach my $edge (@{$g->{edges}}) {
    return if $nname eq $edge->[EDGES_P1];
    return if $nname eq $edge->[EDGES_P2];
  }

  debug("Killed node $nname.");
  delete $g->{nodes}->{$nname};
}


sub decay($) {
  my ($g) = @_;

  for (my $e = 0; $e < @{$g->{edges}}; $e++) {
    my $edge = $g->{edges}->[$e];

    $edge->[EDGES_WEIGHT] -= $decay;

    if ($edge->[EDGES_WEIGHT] <= 0) {
      my ($p1, $p2) = ($edge->[EDGES_P1], $edge->[EDGES_P2]);
      splice (@{$g->{edges}}, $e, 1);
      $e--;

      debug("Removed edge $p1 <-> $p2.");
      kill_disconnected_node($g, $p1);
      kill_disconnected_node($g, $p2);
    }
  }
}


sub layout($) {
  my ($g) = @_;

  my $i = $iterations;
  my @nodes = values %{$g->{nodes}};

  while ($i-- > 0) {
    # Welcome to the time-critical zone

    # Forces on nodes due to node-node repulsions

    foreach my $n1 (0 .. $#nodes) {
      my $node1 = $nodes[$n1];
      foreach my $n2 ($n1 + 1 .. $#nodes) {
	my $node2 = $nodes[$n2];

	my $dx = $node2->[NODES_X] - $node1->[NODES_X];
	my $dy = $node2->[NODES_Y] - $node1->[NODES_Y];

	my $d2 = $dx * $dx + $dy * $dy;
	if ($d2 < 0.01) {
	  $dx = rand (0.1) + 0.1;
	  $dy = rand (0.1) + 0.1;
	  $d2 = $dx * $dx + $dy * $dy;
	}

	my $d = sqrt $d2;
	if ($d < $max_repulsive_force_distance) {
	  my $repulsive_force = $k * $k / $d;

	  $node2->[NODES_FX] += $repulsive_force * $dx / $d;
	  $node2->[NODES_FY] += $repulsive_force * $dy / $d;
	  $node1->[NODES_FX] -= $repulsive_force * $dx / $d;
	  $node1->[NODES_FY] -= $repulsive_force * $dy / $d;
	}
      }
    }

    # Forces on nodes due to edge attractions

    foreach my $pedge (@{$g->{edges}}) {
      my @edge = @$pedge;
      my $node1 = $g->{nodes}->{$edge[EDGES_P1]};
      my $node2 = $g->{nodes}->{$edge[EDGES_P2]};

      my $dx = $node2->[NODES_X] - $node1->[NODES_X];
      my $dy = $node2->[NODES_Y] - $node1->[NODES_Y];

      my $d2 = $dx * $dx + $dy * $dy;
      if ($d2 < 0.01) {
	$dx = rand (0.1) + 0.1;
	$dy = rand (0.1) + 0.1;
	$d2 = $dx * $dx + $dy * $dy;
      }

      my $d = sqrt $d2;
      if ($d > $max_repulsive_force_distance) {
	$d = $max_repulsive_force_distance;
      }

      $d2 = $d * $d;
      my $attractive_force = ($d2 - $k * $k) / $k;
      my $weight = $edge[EDGES_WEIGHT]; $weight = 1 if $weight < 1;
      $attractive_force *= log($weight) * 0.5 + 1;

      $node2->[NODES_FX] -= $attractive_force * $dx / $d;
      $node2->[NODES_FY] -= $attractive_force * $dy / $d;
      $node1->[NODES_FX] += $attractive_force * $dx / $d;
      $node1->[NODES_FY] += $attractive_force * $dy / $d;
    }

    foreach my $node (@nodes) {
      my $xmove = $c * $node->[NODES_FX];
      my $ymove = $c * $node->[NODES_FY];

      my $max = $max_node_movement;
      $xmove = $max if $xmove > $max;
      $xmove = -$max if $xmove < -$max;
      $ymove = $max if $ymove > $max;
      $ymove = -$max if $ymove < -$max;

      $node->[NODES_X] += $xmove;
      $node->[NODES_Y] += $ymove;

      $node->[NODES_FX] = $node->[NODES_FY] = 0;
    }
  }
}


sub calc_bounds($$$) {
  my ($g, $width, $height) = @_;

  my ($max_weight) = 0;

  # Stupid Perl emits a metric ton of warnings blab when counting with
  # infinity numbers. Blah.

  #$^W = 0;

  my ($minx, $maxx, $miny, $maxy) = ('Infinity', -'Infinity', 'Infinity', -'Infinity');

  foreach my $node (values %{$g->{nodes}}) {
    $maxx = $node->[NODES_X] if $node->[NODES_X] > $maxx;
    $minx = $node->[NODES_X] if $node->[NODES_X] < $minx;
    $maxy = $node->[NODES_Y] if $node->[NODES_Y] > $maxy;
    $miny = $node->[NODES_Y] if $node->[NODES_Y] < $miny;
  }

  # ... but if an infinity survived through this, we want to get a warning!
  #$^W = 1;

  # The following code was in the original Java version, but it caused
  # pathologic behaviour of random "graph collapsing" to a small chunk etc -
  # the problem is probably that it skews the min/max but doesn't change the
  # node coordinates themselves so if it enlarges it by too much, everything
  # just gets stuffed in the middle, what a sad view.

=foul
  if ($maxx - $minx < $min_diagram_size) {
    my $midx = ($maxx + $minx) / 2;
    $minx = $midx - $min_diagram_size / 2;
    $maxx = $midx + $min_diagram_size / 2;
  }

  if ($maxy - $miny < $min_diagram_size) {
    my $midy = ($maxy + $miny) / 2;
    $miny = $midy - $min_diagram_size / 2;
    $maxy = $midy + $min_diagram_size / 2;
  }

  my $xyratio = (($maxx - $minx) / ($maxy - $miny)) * ($height / $width);
  if ($xyratio > 1) {
    my $dy = $maxy - $miny;
    $dy = $dy * $xyratio - $dy;
    $miny = $miny - $dy / 2;
    $maxy = $maxy + $dy / 2;
  } elsif ($xyratio < 1) {
    my $dx = $maxx - $minx;
    $dx = $dx / $xyratio - $dx;
    $minx = $minx - $dx / 2;
    $maxx = $maxx + $dx / 2;
  }
=cut

  foreach my $edge (@{$g->{edges}}) {
    $max_weight = $edge->[EDGES_WEIGHT] if $max_weight < $edge->[EDGES_WEIGHT];
  }

  ($g->{minx}, $g->{maxx}, $g->{miny}, $g->{maxy}, $g->{max_weight}) = ($minx, $maxx, $miny, $maxy, $max_weight);
}


sub draw($$$) {
  my ($g, $width, $height) = @_;

  use Imager;

  my $image = Imager->new(xsize => $width, ysize => $height, channels => 4);

  my $bgcolor = Imager::Color->new(0xff, 0xff, 0xff);
  my $chancolor = Imager::Color->new(0xee, 0xee, 0xff);
  my $labelcolor = Imager::Color->new(0x00, 0x00, 0x00);
  my $titlecolor = Imager::Color->new(0x99, 0x99, 0xcc);
  my $nodecolor = Imager::Color->new(0xff, 0xff, 0x00);
  my $edgecolor = Imager::Color->new(0x66, 0x66, 0xff);
  my $bordercolor = Imager::Color->new(0x66, 0x66, 0x66);

  my $boldfont = Imager::Font->new(file => Irssi::settings_get_str("piespy_font_dir") . '/luxisb.ttf');
  my $normfont = Imager::Font->new(file => Irssi::settings_get_str("piespy_font_dir") . '/luxisr.ttf');
  unless ($boldfont and $normfont) {
    print STDERR "Cannot read either luxisb.ttf or luxisr.ttf from ".Irssi::settings_get_str("piespy_font_dir")."!\n";
    print STDERR "Check your piespy_font_dir settings.\n";
    POSIX::_exit(1);
  }

  $image->box(color => $bgcolor, xmin => 0, ymin => 0, xmax => $width - 2, ymax => $height - 2, filled => 1);
  $image->box(color => $bordercolor, xmin => 0, ymin => 0, xmax => $width - 1, ymax => $height - 1);

  $width -= $border_size * 3;
  $height -= $border_size * 2;

  $image->string(font => $boldfont, x => $border_size + 20, y => 80,
    color => $chancolor, aa => 1, size => 64,
    string => $g->{name});
  $image->string(font => $boldfont, x => $border_size, y => $border_size - $node_radius - 15,
    color => $titlecolor, aa => 1, size => 18,
    string => "A Social Network Diagram for an IRC Channel");
  $image->string(font => $normfont, x => $border_size, y => $border_size * 2 + $height - 65,
    color => $titlecolor, aa => 1, size => 12,
    string => "Generated on $g->{server} using PieSpy.pl $VERSION");
  $image->string(font => $normfont, x => $border_size, y => $border_size * 2 + $height - 50,
    color => $titlecolor, aa => 1, size => 12,
    string => "Based on PieSpy Java IRC bot - http://www.jibble.org/piespy/");
  $image->string(font => $normfont, x => $border_size, y => $border_size * 2 + $height - 35,
    color => $titlecolor, aa => 1, size => 12,
    string => "Blue edge thickness and shortness represents strength of relationship");
  $image->string(font => $normfont, x => $border_size, y => $border_size * 2 + $height - 20,
    color => $titlecolor, aa => 1, size => 12,
    string => "http://pasky.or.cz/~pasky/dev/irssi/ - This frame was drawn at " . localtime);

  $height -= 65; # prevent the bottom text override

  foreach my $edge (@{$g->{edges}}) {
    next if $edge->[EDGES_WEIGHT] < $edge_threshold;
    next unless $show_edges;

    my $node1 = $g->{nodes}->{$edge->[EDGES_P1]};
    my $node2 = $g->{nodes}->{$edge->[EDGES_P2]};
    my $x1 = $width * ($node1->[NODES_X] - $g->{minx}) / ($g->{maxx} - $g->{minx}) + $border_size;
    my $y1 = $height * ($node1->[NODES_Y] - $g->{miny}) / ($g->{maxy} - $g->{miny}) + $border_size;
    my $x2 = $width * ($node2->[NODES_X] - $g->{minx}) / ($g->{maxx} - $g->{minx}) + $border_size;
    my $y2 = $height * ($node2->[NODES_Y] - $g->{miny}) / ($g->{maxy} - $g->{miny}) + $border_size;

    my @rgba = $edgecolor->rgba;
    # This was the original line, but it makes sense only when we can change thickness...
    #$rgba[3] = 102 + 153 * $edge->{weight} / $g->{max_weight};
    # ...so we do this instead, adjusting the saturation:
    foreach my $i (0 .. 1) { $rgba[$i] = 0xee - 0xee * (log($edge->[EDGES_WEIGHT] + 1) / log($g->{max_weight} + 1)); }
    my $adgecolor = Imager::Color->new(@rgba);

    #$image->setThickness(log($edge->{weight} + 1) * 0.5 + 1);

    $image->line(color => $adgecolor, x1 => $x1, y1 => $y1, x2 => $x2, y2 => $y2, aa => 1);
  }

  #$image->setThickness(2);
  foreach my $node (values %{$g->{nodes}}) {
    my $x = $width * ($node->[NODES_X] - $g->{minx}) / ($g->{maxx} - $g->{minx}) + $border_size;
    my $y = $height * ($node->[NODES_Y] - $g->{miny}) / ($g->{maxy} - $g->{miny}) + $border_size;
    $image->circle(color => $edgecolor, x => $x, y => $y, r => $node_radius, filled => 1, aa => 1);
    $image->circle(color => $nodecolor, x => $x, y => $y, r => $node_radius - 2, filled => 1, aa => 1);
    $image->string(font => $normfont, x => $x + $node_radius, y => $y - $node_radius,
      color => $labelcolor, aa => 1, size => 10,
      string => $node->[NODES_NAME]);
  }

  $image;
}



### The irssi interface


sub update(@) {
  my (@msgtargets) = @_;

  my $x = Irssi::settings_get_str("piespy_width");
  my $y = Irssi::settings_get_str("piespy_height");
  my $dfile = Irssi::settings_get_str("piespy_data_file");
  my $gfile = Irssi::settings_get_str("piespy_graph_file");

  use Data::Dumper;

  if ($dfile) {
    unless (open (DUMP, '>' . $dfile)) {
      # We are fork()'d now so dying should be safe.
      print STDERR "Cannot open $dfile for writing: $!\n";
      POSIX::_exit(1);
    }
    print DUMP Data::Dumper->Dump([$graph], ['graph']);
    close (DUMP);
  }

  if ($gfile) {
    foreach my $msgtarget (@msgtargets) {
      my $file = $gfile;
      $file =~ s/\%c/$msgtarget/g;

      layout($graph->{$msgtarget});
      calc_bounds($graph->{$msgtarget}, $x, $y);
      my $image = draw($graph->{$msgtarget}, $x, $y);
      $image->write(file => $file);
    }
  }
}

sub dispatch_update(@) {
  my (@msgtargets) = @_;

  # We will detach so that we don't block irssi

  $child = fork ();
  if ($child > 0) {
    # Main process
    Irssi::pidwait_add($child);
    return;
  }

  update(@msgtargets);

  if ($child == 0) {
    # Child process
    POSIX::_exit(0);
  }

  # Main process but fork() failed so we did it there
  undef $child;
}


=moo
sub timed_dispatch_update {
  if (defined $child) {
    Irssi::print("[PieSpy] Warning: Update taking too long, consider increasing piespy_update_interval!");
    Irssi::print(Irssi::settings_get_int("piespy_update_interval") * 1000);
    Irssi::timeout_add(Irssi::settings_get_int("piespy_update_interval") * 1000,
			    &timed_dispatch_update, []);
    return;
  }

  dispatch_update(@upqueue);
  undef @upqueue;
}
=cut


sub queue_update($) {
  my ($msgtarget) = @_;

  # We do not want to update TOO fast, so that we won't kill the machine.
  # Therefore, if we are already in the middle of one update and we should
  # already do another, we do it in 10s, cummulatively for all the msgtargets
  # touched in the meantime.

  # XXX: And that thing is not really working now, somehow the timeouts aren't
  # _timing_ out but triggered immediatelly :-(.

=moo
  if ((not defined $child) and Irssi::settings_get_bool("piespy_update_continuous")) {
    dispatch_update($msgtarget);
    return;
  }

  if (@upqueue) {
    # Timer is already set
    push (@upqueue, $msgtarget);
    return;
  }

  push (@upqueue, $msgtarget);
  Irssi::timeout_add(Irssi::settings_get_int("piespy_update_interval") * 1000,
                          timed_dispatch_update, []);
=cut

  push (@upqueue, $msgtarget)
    unless (grep {lc $_ eq lc $msgtarget} @upqueue);

  if (not defined $child and Irssi::settings_get_bool("piespy_update")) {
    dispatch_update(@upqueue);
    undef @upqueue;
  }
}


sub funeral_service($) {
  my ($pid) = @_;

  return unless defined $child;
  return unless $pid == $child;
  undef $child;
}


sub channel_allowed($) {
  my ($msgtarget) = @_;
  $msgtarget = lc $msgtarget;

  if (my $l = Irssi::settings_get_str("piespy_channels_deny")) {
    return 0 if grep { lc $_ eq $msgtarget } split (/,/, $l)
  }

  if (my $l = Irssi::settings_get_str("piespy_channels_allow")) {
    return 0 unless grep { lc $_ eq $msgtarget } split (/,/, $l)
  }

  return 1;
}

sub event_privmsg {
  my ($server, $data, $nick, $address) = @_;
  my ($msgtarget, $text) = split(/ :/, $data, 2);


  # What _IS_ $msgtarget?

  return if ($msgtarget !~ /^[#!+&]/);
  return unless (channel_allowed($msgtarget));

  my ($chanptr) = $server->channel_find($msgtarget);
  return unless $chanptr; # Bitlbee bugfix.



  # Make sure the graph is set up

  setup_graph($msgtarget, $server);
  $msgtarget = lc $msgtarget;


  # Analyze the text

  my (@text);

  while ($text) {
    # XXX: My eyes bleed upon this but...
    my ($token, $sep) = $text =~ /^(.*?)([ \t\n\r\f:,.\/&!?()<>]+)/;
    $text =~ s/^(.*?)([ \t\n\r\f:,.\/&!?()<>]+)//;
    if (not defined $token) { $token = $text; $text = ''; }

    my ($pri) = 0.4;
    $pri = 1.0 if ($sep =~ /:/ or $sep =~ />/);
    $pri = 0.8 if ($sep =~ /!/ or $sep =~ /\?/);
    $pri = 0.6 if ($sep =~ /,/ or $sep =~ /\./);

    push (@text, { t => $token, h => $pri });
  }


  # Add edges

  my $cc = 0;

  foreach my $token (@text) {
    next unless $chanptr->nick_find($token->{t});
    $cc += add_edge($graph->{$msgtarget}, $nick, $token->{t}, $token->{h});
    decay($graph->{$msgtarget});
  }

  if ($cc) {
    queue_update($msgtarget);
  }
}


sub event_message_own_public {
  my ($server, $msg, $msgtarget) = @_;

  event_privmsg($server, $msgtarget . ' :' . $msg, $server->{nick});
}


sub event_message_kick {
  my ($server, $msgtarget, $nick, $kicker, $address, $reason) = @_;

  return unless (channel_allowed($msgtarget));

  setup_graph($msgtarget, $server);
  $msgtarget = lc $msgtarget;

  if (add_edge($graph->{$msgtarget}, $nick, $kicker, 0.8)) {
    decay($graph->{$msgtarget});
    queue_update($msgtarget);
  }
}


sub event_mode {
  my ($server, $data, $nick, $address) = @_;
  my ($msgtarget, @mmode) = split(/ /, $data);
  my ($mode, @args) = @mmode;


  return unless Irssi::settings_get_bool("piespy_count_mode");


  # Make sure the graph is set up

  setup_graph($msgtarget, $server);
  $msgtarget = lc $msgtarget;


  # Process the mode string

  my $cc = 0;
  my $operation;

  foreach my $mchar (split //, $mode) {
    if ($mchar =~ /[+-]/) { $operation = $mchar; next; }
    if ($mchar =~ /[eIblk]/) { shift @args; }
    if ($mchar ne 'v' and $mchar ne 'o') { next; }
    # XXX: $operation ? Yes, at first you'd shout "decrease" for '-', but then
    # again, it proves that there is _some_ social binding between the two
    # individuals, however negative ;-). --pasky

    my $pri = 0;
    $pri = 1.8 if ($mchar eq 'o');
    $pri = 0.8 if ($mchar eq 'v');

    $cc += add_edge($graph->{$msgtarget}, $nick, shift @args, $pri);
  }

  if ($cc) {
    decay($graph->{$msgtarget});
    queue_update($msgtarget);
  }
}


sub cmd_piespy {
  my ($data, $server, $channel) = @_;

  if ($data =~ /^(usage|help)/i) {
    Irssi::print <<USAGE
PieSpy $VERSION
This script maintains per-channel social networks based on communication on
the channel. It keeps its state across irssi runs and keeps up-to-date network
diagram on the disk.

Commands:

%9/piespy help%9
%9/piespy usage%9
    This help
%9/piespy status%9
    General status information
%9/piespy update%9
    Update all the files
%9/piespy chlist%9
    List all the currently tracked channels
%9/piespy chwho <channel>%9
    Show list of tracked people on a channel
%9/piespy chnet <channel> [<nick>]%9
    Show list of people associated with <nick> (or all associations) on a channel
%9/piespy merge <channel> <merger> <mergee>%9
    Merge all connections of <mergee> to <merger> and remove <mergee>, aliasing <mergee> to <merger>
%9/piespy lsalias <channel> [<nick>]%9
    List all aliases in given <channel>
%9/piespy unalias <channel> <nick>%9
    Unalias <nick> if it was aliased to anything

Settings:
%9piespy_data_file%9
    File with the complete current state (loaded on irssi startup)
    If this is empty, the action is not performed
%9piespy_graph_file%9
    File with the plotted social network diagram, '\%\%c' is substituted by the channel name
    If this is empty, the action is not performed
%9piespy_font_dir%9
    Directory containing your TTF fonts. It should contain at least luxisb.ttf and luxisr.ttf
%9piespy_width%9, %9piespy_height%9
    Diagram dimensions
%9piespy_debug%9
    Report edges being created/enweighted/removed, and possibly other interesting things
%9piespy_update%9
    If disabled, updates will be just queued but none will be run until you enable it again
%9piespy_channels_allow%9
%9piespy_channels_deny%9
    Comma-separated list of channels for which to track the social network; if allow list is empty, all except deny are allowed
%9piespy_count_mode%9
    If enabled, +o and +v also creates/enweightens a social connection
%9piespy_bare_nicknames%9
    If enabled, nicknames are stripped of any leading/trailing special characters before incorporating to the social network
USAGE
    ;

  } elsif ($data =~ /^stat/i) {
    Irssi::print "Hello, this is PieSpy $VERSION!";

    my $chancount = scalar keys %$graph;
    my ($nodecount, $edgecount) = (0, 0);
    foreach my $g (values %$graph) {
      $nodecount += scalar keys %{$g->{nodes}};
      $edgecount += scalar @{$g->{edges}};
    }
    Irssi::print "I'm currently tracking $chancount channels, with total of $nodecount people maintaining $edgecount connections.";
    if (defined $child) {
      Irssi::print "I'm updating stuff right now w/ pid $child.";
    }
    if (@upqueue) {
      Irssi::print "I have updates queued for these channels: @upqueue.";
    }

  } elsif ($data =~ /^update/i) {
    Irssi::print "Updating all files...";
    update(keys %$graph);
    Irssi::print "Done.";

  } elsif ($data =~ /^chlist/i) {
    Irssi::print "Currently tracking channels:";
    foreach my $g (values %$graph) {
      my ($nodecount, $edgecount) = (scalar keys %{$g->{nodes}}, scalar @{$g->{edges}});
      Irssi::print $g->{name} . ": $nodecount people, $edgecount connections";
    }

  } elsif ($data =~ /^chwho\s+(\S+)/i) {
    unless ($graph->{lc $1}) {
      Irssi::print "Unknown channel $1.";
      return;
    }

    # TODO: Edge count for each node. --pasky

    Irssi::print "Currently tracking on channel $1:";
    foreach my $node (values %{$graph->{lc $1}->{nodes}}) {
      Irssi::print $node->[NODES_NAME];
    }

  } elsif ($data =~ /^chnet\s+(\S+)(\s+(\S+))?/i) {
    unless ($graph->{lc $1}) {
      Irssi::print "Unknown channel $1.";
      return;
    }

    Irssi::print "Social network on channel $1:";
    foreach my $edge (@{$graph->{lc $1}->{edges}}) {
      next if (defined $3 and lc $3 ne $edge->[EDGES_P1] and lc $3 ne $edge->[EDGES_P2]);
      Irssi::print sprintf('%-12s <-> %-12s [% 2.01f]', $edge->[EDGES_P1], $edge->[EDGES_P2], $edge->[EDGES_WEIGHT]);
    }

  } elsif ($data =~ /^merge\s+(\S+)\s+(\S+)\s+(\S+)/i) {
    my ($channel, $target, $nick) = ($1, $2, $3);
    my $g = $graph->{lc $channel};

    unless ($g) {
      Irssi::print "Unknown channel $channel.";
      return;
    }

    $target = lc $target if (defined $target);
    $target = bare_nickname($target) if (defined $target and Irssi::settings_get_bool("piespy_bare_nicknames"));

    $nick = lc $nick if (defined $nick);
    $nick = bare_nickname($nick) if (defined $nick and Irssi::settings_get_bool("piespy_bare_nicknames"));


    # Alias

    if ($g->{aliases}->{$nick}) {
      Irssi::print "Alias $nick (-> ".$g->{aliases}->{$nick}.") already exists.";
      return;
    }

    if ($g->{aliases}->{$target}) {
      Irssi::print "$target (-> ".$g->{aliases}->{$target}.") is itself an alias.";
      return;
    }

    Irssi::print "[$channel] Adding alias $nick -> $target";
    $g->{aliases}->{$nick} = $target;


    # Merge

    Irssi::print "[$channel] Merging $nick -> $target";

    for (my $e = 0; $e < @{$g->{edges}}; $e++) {
      my $edge = $g->{edges}->[$e];

      my $peer;
      $peer = $edge->[EDGES_P2] if ($edge->[EDGES_P1] eq $nick);
      $peer = $edge->[EDGES_P1] if ($edge->[EDGES_P2] eq $nick);
      next unless ($peer);

      add_edge($g, $target, $peer, $edge->[EDGES_WEIGHT]);
      splice (@{$g->{edges}}, $e, 1);
      $e--;
    }

    delete $g->{nodes}->{$nick};

  } elsif ($data =~ /^lsalias\s+(\S+)(\s+(\S+))?/i) {
    my ($channel, $nick) = ($1, $3);
    my $g = $graph->{lc $channel};

    unless ($g) {
      Irssi::print "Unknown channel $channel.";
      return;
    }

    $nick = lc $nick if (defined $nick);
    $nick = bare_nickname($nick) if (defined $nick and Irssi::settings_get_bool("piespy_bare_nicknames"));

    Irssi::print "Aliases for channel ".$channel.":";
    foreach my $alias (keys %{$g->{aliases}}) {
      next if (defined $nick and $nick ne $alias);
      Irssi::print "$alias -> ".$g->{aliases}->{$alias};
    }

  } elsif ($data =~ /^unalias\s+(\S+)\s+(\S+)/i) {
    my ($channel, $nick) = ($1, $2);
    my $g = $graph->{lc $channel};

    unless ($g) {
      Irssi::print "Unknown channel $channel.";
      return;
    }

    $nick = lc $nick if (defined $nick);
    $nick = bare_nickname($nick) if (defined $nick and Irssi::settings_get_bool("piespy_bare_nicknames"));

    unless ($g->{aliases}->{$nick}) {
      Irssi::print "No such alias $nick.";
      return;
    }

    Irssi::print "[$channel] Removing alias $nick -> ".$g->{aliases}->{$nick};
    delete $g->{aliases}->{$nick};

  } else {
    Irssi::print "Unknown command. Try /piespy help for help.";
  }
}



### The epilogue



Irssi::command_bind("piespy", "cmd_piespy");
foreach my $cmd ('usage', 'help', 'stat', 'update', 'chlist', 'chwho', 'chnet', 'merge', 'lsalias', 'unalias') {
  Irssi::command_bind('piespy '.$cmd =>
    sub { cmd_newsline("$cmd ".$_[0], $_[1], $_[2]); } );
}

Irssi::signal_add("event privmsg", "event_privmsg");
Irssi::signal_add("event mode", "event_mode");
Irssi::signal_add("message kick", "event_message_kick");
Irssi::signal_add("message own_public", "event_message_own_public");
Irssi::signal_add("pidwait", "funeral_service");

Irssi::settings_add_str("piespy", "piespy_data_file", "socnet.dat");
Irssi::settings_add_str("piespy", "piespy_graph_file", "socnet-\%c.png");
Irssi::settings_add_str("piespy", "piespy_font_dir", "/usr/X11/lib/X11/fonts/TTF");
Irssi::settings_add_str("piespy", "piespy_width", 800);
Irssi::settings_add_str("piespy", "piespy_height", 600);
=moo
Irssi::settings_add_bool("piespy", "piespy_update_continuous", 1);
Irssi::settings_add_int("piespy", "piespy_update_interval", 10);
=cut
Irssi::settings_add_bool("piespy", "piespy_debug", 0);
Irssi::settings_add_bool("piespy", "piespy_update", 1);
Irssi::settings_add_str("piespy", "piespy_channels_allow", "");
Irssi::settings_add_str("piespy", "piespy_channels_deny", "");
Irssi::settings_add_bool("piespy", "piespy_count_mode", 0);
Irssi::settings_add_bool("piespy", "piespy_bare_nicknames", 1);

Irssi::print("PieSpy $VERSION loaded: /piespy help for help");


if (open (DUMP, Irssi::settings_get_str("piespy_data_file"))) {
  eval join("\n", <DUMP>);
  close (DUMP);
}

# vim:sw=2: