# -*- perl -*-
# Cell.pm $Id: Cell.pm,v 1.12.2.3 2000/01/30 13:56:23 jens Exp $
# (C) Copyright Jens G Jensen <jens@argaeus.ma.rhul.ac.uk>
# This file is part of epsmerge and is distributed under GNU GPL

# This file contains a skeleton Cell hierarchy and two derived
# hierarchies: one actually used for the EPS-files; it will handle
# formatting and printing files to stdout (which will probably be
# redirected anyway).  The other is the FakeCell hierarchy which handles
# basically the same geometry, but inside the canvas on the formatter
# dialog when using the Tk interface.  Both hierarchies are constructed
# using the MainCell (note: the latter has been moved).


package Cell;

use strict;


# Constructor parameters should be:
# 1: filename, 2: creation date (string), 3: title,
# 4: width (in points), 5: height (in points)
sub new {
    my $class = shift;
    my $self = { 'f' => $_[0], 'd' => $_[1], 'T' => $_[2], dim => [ $_[3], $_[4] ] };
    return bless $self, $class;
}

sub write_setup {
    my $self = shift;
    if(defined $self->{cont}) {
	return $self->{cont}->write_setup();
    }
    return;
}

sub write {
  return "Internal error: Cell::write: you should overload this method\n";
}

# This stuff because I might want to separate the format() method from the
# write() method one day.
# sub format {
#   return "Internal error: Cell::format: you should overload this method\n";
# }

# Return width and height of the Cell's boundingbox
sub dim {
    my $self = shift;
    return unless defined $self->{dim};
    return wantarray ? @{$self->{'dim'}} : $self->{'dim'}; # hack alert!
}

# Return the aspect ratio of the Cell
sub asprat {
    no integer;
    my $self = shift;
    my ($w, $h) = $self->dim();
    return $h / $w;
}

# Given a new boundingbox calculate scaling parameters allowing us
# to fit into the new box.
sub getscale {
    my $self = shift;
    my @newbox = @_;
    my @dim = $self->dim();
    my ($xsc, $ysc);
    no integer;
    $xsc = ($newbox[2] - $newbox[0]) / $dim[0];
    $ysc = ($newbox[3] - $newbox[1]) / $dim[1];
    return ($xsc, $ysc);
}

# getlabel should return a label string as follows:
# T: title (must be upper case, since 't' means place-on-top)
# d: creation date
# f: filename
# F: filename, extension (if any) stripped
# i: prompt user for a string
# s: run a perl script to get a label string, script (currently) passed as the next parameter
sub getlabel {
    my $self = shift;
    my $opt = Options->new();
    my $io = $opt->getopts('-io-');
    $_ = shift;
    if( /[fdT]/ ) {
	return $self->{$_};
    }
    elsif( /F/ ) {
	my $fname = $self->{f};
	$fname =~ s/\.\w*$//;
	return $fname;
    }
    elsif( /i/ ) {
	if( -t STDIN && -t STDOUT ) {
	    printf STDOUT "Enter a one line label for %s: ", $self->{f};
	    my $line = <STDIN>;
	    chomp $line;
	    return $line;
	}
	print STDERR "epsmerge: Can't read labels interactively\n";
    }
    elsif( /s/ ) {
	my ($script, $n, $l) = @_;		  # get the script and the extra vars
	# make some vars available to the script:
	my $f = $self->{f};
	my $line;
	my @warnings;
	{
	  local $SIG{__WARN__} = sub { push @warnings, $_[0] };
	  if( $opt->getopts( '-Allow-Scripts-' ) ) {
	      $line = eval $script;
	  }
	  else {
	      $warnings[0] = "Scripts not allowed";
	  }
	}
	unless( defined $line ) {
	    printf STDERR "Error%s in script `%s':\n", @warnings > 1 ? "s" : "", $script;
	    foreach ( @warnings ) {
	      print STDERR "----> $_";
	    }
	    print STDERR "====> $@" if $@;
	    $line = "";
	  }
	chomp $line;
	return $line;
    }
    else {
	print STDERR "Warning: Unknown label option $_\n";
    }
    return "";
}

# Utility function for writing %%Resource DSC.
# Input (by example):
#	1. "%%DocumentSuppliedResources:"
#	2. { font => [ "Times-Foo", "Times-Bar" ],
#		procset => [ "tex-biz", "tex-boz" ] }
sub write_dsc_line {
    my ($type, $what) = ($_[1], $_[2]);			# 0 is self
    return unless %$what;				# ref empty
    print $type, " ";
    my $len = 1+length $type;
    my $key; my $firstline = 1;
    foreach $key (keys %$what) {
	if( $firstline ) {
	    print $key; $len += length $key;
	    $firstline = 0;
	}
	else {
	    # resource entries of different type should appear on new line
	    print "\n%%+ $key"; $len = 4 + length $key;
	}
	foreach ( @{$what->{$key}} ) {
	    my $l = length;
	    if( $l + $len > 78 ) {			# wrap to next line
		print "\n%%+ $key"; $len = 4 + length $key;
		print " $_"; $len += 1 + length;
	    }
	    else {
		print " $_"; $len += 1 + $l;
	    }
	}
    }
    print "\n";
}


package EpsCell;

use vars ('@ISA');

@ISA = ('Cell');

use strict;
use Eps;


# Create a Cell by passing a reference to an EPS object
sub new {
    my $self = shift;
    my $eps = shift;
    die "Internal error creating EpsCell without Eps reference"
	unless ref( $eps ) =~ /Eps/;
    my @bbox = $eps->box();
    my $data = Cell->new($eps->getlabel('f'), $eps->getlabel('d'), $eps->getlabel('T'));
    $data->{cont} = $eps;
    $data->{dim} = [ $bbox[2]-$bbox[0], $bbox[3]-$bbox[1] ];
    bless $data, $self;
}

