User:Saric/Roadmap

#!/usr/bin/perl
 
use warnings;
use strict;
use SVG;
 
# ---------------------------------------------------------------
# Options
# ---------------------------------------------------------------
 
our $side_length = 500;
  # Height and width of the roadmap square in pixels.
# The following sizes are expressed as fractions of
# $side_length.
our $line_width = 1/250;
  # The width of the divider lines.
our $legend_width = 1/2;
  # Width of the margin used for the legend.
our $legend_box_space = 1/30;
  # Space between the rectangle for each legend and the
  # right edge of the roadmap square.
our $legend_top_margin = 1/30;
  # Space between the first box of the legend and the top of the
  # image.
our $legend_box_width = 1/20;
our $legend_box_height = 1/40;
our $legend_text_space = 1/50;
  # Space between the left edge of each legend box and
  # its descriptive text.
our $legend_line_break = 1/50;
 
our $line_color = '#DADADA';
our $roadmap_font =
    '"DejaVu Sans Mono", "Andale Mono", monospace';
our $legend_font =
    '"DejaVu Sans", Arial, "sans-serif"';
 
our %text_colors =
   (map({$_ => 'white'}
        qw(black darkgray blue darkgreen purple)),
    map({$_ => 'black'}
        qw(white lightgray lightblue cyan orange
           lightgreen red yellow salmon magenta)));
 
our @scripts =
   (['latin', 'Latin scripts and symbols', 'black'],
    ['ling', 'Linguistic scripts', 'lightblue'],
    ['euro', 'Other European scripts', 'blue'],
    ['meswa', "Middle Eastern and\nSouthwest Asian scripts", 'orange'],
    ['africa', 'African scripts', 'lightgreen'],
    ['Sasian', 'South Asian scripts', 'darkgreen'],
    ['SEasian', 'Southeast Asian scripts', 'purple'],
    ['Easian', 'East Asian scripts', 'red'],
    ['han', 'Unified CJK Han', 'salmon'],
    ['canada', 'Canadian Aboriginal scripts', 'yellow'],
    ['symbol', 'Symbols', 'magenta'],
    ['diacritics', 'Diacritics', 'darkgray'],
    ['private', "UTF-16 surrogates and\nprivate use", 'lightgray'],
    ['misc', 'Miscellaneous characters', 'cyan'],
    ['unused', 'Unallocated code points', 'white']);
 
# http://www.unicode.org/roadmaps/bmp/
# Format of each line:
#   First 2 hex digits, 3rd digit, script name   # Comment
our $data_string =
 qq[00 0 latin
    02 5 ling
    03 0 diacritics
    03 7 euro
    05 9 meswa
    07 8 Sasian
    07 C africa
    08 4 unused
    09 0 Sasian
    0E 0 SEasian
    10 A meswa
    11 0 Easian
    12 0 africa
    13 A canada
    16 8 euro
    17 0 Easian
    17 8 SEasian
    18 0 Easian
    18 B unused
    19 0 Sasian
    19 5 Easian
    19 E SEasian
    1A B unused
    1B 0 Sasian
    1B C unused
    1C 0 Sasian
    1D 0 ling
    1D C diacritics
    1E 0 latin
    1F 0 euro
    20 0 symbol
    20 7 latin
    20 A symbol
    21 0 latin
    21 9 symbol
    24 6 latin
    25 0 symbol
    2C 0 euro
    2C 6 latin
    2C 8 euro
    2D 0 meswa
    2D 3 africa
    2D E euro
    2E 0 SEasian
    2E 8 han
    30 4 Easian
    31 A han  # The third digit is a wild guess, really.
    31 F Easian
    34 0 han
    4D C symbol
    4E 0 han
    A0 0 Easian
    A5 0 africa  # Vai counts as an African script, right?
    A6 4 euro
    A6 A africa
    A7 0 Easian
    A7 2 latin
    A8 0 Sasian
    A9 0 Easian
    A9 3 SEasian
    A9 6 Easian
    A9 8 SEasian
    A9 E unused
    AA 0 SEasian
    AA 6 unused
    AA 8 SEasian
    AA E unused
    AB 0 unused
    AC 0 Easian
    D8 0 private
    F9 0 han
    FB 0 misc];
 
# ---------------------------------------------------------------
# Other declarations
# ---------------------------------------------------------------
 
our $grad_defs;
our $grad_id = -1;
 
sub stripes
# This creates a "gradient" of distinct vertical stripes. Its
# arguments should be the starting x-coordinate of the gradient,
# the ending x-coordinate, an SVG color, and then any number of
# stops. Each stop should be an array reference containing a stop
# location (expressed as a number between 0 and 1) and a color.
# The subroutine returns a string you can set a stroke or fill
# attribute to to use the gradient.
 {my ($x1, $x2, $first_color, @stops) = @_;
  my $grad = $grad_defs->gradient
   (-type => 'linear',
    gradientUnits => "userSpaceOnUse",
    id => 'grad' . ++$grad_id,
    x1 => $x1, x2 => $x2);
  $grad->stop
     (offset => '0%',
      'stop-color' => $first_color);
  my $last_color = $first_color;
  foreach (@stops)
     {my $percent = 100*$_->[0] . '%';
      $grad->stop
         (offset => $percent,
          'stop-color' => $last_color);
      $grad->stop
         (offset => $percent,
          'stop-color' => $_->[1]);
      $last_color = $_->[1];}
  $grad->stop
     (offset => '100%',
      'stop-color' => $last_color);
  return "url(#grad$grad_id)";}
 
