File:BrownCabinet.svg

#!/usr/bin/perl -w

############################################################################
# Version 1.1, 3 October 2009
#
# Copyright 2009 TimR. All rights reserved.
############################################################################

############################################################################
# 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 3 of the License, 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.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
############################################################################

use strict;

my @colours = qw(
  blue
  blueviolet
  brown
  burlywood
  cadetblue
  chartreuse
  crimson
  darkblue
  darkcyan
  darkgreen
  darkgrey
  darkmagenta
  darkorange
  deepskyblue
  dimgrey
  forestgreen
  gold
  goldenrod
  hotpink
  indianred
  indigo
  khaki
  lawngreen
  lightblue
  lightcoral
  lightgreen
  lightgrey
  lightpink
  lightsalmon
  lightskyblue
  lightslategrey
  lightsteelblue
  lime
  limegreen
  magenta
  maroon
  mediumblue
  mediumorchid
  mediumpurple
  mediumseagreen
  mediumslateblue
  mediumspringgreen
  mediumturquoise
  mediumvioletred
  mistyrose
  moccasin
  navajowhite
  navy
  oldlace
  olive
  olivedrab
  orange
  orangered
  orchid
  palegoldenrod
  palegreen
  paleturquoise
  palevioletred
  papayawhip
  peachpuff
  peru
  pink
  plum
  powderblue
  purple
  red
  rosybrown
  royalblue
  saddlebrown
  salmon
  sandybrown
  seagreen
  seashell
  sienna
  silver
  skyblue
  slateblue
  slategray
  slategrey
  snow
  springgreen
  steelblue
  tan
  teal
  thistle
  tomato
  turquoise
  violet
  wheat
  white
  whitesmoke
  yellow
  yellowgreen
);

my @headers =                 ("Jun 07",  "Jan 08",  "Oct 08",  "Jun 09");
                            
my @rawdata = (             
  [ "Lord Adonis",          qw(-          -          -          trans      )],
  [ "Bob Ainsworth",        qw(-          -          -          defence    )],
  [ "Douglas Alexander",    qw(id         id         id         id         )],
  [ "Valerie Amos",         qw(-          -          -          -          )],
  [ "Hilary Armstrong",     qw(-          -          -          -          )],
  [ "Lady Ashton",          qw(lhol       -          -          -          )],
  [ "Margaret Beckett",     qw(-          -          house      -          )],
  [ "Ed Balls",             qw(csf        csf        csf        csf        )],
  [ "Hilary Benn",          qw(efra       efra       efra       efra       )],
  [ "Tony Blair",           qw(-          -          -          -          )],
  [ "Hazel Blears",         qw(clg        clg        clg        -          )],
  [ "David Blunkett",       qw(-          -          -          -          )],
  [ "Paul Boateng",         qw(-          -          -          -          )],
  [ "Ben Bradshaw",         qw(-          -          -          cms        )],
  [ "Gordon Brown",         qw(pm         pm         pm         pm         )],
  [ "Nick Brown",           qw(-          -          whip       whip       )],
  [ "Des Browne",           qw(defence    defence    -          -          )],
  [ "Andy Burnham",         qw(treas      cms        cms        health     )],
  [ "Liam Byrne",           qw(-          cab        cab        treas      )],
  [ "Charles Clarke",       qw(-          -          -          -          )],
  [ "Yvette Cooper",        qw(house      treas      treas      work       )],
  [ "Alistair Darling",     qw(chan       chan       chan       chan       )],
  [ "John Denham",          qw(ius        ius        ius        clg        )],
  [ "Charles Falconer",     qw(-          -          -          -          )],
  [ "Caroline Flint",       qw(-          house      europe     -          )],
  [ "Peter Hain",           qw(work       -          -          wales      )],
  [ "Harriet Harman",       qw(lhoc       lhoc       lhoc       lhoc       )],
  [ "Patricia Hewett",      qw(-          -          -          -          )],
  [ "Geoff Hoon",           qw(whip       whip       trans      -          )],
  [ "John Hutton",          qw(bis        bis        defence    -          )],
  [ "Alan Johnson",         qw(health     health     health     home       )],
  [ "Tessa Jowell",         qw(-          olymp      olymp      cab        )],
  [ "Ruth Kelly",           qw(trans      trans      -          -          )],
  [ "Lady Kinnock",         qw(-          -          -          europe     )],
  [ "Dennis MacShane",      qw(-          -          -          -          )],
  [ "Lord Mandelson",       qw(-          -          bis        bis        )],
  [ "David Miliband",       qw(fs         fs         fs         fs         )],
  [ "Ed Miliband",          qw(cab        energy     energy     energy     )],
  [ "Jim Murphy",           qw(europe     europe     -          scot       )],
  [ "Paul Murphy",          qw(-          wales      wales      -          )],
  [ "James Purnell",        qw(cms        work       work       -          )],
  [ "John Reid",            qw(-          -          -          -          )],
  [ "Lady Royall",          qw(-          lhol       lhol       lhol       )],
  [ "Chris Smith",          qw(-          -          -          -          )],
  [ "Jacqui Smith",         qw(home       home       home       -          )],
  [ "Jack Straw",           qw(lchan      lchan      lchan      lchan      )],
  [ "Stephen Timms",        qw(-          -          -          -          )],
  [ "Shaun Woodward",       qw(ni         ni         ni         ni         )],
);

