contour.pl

#!/usr/bin/perl

use warnings;
use strict;

my $parsons = shift;
if (!$parsons || $parsons !~ /^\*/)
{
    print STDERR "Parsons code must start with *\n";
    exit 1;
}
$parsons =~ s/^\*//g;

my $output;
my $pitch = 0;
my $index = 1;
$output->{$pitch}->{$index} = "*";

foreach my $parson (split //, $parsons)
{
    $parson = lc $parson;
    if ($parson eq "r")
    {
        $output->{$pitch}->{ ++$index } = "-";
        $output->{$pitch}->{ ++$index } = "*";
    }
    elsif ($parson eq "u")
    {
        $output->{ --$pitch }->{ ++$index } .= "/";
        $output->{ --$pitch }->{ ++$index } .= "*";
    }
    elsif ($parson eq "d")
    {
        $output->{ ++$pitch }->{ ++$index } .= "\\";
        $output->{ ++$pitch }->{ ++$index } .= "*";
    }
    else
    {
        print STDERR "Illegal tone '$parson'\n";
        exit 1;
    }
}

foreach my $line (sort { $a <=> $b } keys %$output)
{
    $index = 0;
    foreach my $note (sort { $a <=> $b } keys %{ $output->{$line} })
    {
        my $offset = $note - $index;
        print " " x --$offset if $offset > 1;
        print $output->{$line}->{$note};
        $index = $note;
    }
    print "\n";
}