#!/usr/bin/perl -w
#
# usage:
#   slopecalc =HEIGHT|SLOPE%|+DIST|@ABSDIST ...
#     ... | atp -B >ps
#
# args represent details of control points
#
# an arg starts a new control point if it specifies
#  a property (height, slope or location) which has
#  already been determined for the current control
#  point.
#
# when a new point is started all the properties of the previous
#  point must be determinable - although unless otherwise specified
#  the slope will remain unchanged from the point before, and if
#  the slope _has_ changed a default distance is supplied
#
# the first use of @... to specify an absolute location
#  acts only to fix the zero point of the absolute position scale;
#  the (relative to start) location of the current point must already be known

use strict qw(vars refs);

our $halfreverselen= 80; # mm to change from going flat to going up/down
our $printinterval= 10;
our $totallinesout= 139;

our @cp= ({ L => 0 });
# $cp[]{H}    height
# $cp[]{L}    absolute dist
# $cp[]{S}    slope
our $absoffset;

our $numre= '(?:\\d{1,6}(?:\\.\\d*)?|\\.\\d+)';

our $progname= $0;
$progname =~ s,.*/,,;
our $arg_errors= 0;
our $lines++;

sub arg_error ($) {
    my ($m) = @_;
    print STDERR "$progname: $m\n";
    $arg_errors++;
}

sub lprintf {
    printf @_ or die $!;
    print "\n" or die $!;
    $lines++;
}

# always called in this order:         $this->{S}   $this->{L}   $this->{H}
#  compute_fixed_S($last,$this)        undef         -            -
#  compute_fixed_L($last,$this)         -           undef         -
#  compute_fixed_H($last,$this)         -            -           undef
#  compute_default_S($last,$this)      undef         -            -
#  compute_default_L($last,$this)      defined      undef         -
#  compute_default_H($last,$this)      defined      defined      undef
# $last->{S}, $last->{H}, $last->{L} are always defined on entry

sub compute_fixed_S ($$) { }
sub compute_default_S ($$) {
    my ($last,$this) = @_;
    $this->{S}= $last->{S};
}
sub compute_fixed_L ($$) {
    my ($last,$this) = @_;
    if (defined $this->{S}
	and defined $this->{H}
	and $last->{S} == $this->{S}) {
	$this->{L}= $last->{L} + ($this->{H} - $last->{H})/$last->{S};
	return;
    }
}
sub compute_default_L ($$) {
    my ($last,$this) = @_;
    if (defined $this->{S}
	and !defined $this->{H}
	and $last->{S} != $this->{S}) {
	$this->{L}= $last->{L} +
	    $halfreverselen * ($last->{S} * $this->{S} < 0 ? 2 : 1);
	return;
    }
}
sub compute_fixed_H ($$) {
    my ($last,$this) = @_;
    if (defined $this->{S}
	and defined $this->{L}) {
	my $meanslope= 0.5 * ($last->{S} + $this->{S});
	$this->{H}= $last->{H} + $meanslope * ($this->{L} - $last->{L});
	return;
    }
}
sub compute_default_H ($$) { }

