#!/usr/bin/perl -w
use strict;

my $DEBUG = 0;

my @colours;
my %commands;
my %macros;

my $ltw = 3;
my $modulus = 16;

{
  foreach my $c((
    [0xff,0xc0,0xc0],
    [0xff,0xff,0xc0],
    [0xc0,0xff,0xc0],
    [0xc0,0xff,0xff],
    [0xc0,0xc0,0xff],
    [0xff,0xc0,0xff],

    [0xff,0x00,0x00],
    [0xff,0xff,0x00],
    [0x00,0xff,0x00],
    [0x00,0xff,0xff],
    [0x00,0x00,0xff],
    [0xff,0x00,0xff],

    [0xc0,0x00,0x00],
    [0xc0,0xc0,0x00],
    [0x00,0xc0,0x00],
    [0x00,0xc0,0xc0],
    [0x00,0x00,0xc0],
    [0xc0,0x00,0xc0],

    [0x00,0x00,0x00],
    [0xff,0xff,0xff]
  ))
  {
    push @colours, chr($c->[0]) . chr($c->[1]) . chr($c->[2]);
  }
}

{
  my $i = 0;
  foreach my $command((
   'ext', 'push', 'pop', 'add', 'sub', 'mul', 'div', 
   'mod', 'not', 'gt', 'ptr', 'switch', 'dup', 'roll',
   'inn', 'in', 'outn', 'out'
  ))
  {
    my $lightness = ($i % 3);
    my $hue = int(($i-$lightness) / 3 );
    $i++;
    $commands{$command} = [ 0, $hue, $lightness, $command ];
  }
  $commands{'black'} = [ 1, [18], 0, 'black' ];
  $commands{'white'} = [ 1, [19], 0, 'white' ];
}

my $lnbr = 0;

sub gen_halt
{
  my($track) = @_;
  
  push @$track, [2, 1, 'white'];
  push @$track, [1, 3, [0,18,19]]; 
  push @$track, [1, 3, [0,19,19]]; 
  push @$track, [1, 3, [0,18,18]]; 
  push @$track, [2, 1, 'black'];
}

sub gen_push_zero
{
  my($track) = @_;
  push @$track,[2, 1, 'push'];
  push @$track,[2, 1, 'not'];
}

