#!/usr/bin/perl -w
#
# Panelises PCB layouts
#
# Usage:
#       pcb-panelise [options] layout1.pcb layout2.pcb ...
#
# Options:
#      -gTHOU   set inter-board gap to THOU
#               (should occur _before_ the board which _precedes_ the
#               gap, and then affects all later gaps)
#
# Layouts are currently simply placed parallel from top to bottom.
# Making it put them somewhere else wouldn't be _too_ hard; basically,
# make an option for the user to specify xpos and ypos between layouts.
#
# Rotation will be slightly more difficult and will involve a careful
# review of Stuff, to see where additional transformations etc. are needed.
# It might be eaiser to use pcb to rotate the boards.
#
# We use a trick to make net and element names unique: we append
# spaces to the names in the 2nd and subsequent boards.  This seems to
# work fine in pcb snapshot 1.99.20040530-0.0.1 but means that
#   - you mustn't feed this program's output to itself!
#   - you probably don't want to edit the output (but you didn't
#     edit output files anyway, did you?)
#
# On the other hand, pcb's builtin netlist correspondence checker and
# DRC system ought to work properly.

use strict qw(vars);

use IO::File;

our ($line,$indent,$command,$lbrack,$rbrack);
our (@a, $output_file, $accumulate);

our ($xpos,$ypos,$spaces,@titles);
our ($xmax,$ymax,$gap);
our ($cutlinewidth,$idstring_size);

sub init () {
    $xpos=$ypos=0;
    $xmax=0,$ymax=0;

    # 100s of thou like in PCB
    $gap=20000;
    $cutlinewidth=800;
    $idstring_size=100;

    $spaces= '';
    $output_file= '';
    @titles= ();
}

