#!/usr/bin/perl
##
# Widen the lines on the dot graphs so that they appear thicker for the 
# common paths.
#
# This script is expected to be used with the output from 'visitors' to
# thicken the lines on the produced 'dot' graph. Whilst the 'visitors'
# tool produces a useful presentation of the site, it is often useful to
# vary this presentation for some sites.
#
# The frequency of path use is shown as the line label. This ranges from
# about 0.3 to a high of about 30 - it may get bigger than this if the
# site has a path that it /always/ used.
#
# The line width ranges from 1.0 upwards. We try to keep the minimum as 
# 1.0.
#
# For my own use, the following example works well:
#
#   ./widen-lines.pl -toptobottom \
#                    -colour /riscos/=#ffddff \
#                    -label '/riscos/ramble/(.*)=$1' \
#                    -i visitors-rambles.dot
#
# This makes everything in the '/riscos/' tree come out with a pink node,
# (rather than the usual blue), and changes the text on all the nodes
# within '/riscos/ramble/' to just use the trailing path name, as this
# shortens the text.
# 
# @author Justin Fletcher
# @file
#

use Getopt::Long;

my $inplace = 0;
my $help = 0;
my $nopathlabels = 0;
my $maxwidth = 16;
my $weighted = 0;
my $factor = 1;
my $toptobottom = 0;
my %colours;
my %labels;

GetOptions('help' => \$help,
           'colour=s%' => \%colours,
           'label=s%' => \%labels,
           'inplace' => \$inplace,
           'nopathlabels' => \$nopathlabels,
           'maxwidth' => \$maxwidth,
           'toptobottom' => \$toptobottom,
           'weighted' => \$weighted,
           'factor' => $factor,
          );

my $input = shift;
my $output = shift;

if ($inplace)
{
    $output = $input;
}

if (!defined $input ||
    !defined $output ||
    $help)
{
    print <<EOM;
Widen the lines on the graph according to the label.
Optionally also applies other manipulation of the graph, such as
changing the render order, the colours or the text.
Syntax: $0 <options> <input> <output>
Options:
    -help               This help.
    -inplace            Replace the file in place. Does not require an
                        <output> file specification.
    -nopathlabels       Disable the labels on paths.
    -maxwidth <factor>  Maximum width to use (default $maxwidth).
    -weighted           Whether we use the frequency to weight paths.
                        This produces a more linear tree, by forcing the
                        common paths to be more likely to use straight
                        lines.
    -toptobottom        Changes form left-to-right presentation to the
                        top-to-bottom presentation.
                        Top-to-bottom may work better with highly linear
                        paths through the site.
                        Left-to-right may work better with paths which
                        radiate from a single node (or few nodes).
    -factor <factor>    Scaling factor; increasing the frequency
                        by this factor doubles the width of the line.
                        Use 0 for linear size increase.
                        (Default $factor).
    -colour <path>=<colour>
                        Change the colour of a node in the output diagram.
                        The path specified is a regular expression to match.
    -label <path>=<replacement>
                        Perform a replacement of the text label used for
                        paths. The path specified is a regular expression to
                        match, which is anchored at both ends.
                        The replacement may include references to
                        groups in the matched path.

The -colour and -label specifiers may be used multiple times, and will be
applied longest rule to shortest.
EOM
    exit 1;
}

my $text = "";
open(my $fh, ($input eq $output) ? "+<" : "<", $input) ||
    die "Could not read $input: $!\n";
sysread($fh, $text, -s $input);

# Perform the replacements for the widths.
$text =~ s/(label="([\d\.]+)")/replace_edge($1, $2);/ge;

# Perform the replacements for the nodes themselves.
my %seennodes;
$text =~ s/("([^"]+)" -> "([^"]+)".*\n)/
           my ($all, $first, $second) = ($1, $2, $3);
           $all.replace_node($first).replace_node($second);/gme;

if ($toptobottom)
{
    $text =~ s/rankdir=LR/rankdir=TB/;
}

if ($input eq $output)
{
    # Same file, so move to the start.
    seek($fh, 0, 0);
}
else
{
    open($fh, ">", $output) ||
        die "Could not write $output: $!\n";
}

print $fh $text;
close($fh);


##
# Perform the replacement on the edges (labels, widths).
#
# @param[in] $label    The full label line
# @param[in] $freq     The frequency from the label
#
# @return the replacement text, which may include the original label
sub replace_edge
{
    my ($label, $freq) = @_;
    
    my $newtext = "";
    if (!$nopathlabels)
    {
        $newtext = "$label ";
    }
    
    my $width;
    if ($factor == 0)
    {
        $width = $freq;
    }
    else
    {
        $width = 2 ** ($freq / $factor);
    }
    $width = $maxwidth if ($width > $maxwidth);

    $newtext .= "penwidth=$width";
    
    if ($weighted)
    {
        my $weight = int($freq);

        # Values less than 1 can have lines that wiggle all over the 
        # place. This makes the diagram look very fun, but reduces the
        # readability significantly.
        # 'dot' requires that the weights be integers.
        $weight++;

        $newtext.= " weight=$weight";
    }
    
    return $newtext;
}


##
# Perform replacements on the nodes.
#
# This allows us to change the text that labels each node, or its
# colouring.
#
# @param[in] $node      Node identifier (the path)
#
# @return Any new text to add to the dot file to describe the node.
sub replace_node
{
    my ($node) = @_;

    # If we've already seen this node, we don't need to add any text.
    return "" if (defined $seennode{$node});

    my $colour;
    my $label;
    
    # We'll check all the paths that we were given, from longest to
    # shortest.
    # First for the colours.
    for my $path (sort { length $b <=> length $a } keys %colours)
    {
        if ($node =~ /$path/)
        {
            # Matched. Yay.
            $colour = $colours{$path};
            last;
        }
    }

    # Then for the label replacements
    for my $path (sort { length $b <=> length $a } keys %labels)
    {
        if ($node =~ /^$path$/)
        {
            # Matched, perform replacement on the labels.
            $label = $node;
            # Deep magic. See http://www.perlmonks.org/?node_id=687031
            $label =~ s/^$path$/eval qq{"$labels{$path}"}/e;
            last;
        }
    }
    
    my @attribs;
    if (defined $colour)
    {
        push @attribs, "color=\"$colour\"";
    }
    if (defined $label)
    {
        push @attribs, "label=\"$label\"";
    }
    
    if (@attribs != 0)
    {
        return "  \"$node\" [". join(" ", @attribs). "]\n";
    }
    else
    {
        return "";
    }
}