sub gen_push_int
{
  my($track, $int) = @_;

  if($int == 0)
  {
    gen_push_zero($track);
    return;
  }
  if($int < 0)
  {
    gen_push_zero($track);
    gen_push_int($track, -$int);
    push @$track,[2, 1, 'sub'];
    return;
  }
  my $m = $modulus;
  if($int <= $m )
  {
    $track->[$#$track]->[1] = $int;
    push @$track,[2, 1, 'push'];
    return;
  }
  if(($int % $m ) == 0)
  {
    $track->[$#$track]->[1] = $m;
    push @$track,[2, 1, 'push'];
    gen_push_int( $track, int($int / $m) );
    push @$track,[2, 1, 'mul'];
    return;
  }
  
  $track->[$#$track]->[1] = ($int % $m);
  push @$track,[2, 1, 'push'];
  gen_push_int($track, $int - ($int % $m));
  push @$track,[2, 1, 'add'];
}

sub get_d_act
{
   my($n, $l) = @_;
   return ($n<$l)?(($l-$n),'sub'):(($n-$l),'add');
}

sub gen_push_expr
{
  my($track, $string, $internal) = @_;
  defined($internal) or ($string = eval($string));
  my @chars = reverse split(//, $string);
  
  my $last = ord(shift @chars);
  gen_push_int($track, $last);

  my $i = 0;
  my $ldd = 0;
  
  # in a general ASCII string, we expect the differences between adjacent characters to be smaller than the absolute values of those characters
  # so encode the differences instead of the character values, and use add/sub and dup to generate the correct sequence on the stack at runtime
  
  while($i <= $#chars)
  {
    my $n = ord $chars[$i++];
    my ($d, $act) = get_d_act($n, $last); # the difference from the last character, and the command (add/subtract)
    
    if( $d <= $modulus )
    {      
      if( $d != 0 ) # there is a difference, and it'll fit into the track, so we can widen the previous instruction to encode it
      {
        if( $i < $#chars )
        {
            my($d2, $act2) = get_d_act(ord($chars[$i]),$n);
            
            # here's an evil thought: can we encode a whole bunch of small differences more compactly by squishing the track into an S shape?
            # let's see if the next one fits
            if( ($d2!=0) && ($d < ($modulus-9)) && ($d2 < ($modulus-9)) ) 
            {
			  # ooh, it does.
              if($ldd)
              {
                pop @$track;
                pop @$track;
                push @$track, [2, 1, 'ext'];
              }
              my ($c, $cmds) = gen_cmds( [
              ('ext', 'dup', ('ext') x ($d-1), 'push', $act, 'ext', 'push', 'ptr')
              ], 0 ); 
              $cmds = [ reverse @$cmds ];
              push @$cmds, ((19) x (($modulus-1) - $#$cmds));
              push @$track, [1, $modulus, $cmds];
              push @$track, [1, $modulus, [$c, (18) x ($modulus-1)]];

              my $nc;
              ($nc, $cmds) = gen_cmds( [( 
              'ext', 'white', 'ext', 'dup', ('ext') x ($d2-1), 'push', $act2 
              )], $c);
              unshift @$cmds, $c;
              {
                  my $work = 1;
                  while( $work && ( ($i+1) < $#chars) )
                  {
                    $work = 0;
                    my($d3, $act3) = get_d_act(ord($chars[$i+1]),ord($chars[$i]));
                    if( ($d3!=0) && ($d3+$d2) < ($modulus-11) )
                    {
                      $work = 1;
                      my $ncmds;
                      ($nc, $ncmds) = gen_cmds( ['dup', ('ext') x ($d3-1), 'push', $act3 ], $nc );
                      push @$cmds, @$ncmds;
                      $d2 += $d3;
                      $i++;
                    }
                  }
              }
              push @$cmds, ((19) x (($modulus-1) - $#$cmds));
              push @$track, [1, $modulus, $cmds];
              if( $#$cmds >= ($modulus-1) )
              {
				push @$track, [2, 1, 'white'];
			  }
              push @$track, [2, 1, 'white'];
              push @$track, [2, 1, 'ext'];
              $last = ord($chars[$i++]);
              $ldd = 1;
              next;
            } 
        } 
        if($ldd)
        {
          pop @$track;
          pop @$track;
          push @$track, [2, 1, 'ext'];
        }
        push @$track,[2, $d, 'dup'];
        push @$track,[2, 1, 'push'];
        push @$track,[2, 1, $act];
      }
      else
      {
        push @$track,[2, 1, 'dup']; # two identical chars in a row, just dup
      }
    }
    else
    {
      gen_push_int($track, $n); # there's a difference but it won't fit on the track; just encode the whole character the regular way
    }
    
    $last = $n;
    $ldd = 0;
  }
  gen_push_int($track, length $string);
}


sub gen_cmds
{
  my($cnames,$c) = @_;
  defined($c) or $c = 0; 
  my $result;
  my $cmds = [ ];

  foreach my $cname(@$cnames)
  {
    if($cname eq 'white')
    {
      push @$cmds, 19;
      next;
    }
    if($cname eq 'black')
    {
      push @$cmds, 18;
      next;
    }
    push @$cmds, ($c = nextcolour( $c, $cname ) );
    ($cname eq 'ptr') and ($result = $c);
  }
  defined($result) or ($result = $c); 

  return($result, $cmds);
}

sub gen_vline
{
  my($track, $label, $cnames, $c) = @_;
  my ($result, $cmds) = gen_cmds( $cnames, $c ); 

  push @$track, [5, $#$cmds+1, $label, [@$cmds]];
  return ($result, $#$cmds);
}

sub gen_out_expr
{
  my($track, $string, $internal) = @_;
  defined($internal) or ($string = eval($string));
  length($string) or return;

  if( length $string > 6 )
  {
    gen_push_expr($track, $string, 1);
    push @$track, [3, 1, '=0']; 
    push @$track, [2, 1, 'white'];
    my ($c, $l) = gen_vline( $track, '=0', [
    'ext', 'ext', 'push', 'push', 'roll', 'out', 'push', 'sub', 'dup', 'not',
    'ext', 'ext', 'push', 'mul', 'dup', 'ptr', 'pop'
    ] ); 
    $c = nextcolour( $c, 'ptr' );
    push @$track, [1, $l, [$c, (18) x ($l-1)]];
    push @$track, [1, $l, [$c, nextcolour( $c, 'pop' ), (19) x ($l-2)]];
    push @$track, [2, 1, 'ext'];
    return;
  }

  my @chars = split(//, $string);
  my $last = ord(shift @chars);
  gen_push_int($track, $last);
  
  foreach my $c(@chars)
  {
    my $n = ord $c;
    my $d   = ($n<$last)?($last-$n):($n-$last);
    my $act = ($n<$last)?'sub':'add';
    
    if( $d <= $modulus )
    {      
      push @$track,[2, 1, 'dup'];
      if( $d != 0 )
      {
        push @$track,[2, $d, 'out'];
        push @$track,[2, 1, 'push'];
        push @$track,[2, 1, $act];
      }
      else
      {
        push @$track,[2, 1, 'out'];
      }
    }
    else
    {
      push @$track,[2, 1, 'out'];
      gen_push_int($track, $n);
    }
    
    $last = $n;
  }
  push @$track,[2, 1, 'out'];  
}

sub gen_label
{
  my( $track, $string) = @_;
  push @$track, [3, 1, $string]; 
  push @$track, [2, 1, 'ext'];
}

sub gen_b
{
  my( $track, $string, $op) = @_;
  push @$track, [2, 1, 'push'];   
  push @$track, [4, 1, $string, $op]; 
  push @$track, [2, 1, 'black'];
}

sub gen_brgt
{
  my( $track, $string, $op) = @_;
  push @$track, [2, 1, 'gt'];   
  push @$track, [4, 1, $string, $op];
  push @$track, [2, 1, 'white'];
  push @$track, [2, 1, 'ext'];
}

sub gen_brle
{
  my( $track, $string, $op) = @_;
  push @$track, [2, 1, 'gt'];   
  push @$track, [2, 1, 'not'];
  push @$track, [4, 1, $string, $op];
  push @$track, [2, 1, 'white'];
  push @$track, [2, 1, 'ext'];
}

sub gen_bz
{
  my( $track, $string, $op) = @_;
  push @$track, [2, 1, 'not'];
  push @$track, [4, 1, $string, $op]; 
  push @$track, [2, 1, 'white'];
  push @$track, [2, 1, 'ext'];
}

sub gen_bnz
{
  my( $track, $string, $op) = @_;
  push @$track, [2, 1, 'not'];
  push @$track, [2, 1, 'not'];
  push @$track, [4, 1, $string, $op]; 
  push @$track, [2, 1, 'white'];
  push @$track, [2, 1, 'ext'];
}

sub parsecmd
{
  my($line, $track) = @_;

  if($line =~ /^\.btbl\s+(.+)$/i)
  {
    my $labels = [split(/\s/, $1)]; #//
    gen_btbl( $track, $labels );
    return;
  }    

  my $cmd = '';
  foreach my $c( split(/\s/, $line) )
  {
    $cmd = $cmd . (length($cmd)?' ':''). $c;
    length($cmd) or next;
    
    if(defined($macros{$cmd}))
    {
		  parsecmd($macros{$cmd}, $track);
		  $cmd = '';
		  next;
    }

    if($cmd=~/^\@(['"].*[^\\]['"])$/)
    {
      gen_out_expr($track, $1);
      $cmd = '';
      next;
    }
    
    if($cmd=~/^['"].*[^\\]['"]$/)
    {
      gen_push_expr($track, $cmd);
      $cmd = '';
      next;
    }

    if($cmd=~/^\@?['"]/)
    {
      next;
    }

    if($cmd=~/^(-?[0-9][0-9A-Fa-fx]*)$/)
    {
      gen_push_int($track, eval($cmd));
      $cmd = '';
      next;
    }
        
    if(lc($cmd) eq 'halt')
    {
      gen_halt($track);
      $cmd = '';
      next;
    }
    
    if($cmd=~/^br?gt\.([A-Za-z0-9_]+)(?:\.([A-Za-z]+))?$/)
    {
      (!defined($2)) or (defined($commands{$2})) or die("Branch delay cmd must be built-in in line $lnbr, got $2\n");
	  gen_brgt($track, $1, $2);
      $cmd = '';
      next;	  
    }

    if($cmd=~/^br?le\.([A-Za-z0-9_]+)(?:\.([A-Za-z]+))?$/)
    {
      (!defined($2)) or (defined($commands{$2})) or die("Branch delay cmd must be built-in in line $lnbr, got $2\n");
	  gen_brle($track, $1, $2);
      $cmd = '';
      next;	  
    }

    if($cmd=~/^br?z\.([A-Za-z0-9_]+)(?:\.([A-Za-z]+))?$/)
    {
      (!defined($2)) or (defined($commands{$2})) or die("Branch delay cmd must be built-in in line $lnbr, got $2\n");
	  gen_bz($track, $1, $2);
      $cmd = '';
      next;	  
    }

    if($cmd=~/^br?nz\.([A-Za-z0-9_]+)(?:\.([A-Za-z]+))?$/)
    {
      (!defined($2)) or (defined($commands{$2})) or die("Branch delay cmd must be built-in in line $lnbr, got $2\n");
	  gen_bnz($track, $1, $2);
      $cmd = '';
      next;	  
    }
    
    if($cmd=~/^br?\.([A-Za-z0-9_]+)(?:\.([A-Za-z]+))?$/)
    {
      (!defined($2)) or (defined($commands{$2})) or die("Branch delay cmd must be built-in in line $lnbr, got $2\n");
	  gen_b($track, $1, $2);
      $cmd = '';
      next;	  
    }    

    if($cmd=~/^([A-Za-z0-9_]+):$/)
    {
	  gen_label($track, $1);
      $cmd = '';
      next;	  
    }
    
    defined($commands{$cmd}) or die("Syntax error at line $lnbr: $line\n"); 
    push @$track, [2, 1, $cmd];
    $cmd = '';
  }
}

sub colouridx
{
  my($h, $l) = @_;
  return $l*6 + $h;
}

sub _hlc
{
  my($h, $l, $c) = @_;
  $h = int($h + $commands{$c}->[1]) % 6;
  $l = int($l + $commands{$c}->[2]) % 3;
  return ($h, $l);
}

sub nextcolour
{
  my($c, $cmd) = @_;
  my $h = ($c % 6);
  my $l = int(($c-$h) / 6);
  return colouridx( _hlc( $h, $l, $cmd ) );
}

sub _sequence_row
{
  my($count, $data, $width, $margin) = @_;
  my @arry = (18);
  push @arry, (18,19,18) x $margin;
  push @arry, ((18) x ($width - ($#$data+1)));
  push @arry, @{$data};
  return [($width+($ltw*$margin)+1), [(@arry)]];
}

sub assemble 
{
  my( $tracks ) = @_;
  my $sequences = [ ];
  
  my $tidx = 0;
  
  foreach my $t(@$tracks)
  {
    while($#$t < 25)
    {
      push @$t, [2,1,'white'];
    }

    my $sequence = [];

    my $h = 0;
    my $l = 0;
    my $width = 8;
    my @labels;
    my %labels;
    
    if($#$tracks > 0)
    {
      if($tidx == 0)
      {
        foreach my $t(0..$#$tracks)
        {
          push @labels, ('_track_'.$t);
		      $labels{'_track_'.$t} = $#labels;
        }
      }
      else
      {
        push @labels, ('_track_0');
        $labels{'_track_0'} = $#labels;
      }
    }    
    
    foreach my $c(@$t) 
    {
      if($c->[0] != 0)
      {
        (($c->[1]+1) > $width) and ($width = ($c->[1]+1));
      }

      if(($c->[0] == 3)||($c->[0] == 4))
      {
        my $lbl = $c->[2];
        my $back = 1;
        ($lbl =~ s/^([0-9]+)([BbFf])$/$1/) and ($back =(($2 eq 'B')||($2 eq 'b')));
		    if(!defined($labels{$lbl}))
		    {
			    push @labels, $lbl;
			    $labels{$lbl} = $#labels;
		    }
      }
    }
    
    # push @$sequence, _sequence_row(1, [colouridx($h,$l)], $width, $#labels+1);

    foreach my $c(@$t) 
    {
      if($c->[0] == 0) 
      {
        $DEBUG and print STDERR "$c->[3] $c->[1] $c->[2]  $h $l";
        ($h, $l) = _hlc($h, $l, $c->[3]);
        $DEBUG and print STDERR " --> $h $l\n";
        push @$sequence, _sequence_row(1, [colouridx($h,$l)], $width, $#labels+1);
      }
      elsif($c->[0] == 1)
      {
        push @$sequence, _sequence_row($c->[1], $c->[2], $width, $#labels+1);
      }
      elsif($c->[0] == 2)
      {
        my $cmd = $commands{$c->[2]};
        if($cmd->[0] == 0)
        {
          $DEBUG and print STDERR "$c->[2] $cmd->[1] $cmd->[2]  $h $l";
          ($h, $l) = _hlc($h, $l, $cmd->[3]);
          my $idx = colouridx($h,$l);
          push @$sequence, _sequence_row($c->[1], [($idx) x $c->[1]], $width, $#labels+1);
        }
        else
        {
          $DEBUG and print STDERR "$c->[2] $h $l";
          push @$sequence, _sequence_row($c->[1], [($cmd->[1]->[0]) x $c->[1]], $width, $#labels+1);
        }
        $DEBUG and print STDERR " --> $h $l\n";
      }
      elsif($c->[0] == 3) # label
      {
	      my $label = $labels{$c->[2]};
	      defined($label) or die("Undefined label: $c->[2]\n");
	      my @arry = (18);
	      push @arry, (18,19,18) x ($#labels+1);
	      push @arry, ((18) x $width);
	      foreach my $i( ($label * $ltw + 1) .. $#arry )
	      {
	        $arry[$i] = (!(($i+1) % $ltw)&&($i<=($ltw*($#labels+1))))?colouridx($h,$l):19;
	      }

	      foreach my $i( ($label * $ltw + 1) .. (($label * $ltw)+ 3) )
	      {
	        $arry[$i] = colouridx($h,$l);
	      }

	      push @$sequence, [($width+($ltw*($#labels+1))+1), [(@arry)]];
      }
      elsif($c->[0] == 4) # branch
      {
        my $lbl = $c->[2];
        my $back = 1;
        ($lbl =~ s/^([0-9=]+)([BbFf])$/$1/) and ($back =(($2 eq 'B')||($2 eq 'b')));    
	      my $label = $labels{$lbl};
	      defined($label) or die("Undefined label: $lbl\n");
	      my $tw = ($width+($ltw*($#labels+1))+1);

	      my @arry = (18);
	      push @arry, (18,19,18) x ($#labels+1);
	      push @arry, ((18) x $width);

	      foreach my $i( (($ltw*$label)+2) .. $#arry )
	      {
	        $arry[$i] = (!(($i+1) % $ltw)&&($i<=($ltw*($#labels+1))))?colouridx($h,$l):19;
	      }

        ($h, $l) = _hlc($h, $l, 'ptr');
        foreach my $i(1..$c->[1])
        {
  		    $arry[$#arry-$i+1] = colouridx($h,$l);
	      }

	      if(defined($c->[3]))
	      {
          my ($bh, $bl) = _hlc($h, $l, $c->[3]);
		      $arry[$#arry-$c->[1]] = colouridx($bh,$bl);
  	    }

        if(!$back)
        {
          ($c->[1] < 3) or die("branch opcode width incompatible with forward reference\n");

		      $arry[$#arry-$c->[1]-2] = 0;
		      $arry[$#arry-$c->[1]-3] = 0;
		      $arry[$#arry-$c->[1]-4] = 0;
		      $arry[$#arry-$c->[1]-5] = colouridx(_hlc(0, 0, 'push'));

          $arry[(($ltw*$label)+3)] = 0;
          $arry[(($ltw*$label)+2)] = colouridx(_hlc(0, 0, 'ptr'));
        }

  	    push @$sequence, [$tw, [(@arry)]];
      }
      elsif($c->[0] == 5) # branch, supplied as precompiled colours
      {
        my $lbl = $c->[2];
        my $back = 1;
        ($lbl =~ s/^([0-9=]+)([BbFf])$/$1/) and ($back =(($2 eq 'B')||($2 eq 'b')));    

	      my $label = $labels{$lbl};
	      defined($label) or die("Undefined label: $lbl\n");
	      my $tw = ($width+($ltw*($#labels+1))+1);

	      my @arry = (18);
	      push @arry, (18,19,18) x ($#labels+1);
	      push @arry, ((18) x $width);

	      foreach my $i( (($ltw*$label)+2) .. $#arry )
	      {
	        $arry[$i] = (!(($i+1) % $ltw)&&($i<=($ltw*($#labels+1))))?colouridx($h,$l):19;
	      }

        foreach my $i(1..$c->[1])
        {
  		    $arry[$#arry-$i+1] = $c->[3]->[$i-1];
	      }

        if(!$back)
        {
          ($c->[1] < ($modulus-6)) or die("branch opcode width incompatible with forward reference\n");

		      $arry[$#arry-$c->[1]-($modulus-5)] = 0;
		      $arry[$#arry-$c->[1]-($modulus-4)] = 0;
		      $arry[$#arry-$c->[1]-($modulus-3)] = 0;
		      $arry[$#arry-$c->[1]-($modulus-2)] = colouridx(_hlc(0, 0, 'push'));

          $arry[(($ltw*$label)+3)] = 0;
          $arry[(($ltw*$label)+2)] = colouridx(_hlc(0, 0, 'ptr'));
        }

  	    push @$sequence, [$tw, [(@arry)]];            
      }
    }

    $sequence = [($width+($ltw*($#labels+1))+1), $sequence]; 
    print STDERR "Track $tidx: $#{$sequence->[1]} x $sequence->[0] pels.\n";
    push @$sequences, $sequence;
    $tidx++;
  }
  
  seqlink($sequences);
  
  return $sequences;
}

sub seqlink
{
  my( $sequences ) = @_;
  
  ($#$sequences > 0) or return;
  
  my $sidx = 0;
  my $x = 0;
  my $root = $sequences->[0]->[1];
  my $tw = 0;

  {
    foreach my $sequence(@$sequences)
    {
      ($sidx++) or next;
      $tw += $sequence->[0];
    }
    my $w = $sequences->[0]->[0];
    while($#$root < $tw)
    {
      push @$root, [$w, [(18,18,19) x ($#$sequences+1), (18) x ($w-(($#$sequences+1)*3))]];
    }
  }

  $x = 0;
  $sidx = 0;

  foreach my $sequence(@$sequences)
  {
    ($sidx++) or next;
    my $height = $sequence->[0];

    while( 
            ( $root->[$x+$height-2]->[1]->[$sidx*3-1] < 18 )
          ||( $root->[$x+$height-1]->[1]->[$sidx*3-1] < 18 )
          ||( $root->[$x+$height  ]->[1]->[$sidx*3-1] < 18 )
          ||( $root->[$x+1]->[1]->[2] < 18 )
          ||( $root->[$x+2]->[1]->[2] < 18 )
          ||( $root->[$x+3]->[1]->[2] < 18 )
    )
    {
      $DEBUG and print STDERR "$sidx: $x $height " . $root->[$x+$height-1]->[1]->[$sidx*3-0] . "\n";
      # collision with something on track 0
      $tw++;
      $x++;
      while($#$root < $tw)
      {
        my $w = $sequences->[0]->[0];
        push @$root, [$w, [(18,18,19) x ($#$sequences+1), (18) x ($w-(($#$sequences+1)*3))]];
      }
      $sequence->[0]++;
      foreach my $item(@{$sequence->[1]})
      {
         ($item->[0])++;
         unshift @{$item->[1]}, 18;
      }
    }

    # link track exit to track 0 reentry line
    if($root->[$x+1]->[1]->[2] != 19)
    {
      $root->[$x+1]->[1]->[1] = 0;
      $root->[$x+1]->[1]->[2] = 0;
      $root->[$x+1]->[1]->[3] = 0;
      $root->[$x+2]->[1]->[0] = 19;
      $root->[$x+2]->[1]->[1] = 0;
      $root->[$x+2]->[1]->[2] = 0;
      $root->[$x+2]->[1]->[3] = 0;
    }
    elsif($root->[$x+3]->[1]->[2] != 19)
    {
      $root->[$x+2]->[1]->[0] = 19;
      $root->[$x+2]->[1]->[1] = 0;
      $root->[$x+2]->[1]->[2] = 0;
      $root->[$x+2]->[1]->[3] = 0;
      $root->[$x+3]->[1]->[1] = 0;
      $root->[$x+3]->[1]->[2] = 0;
      $root->[$x+3]->[1]->[3] = 0;
    }
    else
    {
      $root->[$x+2]->[1]->[0] = 19;
      $root->[$x+2]->[1]->[1] = 19;
      $root->[$x+2]->[1]->[2] = 0;
    }
    
    # link track entry to its exit line in track 0
    
    foreach my $i( 0 .. ($sidx-1) )
    {
      $root->[$x+$height-1]->[1]->[$i*3+0] = 19;
      $root->[$x+$height-1]->[1]->[$i*3+1] = 19;
      $root->[$x+$height-1]->[1]->[$i*3+2] = 0;
    }
    
    if( $root->[$x+$height-2]->[1]->[$sidx*3-1] != 19 )
    {
      $root->[$x+$height-2]->[1]->[$sidx*3-2] = 0;
      $root->[$x+$height-2]->[1]->[$sidx*3-1] = 0;
      $root->[$x+$height-2]->[1]->[$sidx*3] = 0;
    }
    $root->[$x+$height-1]->[1]->[$sidx*3-2] = 0;
    $root->[$x+$height-1]->[1]->[$sidx*3-1] = 0;
    $root->[$x+$height-1]->[1]->[$sidx*3] = 0;
    if( $root->[$x+$height]->[1]->[$sidx*3-1] != 19 )
    {
      $root->[$x+$height]->[1]->[$sidx*3-2] = 0;
      $root->[$x+$height]->[1]->[$sidx*3-1] = 0;
      $root->[$x+$height]->[1]->[$sidx*3] = 0;
    }
    
    $x += $height;
  }
}

sub makestrip
{
  my( $sequence ) = @_;
  my $height = $sequence->[0];
  my $width = ($#{$sequence->[1]})+1;  
  my $rows = [ ];
  my $black = chr(0) . chr(0) . chr(0);
  foreach my $pass(1..$width)
  {
    my $row = [ ];
    foreach my $c(@{$sequence->[1]})
    {
       if( $c->[0] < $pass )
       {
          push @$row, $black;
       }
       else
       {
          push @$row, $colours[$c->[1]->[$c->[0]-$pass]];
       }
    }
    push(@$rows, $row);
  }
  return [ $width, $height, $rows ];
}

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

  my @strips;
  foreach my $sequence( @$sequences )
  {
    my $strip = makestrip($sequence);
    push @strips, $strip;
  }
  
  my $root = shift @strips;

  my $width = 0;
  my $height = 0;  
  foreach my $strip( @strips )
  {
    $width += $strip->[1];
    ($height < $strip->[0]) and ($height = $strip->[0]);    
  }
  ($width < $root->[0]) and ($width = $root->[0]);
  $height += $root->[1];  

  # header  
  print STDERR "$width x $height = ". ($width*$height). " pels.\n";  
  my $out = "P6\n\n$width $height\n255\n";
  
  my $black = chr(0) . chr(0) . chr(0);
  
  # root
  foreach my $row(0..($root->[1]-1))
  {
    if(defined($root->[2]->[$row]))
    {
     $out = $out . join('', (@{$root->[2]->[$row]}, ($black) x ($width - $root->[0])));
    }
    else
    {
     $out = $out . (($black) x ($width));
    }
  }
  
  # other strips
  if($#strips > -1)
  {
   foreach my $row(0..($height-$root->[1]))
   {
    my $x = 0;
    foreach my $strip( @strips )
    {
      if( $strip->[0] > $row )
      {
       foreach my $cidx( 0..($strip->[1]-1) )
       {
        if(defined($strip->[2]->[($strip->[1]-1)-$cidx]->[$row]))
        {
          $out = $out . $strip->[2]->[($strip->[1]-1)-$cidx]->[$row];
        }
        else
        {
          $out = $out . chr(0) . chr(0) . chr(0);
        }
       }
      }
      else
      {
        $out = $out . join('', ($black) x $strip->[1]);
      }
      $x += $strip->[1];
    }
    $out = $out . join('', ($black) x ($width - $x));
   }
  }
  
  return $out;
}
            
sub gen_btbl
{
  my($track, $labels) = @_;
      foreach my $label(@$labels)
      {
        push @$track, [2, 1, 'dup'];
        push @$track, [2, 1, 'not'];
        push @$track, [4, 1, $label, 'pop'];
        push @$track, [2, 1, 'push'];
        push @$track, [2, 1, 'sub'];
      }
      push @$track, [2, 1, 'pop'];
}
            

sub main
{
  my $tracks = [];

  my $track = [];  
  push @$track, [2, 1, 'ext'];

  my $macro = '';
  
  for(<>)
  {
    chomp; chomp; my $line = $_;
    $lnbr++;
  
    $line =~ s/[#].*$//;
    $line =~ s/^\s+//;
    $line =~ s/\s+$//;    
    
    if($line =~ /^\.track$/i)
    {
      (length $macro) and die ".track inside macro definition\n";
      push @$tracks, $track;
      $track = [];  
      push @$track, [2, 1, 'ext'];
      next;
    }
    
    if($line =~ s/^macro//i)
    {
      (length $macro) and die "Nested macros not allowed in line $lnbr\n";
      
      $line =~ s/^\s+//;
      if($line =~ s/([A-Za-z0-9_]+) def$//i)
      {
        $macros{$1} = $line;
        $macro='';
        next;
      }
      $macro = $line . ' ';   
    }
        
    if($line =~ s/([A-Za-z0-9_]+) def$//i)
    {
      $macros{$1} = $macro . ' ' . $line;
      $macro = '';
      next;
    }
    
    if(length $macro)
    {
      $macro = $macro . ' ' . $line;
      next;
    }
    
    
    parsecmd($line, $track);
  }
  
  push @$tracks, $track;
  my $sequences = assemble($tracks);  
  print layout($sequences);
}

main();