sub tcolor
# Given the same arguments as &stripes, returns a value to use
# for the "fill" of text overlaying the given colors. This may be
# a solid color instead of a gradient.
 {my ($x1, $x2, $first_color, @stops) = @_;
  my $last_tc = $text_colors{$first_color};
  $first_color = $last_tc;
  for (my $n = 0 ; $n < @stops ; ++$n)
     {my $this_tc = $text_colors{$stops[$n][1]};
      if ($this_tc eq $last_tc)
         # This stop is redundant, so we can remove it.
         {splice(@stops, $n, 1);
          $n < @stops ? redo : last;}
      $stops[$n][1] = $this_tc;
      $last_tc = $this_tc;}
  return (@stops
    ? stripes($x1, $x2, $first_color, @stops) 
    : # We can just return a solid color.
      $first_color);}
 
# ---------------------------------------------------------------
# Process $data_string
# ---------------------------------------------------------------
 
$data_string =~ s {\#.+} {}gm;
our @d = ();
 {my %script_colors = ();
  $script_colors{$_->[0]} = $_->[2] foreach @scripts;
  foreach (split /\s*\n\s*/, $data_string)
     {/\S/ or next;
      /(.)(.)\s+(.)\s+(.+)/;
      push( @d, [hex($1), hex($2), hex($3),
                 $script_colors{$4}] );}}
 
# ---------------------------------------------------------------
# Set up the SVG
# ---------------------------------------------------------------
 
$$_ *= $side_length foreach
   (\$line_width, \$legend_width, \$legend_box_space,
    \$legend_box_height, \$legend_top_margin,
    \$legend_box_width, \$legend_text_space,
    \$legend_line_break);
 
our $svg = new SVG
   (width => $side_length + $legend_width,
    height => $side_length);
$svg->title->cdata('Roadmap to the Unicode BMP');
$grad_defs = $svg->defs;
  # I declare this here to ensure that the gradient definitions
  # appear in the file before anything else, especially the
  # rectangles that reference them.
$svg->rectangle
   (x => 0, 'y' => 0,
    width => $side_length + $legend_width,
    height => $side_length,
    'stroke-width' => 0,
    'fill' => 'white');
our $rectgrp = $svg->group
   ('stroke-width' => ($line_width . 'px'),
    'stroke' => $line_color);
our $sq_side_length =
    ($side_length - $line_width) / 16;
our $roadmap_tgrp = $svg->group
   ('text-anchor' => 'middle',
    'font-family' => $roadmap_font,
    'font-size' => ($sq_side_length/2 . 'px'),
    'stroke-width' => 0);
our $legend_tgrp = $svg->group
   ('text-anchor' => 'left',
    'font-family' => $legend_font,
    'font-size' => ($legend_box_height . 'px'),
    'stroke-width' => 0,
    'fill' => 'black');
 
# ---------------------------------------------------------------
# Draw the roadmap square
# ---------------------------------------------------------------
 
 {my $last_c = shift(@d)->[3];
    # The last color we used.
  my @next = @{shift @d};
    # The next stop (equivalent to one line of the $data_string).
  foreach my $y (0 .. 15)
     {foreach my $x (0 .. 15)
         # $y and $x correspond to the first and second digits,
         # respectively, of each character's code point
         {my $xp = $line_width/2 + $x*$sq_side_length;
          my $yp = $line_width/2 + $y*$sq_side_length;
          my ($sq_fill, $t_fill);
          my @stops_here = ();
            # Stops that occur in this square.
          while (@next and $next[0] == $y and $next[1] == $x)
             {push(@stops_here, [@next]);
              @next = (@d ? @{shift @d} : ());}
          if (@stops_here)
             {$stops_here[0][2]
                or $last_c = shift(@stops_here)->[3];
              my @args =
                 ($xp, 
                  $xp + $sq_side_length,
                  $last_c,
                  map {[ $_->[2]/16, $_->[3] ]} @stops_here);
              $sq_fill = stripes(@args);
              $t_fill = tcolor(@args);
              @stops_here
                and $last_c = $stops_here[-1][3];}
          else
             {$sq_fill = $last_c;
              $t_fill = $text_colors{$sq_fill};}
          $rectgrp->rectangle
             (x => $xp, 'y' => $yp,
              width => $sq_side_length,
              height => $sq_side_length,
              fill => $sq_fill);
          $roadmap_tgrp->text
             (x => ($xp + $sq_side_length/2),
              'y' => ($yp + (2/3)*$sq_side_length),
              fill => $t_fill)
             ->cdata(sprintf('%X%X', $y, $x));}}}
 
# ---------------------------------------------------------------
# Draw the legend
# ---------------------------------------------------------------
 
 {my $x = $side_length + $legend_box_space + $line_width / 2;
  my $y = $legend_top_margin + $line_width / 2;
  foreach (@scripts)
     {$rectgrp->rectangle
         (x => $x, 'y' => $y,
          width => $legend_box_width,
          height => $legend_box_height,
          fill => $_->[2]);
      my @txt = split /\n/, $_->[1];
      foreach (@txt) 
         {$legend_tgrp->text
             (x => ($x + $legend_box_width + $legend_text_space),
              'y' => ($y + (4/5)*$legend_box_height))
             ->cdata($_);
          $y += (5/4)*$legend_box_height;}
      $y += $legend_line_break;}}
 
# ---------------------------------------------------------------
# Output
# ---------------------------------------------------------------
 
my $txt = $svg->xmlify;
# Remove extra space in <text> elements. Inkscape ignores it, but
# librsvg treats it like a normal character, thus screwing up
# text alignment.
$txt =~ s{\s+</text>\s} {</text>\n}g;
# Do the same for the <title>, for good measure.
$txt =~ s{\s+</title>\s} {</title>\n};
# Change to Unix-style newlines if necessary.
$txt =~ s{\015\012?} {\012}g;
print $txt;