sub complete_current_point ($) {
    my ($why) = @_;
    my $say_why= 0;

    my $this= $cp[$#cp];
    my $last= @cp > 1 ? $cp[$#cp-1] : undef;
    foreach my $k2 (qw(S L H)) {
	if (defined $last) {
	    no strict 'refs';
	    defined $this->{$k2} or &{"compute_fixed_$k2"}($last, $this);
	    defined $this->{$k2} or &{"compute_default_$k2"}($last, $this);
	}
	if (!defined $this->{$k2}) {
	    arg_error("point \#$#cp: property $k2 unspecified");
	    $this->{$k2}= 1;
	    $say_why= 1;
	}
    }
    if ($say_why) {
	print STDERR "$progname: ($why)\n"
	    or die $!;
    }
}

sub arg_item ($$) {
    my ($k, $v) = @_;
    my $last = $cp[$#cp];

    if (!defined $last->{$k}) {
	$last->{$k}= $v;
	return;
    }
    complete_current_point("new point started because of change to $k");
    my $this = { $k => $v };
    foreach my $k2 (qw(S L H)) {
	no strict 'refs';
	defined $this->{$k2} or &{"compute_fixed_$k"}($last, $this);
    }
    push @cp, $this;
}

#use Data::Dumper;

sub parse_args () {
    foreach $_ (@ARGV) {
#print STDERR ">$_<\n", Dumper(\@cp);
	if (m/^\=([-+]?$numre)$/o) {
	    arg_item(H, $1);
	} elsif (m/^([-+]?$numre)\%$/o) {
	    arg_item(S, $1 * 0.01);
	} elsif (m/^([-+]?1)\:($numre)$/o) {
	    arg_item(S, $1 / $2);
	} elsif (m/^\@([-+]?$numre)$/o) {
	    if (defined $absoffset) {
               arg_item(L, $1 + $absoffset);
           } else {
	       if (!@cp) {
		   $absoffset= -$1;
	       } elsif (defined $cp[$#cp]{L}) {
		   $absoffset= $cp[$#cp]{L} - $1;
	       } else {
		   arg_error("point \#$#cp location still unknown at \`$_'");
	       }
           }
	} elsif (m/^\+($numre)$/o) {
	    complete_current_point("new point started because of +...");
	    arg_item(L, $cp[$#cp]{L} + $1);
	} else {
	    arg_error("bad argument `$_'");
	}
	push @{ $cp[$#cp]{Args} }, $_;
    }
    complete_current_point("completing as it is the final point");
    die "$progname: errors in argument(s)\n" if $arg_errors;
}

sub lprint_interp ($$$$) {
    my ($l_more,$l,$y,$cc) = @_;
    lprintf("   %4s        %7d  %8.2f  %s",
	    "+$l_more", $l - $absoffset, $y, $cc);
}

sub dump_schedule ($) {
    my ($interpolate) = @_;
    $absoffset=0 unless defined $absoffset;
    my $i;
    my $last_l= 0;
    my $last_h;
    my $last;
    for ($i=0; $i<@cp; $i++) {
	my $this= $cp[$i];
	lprintf("%4s  %7s  %7s   =%6.2f  %s %5.02f%%   %s   %s",
		"#$i",
		'+'.($this->{L} - $last_l),
		'@'.($this->{L} - $absoffset),
		$this->{H},
		($this->{S} < 0 ? '/' :
		 $this->{S} > 0 ? '\\' :
		 '|'),
		$this->{S} * 100,
		(defined $last_h ?
		 sprintf "=%+6.2f", $this->{H} - $last_h :
		 '       '),
		"@{ $this->{Args} }");
	my $next= $cp[$i+1];
	if ($interpolate and defined $next) {
	    my $more_l= 0;
	    my $dist_l = $next->{L} - $this->{L};
	    if ($dist_l > 0) {
		my $base_hdiff = $next->{H} - $this->{H};
		my $base_slope = $base_hdiff / $dist_l;
		my $next_hoop = -($next->{S} * $dist_l - $base_hdiff);
		my $this_hoop =   $this->{S} * $dist_l - $base_hdiff;
		my $char_char =
		    ($next->{S} < $this->{S} ? '>' :
		     $next->{S} > $this->{S} ? '<' :
		     $next->{H} < $this->{H} ? '/' :
		     $next->{H} > $this->{H} ? '\\' :
		     '|');
		for (;;) {
		    $more_l += $printinterval;
		    my $gamma= $more_l / $dist_l;
		    my $l = $this->{L} + $more_l;
		    last unless $l < $next->{L};
		    my $zeta= 1 - $gamma;
		    my $y = $this->{H} + $gamma * $base_hdiff;
		    my $hoop= $gamma * $zeta;
		    $y += $hoop * ($gamma * $next_hoop +
				   $zeta * $this_hoop);
		    lprint_interp($more_l,$l,$y,$char_char);
		}
	    }
	}
        $last_l= $this->{L};
        $last_h= $this->{H};
	$last= $this;
    }
    if ($interpolate) {
	my $more_l= 0;
	while ($lines+2 < $totallinesout) {
	    lprint_interp($more_l,
			  $last->{L} + $more_l,
			  $last->{H} + $last->{S} * $more_l,
			  ':');
	    $more_l += $printinterval;
	}
    }
}
parse_args();

sub dump_args () {
    my @out;
    my $lmax= 78;
    my $xpos= -1;

    lprintf("args:");
    lprintf("");

    my $writeout= sub {
	foreach my $oi (0..2) {
	    lprintf(" %s",
		    join(($oi==1 ? '|' : ' '),
			 @{ $out[$oi] }));
	}
    };
    my $push= sub {
	$xpos += 1 + length($_[0]);
	if ($xpos >= $lmax) {
	    foreach my $oi (0..2) {
		push @{ $out[$oi] },
		    ($oi==1 && $_[$oi] =~ m/^\-/ ? '-' : '');
	    }
	    $writeout->();
	    lprintf('');
	    @out= ();
	    $xpos= length($_[0]);
	}
	foreach my $oi (0..2) {
	    push @{ $out[$oi] }, $_[$oi];
	}
    };

    foreach (my $i=0; $i<@cp; $i++) {
	my $cp= $cp[$i];
	my @iargs= @{ $cp->{Args} };

	if (@iargs && $iargs[0] =~ m/^\+$numre$/) {
	    my $relmove= shift @iargs;
	    $push->($relmove,
		    '-'x length $relmove,
		    ' 'x length $relmove);
	} elsif ($i) {
	    $push->(' ',
		    '-',
		    ' ');
	}

	my $ipoint= "#$i";
	my $lipoint= length $ipoint;
	my $iargs= "@iargs";
	my $lip= $lipoint;
	my $l= $lipoint > length($iargs) ? $lipoint : length($iargs);

	my $pad= int(($l-$lipoint)/2);

	$push->((sprintf "%-*s", $l, $iargs),
		' 'x $l,
		(' 'x $pad). $ipoint. (' ' x ($l-$lipoint-$pad)));
    }
    $writeout->();
}

dump_args();
lprintf("");

lprintf("control points:");
dump_schedule(0);
lprintf("");
lprintf("table of heights:");
dump_schedule(1);

my $dir= $0; $dir =~ s,/.*?$,,;
my $gitid= `$dir/../.git-revid`; $? and die $?; chomp $gitid;

lprintf("");
lprintf("%s",
       "\$Id: $gitid \$"
    );