my @cats = (
  pm      => "Prime Minister",
  lhoc    => "Leader of the House of Commons",
  chan    => "Chancellor",
  fs      => "Foreign Secretary",
  lchan   => "Lord Chancellor",
  home    => "Home Secretary",
  efra    => "Environment, Food and Rural Affairs",
  id      => "International Development",
  clg     => "Communities and Local Government",
  ius     => "Innovation, Universities and Skills",
  csf     => "Children, Schools and Families",
  energy  => "Energy and Climate Change",
  health  => "Health",
  ni      => "Northern Ireland",
  lhol    => "Leader of the House of Lords",
  cab     => "Cabinet Office",
  olymp   => "Olympics",
  scot    => "Scotland",
  work    => "Work and Pensions",
  cms     => "Culture, Media and Sport",
  treas   => "Chief Secretary to the Treasury",
  wales   => "Wales",
  bis     => "Business, Innovation and Skills",
  defence => "Defence",
  trans   => "Transport",
  europe  => "Europe",
);

my %cats;
my @catmap;
for (my $n=0; $n*2<@cats; $n++) {
  my $tag = $cats[$n*2];
  $cats{$tag} = {
                  tag    => $tag,
                  index  => $n,
                  name   => $cats[$n*2+1],
                };
  $catmap[$n] = $cats{$tag};
}

my @data = map {
                 {
                   name   => $_->[0],
                   positions => [ map { $cats{$_}->{index} }
                                      @{$_}[1 .. @$_-1]
                                ],
                 }
               } @rawdata;

$_->{colour} = shift @colours
  foreach @data;

my $numbercolumns;
my $numberrows;
my $minposition;
my $maxposition;

foreach (@data) {
  $numbercolumns = @{$_->{positions} }
    if !defined $numbercolumns ┃┃
       $numbercolumns < @{$_->{positions} };

  foreach (@{$_->{positions} }) {
    $minposition = $_
      if defined $_ &&
         (!defined $minposition ┃┃
          $_ < $minposition);
    $maxposition = $_
      if defined $_ &&
         (!defined $maxposition ┃┃
          $_ > $maxposition);
  }
}
$numberrows = $maxposition - $minposition + 1;

my $leftmargin        = 10;
my $rightmargin       = 10;
my $topmargin         = 10;
my $bottommargin      = 10;
my $spacer            = 20;
my $lefttextboxwidth  = 480;
my $righttextboxwidth = 300;
my $colwidth          = 120;
my $rowheight         = 70;
my $lefttextvoffset   = 8;
my $textvoffset       = -8;
my $blobradius        = 10;
my $linewidth         = 10;
my $headerheight      = 40;

my $chartxoffset = $leftmargin + $lefttextboxwidth + $spacer;
my $chartyoffset = $topmargin + $headerheight;

my $chartwidth = $blobradius +
                 ($numbercolumns - 1) * $colwidth +
                 $blobradius;
my $totalwidth = $leftmargin + $lefttextboxwidth + $spacer +
                 $blobradius +
                 ($numbercolumns - 1) * $colwidth +
                 $blobradius +
                 $spacer +
                 $righttextboxwidth + $rightmargin;
my $totalheight = $topmargin +
                  $headerheight +
                  $numberrows * $rowheight +
                  $bottommargin;

print <<EOF;
<?xml version='1.0'?>
<!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 1.1//EN' 
  'http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd'>
