--- /dev/null
+#!/usr/bin/perl -w
+#
+# usage:
+# slopecalc =HEIGHT|SLOPE%|+DIST|@ABSDIST ...
+#
+# 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
+# and does not actually specify the location of the current point
+
+use strict qw(vars refs);
+
+our $halfreverselen= 80; # mm to change from going flat to going up/down
+our $printinterval= 10;
+
+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;
+
+sub arg_error ($) {
+ my ($m) = @_;
+ print STDERR "$progname: $m\n";
+ $arg_errors++;
+}
+
+# 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[$#cp-1];
+ foreach my $k2 (qw(S L H)) {
+ if (defined $last) {
+ no strict 'refs';
+ exists $this->{$k2} or &{"compute_fixed_$k2"}($last, $this);
+ exists $this->{$k2} or &{"compute_default_$k2"}($last, $this);
+ }
+ if (!exists $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 (!exists $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';
+ exists $this->{$k2} or &{"compute_fixed_$k"}($last, $this);
+ }
+ push @cp, $this;
+}
+
+sub parse_args () {
+ foreach $_ (@ARGV) {
+ if (m/^\=([-+]?$numre)$/o) {
+ arg_item(H, $1);
+ } elsif (m/^([-+]?$numre)\%$/o) {
+ arg_item(S, $1 * 0.01);
+ } elsif (m/^\@([-+]?$numre)$/o) {
+ if (defined $absoffset) {
+ arg_item(L, $1 + $absoffset);
+ } else {
+ $absoffset= -$1;
+ }
+ } elsif (m/^\+($numre)$/o) {
+ complete_current_point("new point started because of +...");
+ arg_item(L, $cp[$#cp]{L} + $1);
+ } else {
+ arg_error("bad argument `$_'");
+ }
+ }
+ complete_current_point("completing as it is the final point");
+ die "$progname: errors in argument(s)\n" if $arg_errors;
+}
+
+sub dump_schedule ($) {
+ my ($interpolate) = @_;
+ $absoffset=0 unless defined $absoffset;
+ my $i;
+ my $last_l= 0;
+ my $last;
+ for ($i=0; $i<@cp; $i++) {
+ my $this= $cp[$i];
+ if ($interpolate and defined $last) {
+ my $l= $last->{L};
+ my $dist_l = $this->{L} - $last->{L};
+ if ($dist_l > 0) {
+ my $base_hdiff = $this->{H} - $last->{H};
+ my $base_slope = $base_hdiff / $dist_l;
+ my $this_hoop = -($this->{S} * $dist_l - $base_hdiff);
+ my $last_hoop = $last->{S} * $dist_l - $base_hdiff;
+#printf "$dist_l $base_slope $this_hoop $last_hoop\n";
+ while ($l < $this->{L}) {
+ my $gamma= ($l - $last->{L}) / $dist_l;
+ my $zeta= 1 - $gamma;
+ my $y = $last->{H} + $gamma * $base_hdiff;
+ my $hoop= $gamma * $zeta;
+ $y += $hoop * ($gamma * $this_hoop +
+ $zeta * $last_hoop);
+ printf(" %7d %7.2f\n",
+ $l, $y)
+ or die $!;
+ $l += $printinterval;
+ }
+ }
+ }
+ printf("%4s %7s %7s =%5.2f %5.02f%%\n",
+ "#$i",
+ '+'.($this->{L} - $last_l),
+ '@'.($this->{L} - $absoffset),
+ $this->{H},
+ $this->{S} * 100)
+ or die $!;
+ $last_l= $this->{L};
+ $last= $this;
+ }
+}
+parse_args();
+
+printf("%s\n\n", "@ARGV")
+ or die $!;
+
+dump_schedule(0);
+print "\n" or die $!;
+dump_schedule(1);
+
+printf("\n%s\n",
+ '$Id$'
+ ) or die $!;
~ijackson / trains.git / blobdiff