sub write {
    my $self = shift;
    return $self->{cont}->write( @_, $self->getscale( @_ ) );
}

#sub labels {
#    my $self = shift;
#    return $self->{cont}->labels( shift );
#}


package LabelDecoratorCell;

use strict;

use vars qw(@ISA $Cell_Count $Last_Script);

$Cell_Count = 0;
$Last_Script = "";

@ISA = ('Cell');

# Input: cell reference, default fontsize, input data
# (note: LabelDecoratorCell doesn't know if it's generating headers or labels)
sub new {
    my $class = shift;
    my $cont = shift;
    my $opt = Options->new();
    my $data = Cell->new( $cont->getlabel('f'), $cont->getlabel('d'), $cont->getlabel('T'), $cont->dim() );
    $data->{cont} = $cont;
    $data->{font} = $opt->getopts('fn');
    $data->{size} = shift;
    $data->{'pos'} = shift;
    if( $data->{'pos'} =~ /(\d+)$/ ) {
	$data->{size} = $1;
    }
    if( $data->{'pos'} =~ /s/ ) { # script required
	if( $opt->getopts('script') ne '' ) {
	    $data->{script} = $opt->getopts('script');
	}
	else {
	    print STDOUT "Label generating script required for ", $cont->getlabel('f'), $Last_Script ? "; default is $Last_Script: " : ": " ;
	    my $line = <STDIN>;
	    chomp( $line );
	    if( $line ) {
		$Last_Script = $data->{script} = $line;
	    }
	    else {
		$data->{script} = $Last_Script;
	    }
	}
    }
    $data->{num} = $Cell_Count++;
    my @dim = $data->{cont}->dim();
    $data->{dim} = [ $dim[0], $dim[1]+$data->{size} ]
	if @dim;
    return bless $data, $class;
}

sub write {
    my $self = shift;
    my @bbox = @_;
    my @lbox = @_;
    my $width = $bbox[2]-$bbox[0];
    $self->{text} = $self->_getlabels( $self->{'pos'} );
    my $height = @{$self->{text}} * $self->{size};
    if( $self->{'pos'} =~ /^[at]/ ) {
	$bbox[3] -= $height;
	$lbox[1] = $bbox[3];
    }
    else {
	$bbox[1] += $height;
	$lbox[3] = $bbox[1];
    }
    $self->_writelabels( @lbox );
    return $self->{cont}->write( @bbox );
}

sub _getlabels {
    my ($self, $todo) = @_;
    $todo =~ s/^[atb]//;	# remove top/bottom specifier if present
    $todo =~ s/\d+$//;				  # remove trailing digits
    my @todo = split //, $todo;			  # explode string into characters
    @todo = qw(F d) unless @todo;		  # some default values
    my @message = ();
    my $linenum = 0;
    foreach (@todo) {
	if( /^s$/ ) {				  # scripting?
	    push @message, $self->getlabel($_, $self->{script}, $self->{num}, $linenum++);
	}
	else {
	    push @message, $self->getlabel($_);
	}
    }
    return \@message;
}

sub _writelabels {
    my $self = shift;
    my @bbox = @_;
    $bbox[2] -= $bbox[0]; $bbox[3] -= $bbox[1];
    print <<SETUP;
gsave /$self->{font} findfont $self->{size} scalefont setfont
$bbox[0] $bbox[1] translate newpath
0 0 moveto $bbox[2] 0 rlineto 0 $bbox[3] rlineto
-$bbox[2] 0 rlineto closepath clip
SETUP
    # the baseline is assumed to be at 1/4 of the font's height;
    # this should work OK for most text fonts
    no integer;
    my $ypos = $bbox[3] - $self->{size} * 3 / 4;
    foreach( @{$self->{text}} ) {
	# Maybe escape unescaped parens in $_?
	print "(", $_, ") ";
	# Maybe this should be coded as a PS-function, but where?
	print <<CENTER;
dup stringwidth pop neg $bbox[2] add 2 div
dup 0 le { pop 0 } if $ypos moveto show
CENTER
        $ypos -= $self->{size};
    }
    print "grestore\n";
}

sub newpage {
    $Cell_Count = 0;
}

package CompositeCell;

use Options;
use vars ('@ISA');

@ISA = ('Cell');

use strict;

# Parameters: cell ref list, formatter ref
sub new {
    my $class = shift;
    my $opt = Options->new();
    my $fname = $opt->getopts('o');
    # strictly speaking, a compositecell might calculate its dimensions
    # from its contents, but it's not really used now so we just take the
    # page dimensions for now.
    my $data = Cell->new( $fname, scalar localtime(), $fname,
			  @{$opt->getopts('p')} );
    $data->{form} = pop;	# get the formatter reference
    $data->{cont} = [ @_ ];	# contents: cell references
    bless $data, $class;
    return $data;
}

sub write_setup {
    my $self = shift;
    my $bob;
    foreach $bob ( @{$self->{cont}} ) {
	# TODO: handle errors returned by write_setup
	$bob->write_setup();
    }
}

sub write {
    my $self = shift;
    my @bbox = @_;
    my $opt = Options->new();
    my $r = $self->{'form'}->format( $self, @bbox );
    # returns BB or error msg or nothing
    if( ref $r ) {
	$self->{'dim'} = [ $r->[2] - $r->[0], $r->[3] - $r->[1] ];
	return;
    }
    return $r;
}

# Data access functions, used by Formatter
# It returns a reference to a list of references to cells.
sub cells {
    my $self = shift;
    return $self->{cont};
}

1;