<svg xwidth='5cm' xheight='4cm'
     version='1.1'
     xmlns='http://www.w3.org/2000/svg'
     viewBox='0 0 $totalwidth $totalheight'>
  <desc>Cabinet chart</desc>



  <rect x='0' y='0' width='$totalwidth' height='$totalheight'
        fill='white' stroke='none' stroke-width='2'/>

EOF

########################################################################
# Print grid
########################################################################
print "  <g fill='none' stroke='grey' stroke-width='1'>\n";
for (my $i=0; $i<$numberrows; $i++) {
  printf "    <line x1='%s' y1='%s' x2='%s' y2='%s'/>\n",
        0, $chartyoffset + $i * $rowheight,
        $totalwidth, $chartyoffset + $i * $rowheight;
}
printf "    <line x1='%s' y1='%s' x2='%s' y2='%s'/>\n",
      0, $chartyoffset + $numberrows * $rowheight,
      $totalwidth, $chartyoffset + $numberrows * $rowheight;
print "  </g>\n";
print "\n";

########################################################################
# Print headers
########################################################################
print "  <g font-size='20' fill='black' font-family='sans-serif'>\n";
for (my $i=0; $i<@headers; $i++) {
  printf "    <text x='%s' y='%s'>%s</text>\n",
         $chartxoffset + $blobradius + $i * $colwidth - 20,
         $headerheight - 10,
         $headers[$i];
}
print "  </g>\n";
print "\n";

########################################################################
# Calculate segments
########################################################################
my @newsegments;
for (my $i=@data-1; $i>=0; $i--) {
  my $item = $data[$i];

  for (my $start=0; $start<$numbercolumns; $start++) {
    if (defined $item->{positions}[$start]) {
      my $end = $start;
      while ($end+1<$numbercolumns &&
             defined $item->{positions}[$end+1]) {
        $end ++;
      }

      my @coords;
      foreach ($start .. $end) {
        push @coords, $chartxoffset + $blobradius + $colwidth * $_,
                      $chartyoffset +
                      ($item->{positions}[$_] - $minposition) * $rowheight +
                      $rowheight/2 + 10;
      }

      push @newsegments, {
                           item   => $item,
                           start  => $start,
                           end    => $end,
                           coords => \@coords,
                         };
      $start = $end + 1;
    }
  }
}

########################################################################
# Print lines, blobs
########################################################################
print "  <g stroke-width='$linewidth' stroke-linecap='round' fill='none'>\n";
foreach my $segment (@newsegments) {
    my @coords = @{$segment->{coords} };
    my @points = @coords;
    push @points, $chartxoffset + $chartwidth + $spacer + $righttextboxwidth,
                  $points[-1]
      if $segment->{end} == $numbercolumns-1;

    printf "    <polyline stroke='%s' points='%s'/>\n",
           $segment->{item}{colour},
           join(" ", @points);

    while (@coords > 1) {
      my $x = shift @coords;
      my $y = shift @coords;
      printf "    <circle cx='%s' cy='%s' r='%s' fill='%s'/>\n",
            $x, $y, $blobradius, $segment->{item}{colour};
    }
}
print "  </g>\n";
print "\n";

########################################################################
# Print labels
########################################################################
print "  <g font-size='24' fill='black' font-family='sans-serif' font-weight='bold'>\n";
foreach my $segment (@newsegments) {
    my @coords = @{$segment->{coords} };
    my ($x, $y);
    if ($segment->{end} == $numbercolumns-1) {
      $x = $coords[-2] + 60;
      $y = $coords[-1] - 15;
    } else {
      $x = $coords[0] - 10;
      $y = $coords[1] - 20;
    }

    printf "    <text x='%s' y='%s'>%s</text>\n",
          $x, $y, $segment->{item}{name} #. " " .  $segment->{item}{colour}
          ;
}
print "  </g>\n";
print "\n";

########################################################################
# Print text columns
########################################################################
print "  <g font-size='24' fill='black' font-family='sans-serif' font-weight='bold'>\n";

for (my $i=0; $i<$numberrows; $i++) {
  printf "    <text x='%s' y='%s'>%s</text>\n",
        $leftmargin,
        $chartyoffset + $i * $rowheight + $rowheight/2 + $lefttextvoffset,
        $catmap[$i]->{name} #. " " .  $catmap[$i]->{tag}
        ;
}
print "  </g>\n";

print <<EOF;
</svg>
EOF