sub process () {
    my ($filename,$fn,$f,$argstring,@stack);
    my ($q,$z);
    @stack= ();
    foreach $filename (@ARGV) {
	if ($filename =~ m/^\-g(\d+)$/) {
	    $gap= $1 * 100;
	    next;
	} elsif ($filename =~ m/^\-/) {
	    die "$filename ?";
	}
	$f = new IO::File $filename, 'r' or die $filename;
	&beginfile__;
	while (<$f>) {
	    next if m/^\#/;
	    next unless m/\S/;
	    $line= $_;
	    if (m/^(\s*) ( [A-Z][A-Za-z]* ) \s* ([[(]) (.*) ([])]) \s* $/x) {
		($indent, $command, $lbrack, $argstring, $rbrack) =
		    ($1,$2,$3,$4,$5);
		die unless ($lbrack eq '[') == ($rbrack eq ']');
		foreach $q (qw(' ")) {
		    $argstring =~ s/ $q ([^$q]*) $q /
		        $z= $1; $z =~ s, ,\001,g; $q.$z.$q;
		    /gxe; #"')){
		}
		@a= split / /, $argstring;
#print STDERR "$argstring>".join("|",@a)."<\n";
		map {
		    die "$_ ?" unless
			m/^(?: \-? (?: 0 | [1-9]\d* ) (?: \. \d* )?
			    | 0x[0-9a-f]{8} | 0x[0-9a-f]{16} |
			    \" (?: \w | [-():,.] | \001 | \$ )* \" |
			    \'.\' )$/x;
		    s/\001/ /g;
		} @a;
		if (defined $accumulate) {
		    $accumulate .= $line;
		} else {
		    $fn= join '__', 'op',@stack,$command;
		    &$fn;
		}
	    } elsif (m/^ (?: \s+ \[ \-? \d+ \s+ \-? \d+ \] )+ \s* $/x) {
		$line= $_;
		$fn= join '__', 'polygondata',@stack;
		&$fn;
	    } elsif (m/^ \s* \( \s* $/x) {
		die unless defined $command;
		push @stack, $command;
		undef $command;
		$fn= join '__', 'begin',@stack;
		&$fn;
	    } elsif (m/^ \s* \) \s* $/x) {
		$fn= join '__', 'end',@stack;
		&$fn;
		die unless @stack;
		pop @stack;
		undef $command;
	    } else {
		die;
	    }
	}
	die if @stack;
	undef $command;
	&endfile__;
	die if defined $accumulate;
	$f->error and die "$filename $!";
	close $f;
    }
    &endall__;

    print $output_file or die $!;
}

sub transform ($;\@) {
    my ($ix,$ar) = @_;
    $ar= \@a unless defined $ar;
    defined $ar->[$ix] or die;
    defined $ar->[$ix+1] or die;
    $ar->[$ix] += $xpos;
    $ar->[$ix+1] += $ypos;
}
    
sub fromfirst () {
    return if length $spaces;
    copy();
}
sub copy () {
    die unless defined $command;
    $output_file .= $indent. $command. $lbrack. join(' ',@a). $rbrack. "\n";
}
sub copyline () {
    $output_file .= $line;
}

our (%identical_map);
sub identical (;$) {
    my ($key) = @_;
    if (!defined $key) { $key= $command; }
    if (!exists $identical_map{$key}) {
	$identical_map{$key}= $line;
	copy();
    } else {
	die unless $identical_map{$key} eq $line;
    }
}

our ($define_identical_key, %define_identical_map);
sub define_identical_do () { $define_identical_key= $line; }
sub define_identical_begin () { $accumulate=''; }
sub define_identical_end () {
    if (exists $define_identical_map{$define_identical_key}) {
	die unless $define_identical_map{$define_identical_key} eq
	    $accumulate;
    } else {
	$define_identical_map{$define_identical_key}= $accumulate;
	$output_file .= $define_identical_key."(\n".$accumulate.")\n";
    }
    undef $accumulate;
}

our (@thisextent, @last_horizline);
our ($netlist_aside,$netlist_data);
our ($layer,$layer_aside,%layer_name,%layer_data);

sub horizline {
    my ($xlhs,$xrhs,$y) = @_;
    $layer_data{10} .= "\tLine[".
	"$xlhs $y $xrhs $y $cutlinewidth 0 0x00000020".
	    "]\n";
}

sub beginfile__ {
    @thisextent= ();
    if (@last_horizline) { horizline(@last_horizline); }
}
sub op__PCB {
    $a[0] =~ m/^"(.+)"$/ or die;
    push @titles, $1;
    die if @thisextent;
    @thisextent= @a[1..2];
    transform(0,@thisextent);
    $xmax= $xpos + $thisextent[0] if $xpos + $thisextent[0] > $xmax;
    $ymax=         $thisextent[1] if         $thisextent[1] > $ymax;
    if (length $spaces) { horizline($xpos,$thisextent[0],$ypos); }
}
sub endfile__ {
    if (@ARGV) {
	@last_horizline= ($xpos,$thisextent[0],$thisextent[1]);
	if ($idstring_size && !length $spaces) {
	    $layer_data{10} .= sprintf
		("\tText[%d %d %d %d \"%s\" 0x%08lx]",
		 $xpos+$gap, $thisextent[1] + $idstring_size * 10,
		 0, $idstring_size, 'assembled by '.
		 '$Id$',
                 0); #');
	}
    }
    $ypos= $thisextent[1] + $gap;
    $spaces .= ' ';
}

sub op__Grid { fromfirst(); }
sub op__Cursor { fromfirst(); }
sub op__Thermal { identical(); }
sub op__DRC { identical(); }
sub op__Flags { identical(); }
sub op__Groups { identical(); }
sub op__Styles { fromfirst(); }

sub op__Symbol { define_identical_do(); }
sub begin__Symbol { define_identical_begin(); }
sub end__Symbol { define_identical_end(); }

sub op__Via { transform(0); copy(); }
sub op__Element {
    $a[2] =~ s/^\"(.*)\"/\"$1$spaces\"/ or die;
    transform(4);
    copy();
}
sub begin__Element { copyline(); }
sub end__Element { copyline(); }
sub op__Element__Pin { copy(); }
sub op__Element__ElementLine { copy(); }
sub op__Element__ElementArc { copy(); }

sub op__Layer {
    if (exists $layer_name{$a[0]}) {
	die unless $layer_name{$a[0]} eq $a[1];
    } else {
	$layer_name{$a[0]}= $a[1];
    }
    $layer= $a[0];
}
sub begin_aside (\$) {
    my ($asideref) = @_;
    $$asideref= $output_file;
    $output_file= '';
}
sub end_aside (\$) {
    my ($asideref) = @_;
    $output_file= $$asideref;
    undef $$asideref;
}
sub begin__Layer {
    begin_aside($layer_aside);
}
sub op__Layer__Line {
    transform(0);
    transform(2);
    copy();
}
sub op__Layer__Text {
    transform(0);
    copy();
}
sub op__Layer__Arc {
    transform(0);
    copy();
}
sub op__Layer__Polygon {
    copy();
}
sub begin__Layer__Polygon { copyline(); }
sub polygondata__Layer__Polygon {
    my (@polypoint);
    $line =~ s/ \[ (\-?\d+) \ (\-?\d+) \] /
	@polypoint= ($1,$2);
        transform(0,@polypoint);
        "[@polypoint]";
	/egx;
    $output_file .= $line;
}
sub end__Layer__Polygon { copyline(); }
sub end__Layer {
    $layer_data{$layer} .= $output_file;
    end_aside($layer_aside);
}

sub op__NetList {
    die if @a;
}
sub begin__NetList {
    begin_aside($netlist_aside);
}
sub op__NetList__Net {
    $a[0] =~ s/^\"(.*)\"$/\"$1$spaces\"/ or die;
    copy();
}
sub begin__NetList__Net { copyline(); }
sub op__NetList__Net__Connect {
    $a[0] =~ s/^\"([^-]+)\-(\d+)\"$/\"$1$spaces-$2\"/ or die;
    copy();
}
sub end__NetList__Net { copyline(); }
sub end__NetList {
    $netlist_data .= $output_file;
    end_aside($netlist_aside);
}

sub endall__ {
    $output_file= ('# made by pcb-panelise $Id$'."\n".
		   "PCB[\"".join('+',@titles).".pcb\" $xmax $ymax]\n".
		   $output_file);
    foreach $layer (sort keys %layer_data) {
	$output_file .= "Layer($layer $layer_name{$layer})\n";
	$output_file .= "(\n";
	$output_file .= $layer_data{$layer};
	$output_file .= ")\n";
    }
    $output_file .= "NetList()\n";
    $output_file .= "(\n";
    $output_file .= $netlist_data;
    $output_file .= ")\n";
}

die unless @ARGV;
init();
process();