#!/usr/bin/perl -w
use POSIX;
+use strict;
+no strict 'subs';
+
+our $ptscale= 72/25.4 / 7.0;
+
+our $psu_ulen= 4.5;
+our $psu_edgelw= 0.5;
+our $psu_ticklw= 0.1;
+our $psu_ticksperu= 1;
+our $psu_ticklen= 5.0;
+our $psu_allwidth= 37.0/2;
+our $psu_gauge= 9;
+our $psu_sleeperlen= 17;
+our $psu_sleeperlw= 15;
+our $psu_raillw= 1.0;
+
+our $lmu_marklw= 4;
+our $lmu_marktpt= 11;
+our $lmu_txtboxtxty= $lmu_marktpt * 0.300;
+our $lmu_txtboxh= $lmu_marktpt * 1.100;
+our $lmu_txtboxpadx= $lmu_marktpt * 0.335;
+our $lmu_txtboxoff= $lmu_marklw / 2;
+our $lmu_txtboxlw= 1;
+
+our $pi= atan2(0,-1);
# Data structures:
# $ctx->{CmdLog}= undef } not in defobj
# $objs{$id}{CmdLog}
# $objs{$id}{Loc}
+our $ctx;
+our %objs;
+our @al; # current cmd
+
+our $o='';
+our $ol='';
+
+our $param; # for parametric_curve
+
+our $debug=0;
#$debug=1;
open DEBUG, ($debug ? ">&2" : ">/dev/null") or die $!;
}
sub ev_compose ($$$) {
# ev_compose(SUM_R, A,B);
- # appends B to A, result is end of B'
+ # appends B to A, result is end of new B
+ # (B's X is forwards from end of A, Y is translating left from end of A)
# A may have a member R, which if provided then it should be 1.0 or -1.0,
# and B's Y and A will be multiplied by R first (ie, we can reflect);
my ($sum,$a,$b) = @_;
map { $r->{$_} = $q * $a->{$_} + $p * $b->{$_} } qw(X Y A);
$r;
}
-sub v_bearing ($$) {
- # v_bearing(A,B)
- # returns bearing of B from A (in radians)
- # A->{A} and B->{A} are ignored
+sub ev_bearing ($$) {
+ # ev_bearing(A,B)
+ # returns bearing of B from A
+ # value returned is in [ A->{A}, A->{A} + 2*$pi >
+ # A->{A} and B->{A} are otherwise ignored
my ($a,$b)= @_;
- return atan2($b->{Y} - $a->{Y},
- $b->{X} - $a->{X});
+ my ($r);
+ $r= atan2($b->{Y} - $a->{Y},
+ $b->{X} - $a->{X});
+ $r -= 2 * $pi;
+ while ($r < $a->{A}) { $r += 2 * $pi; }
}
sub v_dist ($$) {
# v_dist(A,B)
sub can ($) { my ($c)=@_; canf($c, sub { die "too few args"; }); }
sub cano ($$) { my ($c,$def)=@_; canf($c, sub { return $def }); }
-$pi= atan2(0,-1);
sub signum ($) { return ($_[0] > 0) - ($_[0] < 0); }
-%units_len= qw(- mm mm 1 cm 10 m 1000);
-%units_ang= qw(- d r 1); $units_ang{'d'}= 2*$pi / 360;
+our %units_len= qw(- mm mm 1 cm 10 m 1000);
+our %units_ang= qw(- d r 1); $units_ang{'d'}= 2*$pi / 360;
sub cva_len ($) { my ($sp)=@_; cva_units($sp,\%units_len); }
sub cva_ang ($) { my ($sp)=@_; cva_units($sp,\%units_ang); }
sub dv1 ($$$) {
return 0 unless $debug;
my ($pfx,$expr,$v) = @_;
+ my ($ref);
$ref= ref $v;
#print STDERR "dv1 >$pfx|$ref<\n";
if (!$ref) {
}
}
-$ptscale= 72/25.4 / 7.0;
-
-$psu_ulen= 4.5;
-$psu_edgelw= 0.5;
-$psu_ticklw= 0.1;
-$psu_ticksperu= 1;
-$psu_ticklen= 5.0;
-$psu_allwidth= 37.0/2;
-$psu_gauge= 9;
-$psu_sleeperlen= 17;
-$psu_sleeperlw= 15;
-$psu_raillw= 1.0;
-
-$lmu_marklw= 4;
-$lmu_marktpt= 11;
-$lmu_txtboxtxty= $lmu_marktpt * 0.300;
-$lmu_txtboxh= $lmu_marktpt * 1.100;
-$lmu_txtboxpadx= $lmu_marktpt * 0.335;
-$lmu_txtboxoff= $lmu_marklw / 2;
-$lmu_txtboxlw= 1;
-
sub o ($) { $o .= $_[0]; }
sub ol ($) { $ol .= $_[0]; }
+our $o_path_verb;
+
sub o_path_begin () {
o(" newpath\n");
$o_path_verb= 'moveto';
my ($ends,$inunit,$across)=@_;
# $ends->[0]{X} etc.; $inunit 0 to 1 (but go to 1.5);
# $across in mm, +ve to right.
- my (%ea_zo);
+ my (%ea_zo, $zo, $prop);
$ea_zo{X}=$ea_zo{Y}=0;
foreach $zo (qw(0 1)) {
$prop= $zo ? $inunit : (1.0 - $inunit);
return $ea_zo{X}." ".$ea_zo{Y};
}
-sub parametric_segment ($$$$$) {
- my ($endstatuses,$p0,$p1,$lenperp,$calcfn) = @_;
+sub parametric_segment ($$$$) {
+ my ($p0,$p1,$lenperp,$calcfn) = @_;
# makes $p (global) go from $p0 to $p1 ($p1>$p0)
- # $ends is II, SI, IS, SS (I=actual lineobj end, S=in mid of lineobj)
# $lenperp is the length of one unit p, ie the curve
# must have a uniform `density' in parameter space
# $calcfn is invoked with $p set and should return a loc
print DEBUG "ps $p0 $p1 $lenperp ($ppu)\n";
for ($pa= $p0; $pa<$p1; $pa=$pb) {
$pb= $pa + $ppu;
- $p= $pa; $ends[0]= @ends ? $ends[1] : &$calcfn;
- $p= $pb; $ends[1]= &$calcfn;
+ $param= $pa; $ends[0]= @ends ? $ends[1] : &$calcfn;
+ $param= $pb; $ends[1]= &$calcfn;
#print DEBUG "pa $pa $ends[0]{X} $ends[0]{Y} $ends[0]{A}\n";
#print DEBUG "pb $pb $ends[1]{X} $ends[1]{Y} $ends[1]{A}\n";
$e= $pb<=$p1 ? 1.0 : ($p1-$pa)/$ppu;
}
}
-sub arc ($$$$$$$) {
- my ($to, $endstatuses, $ctr,$from,$fromsense, $radius,$delta) = @_;
+sub arc ($$$$$$) {
+ my ($to, $ctr,$from,$fromsense, $radius,$delta) = @_;
# does parametric_segment to draw an arc centred on $ctr
# from $from with radius $radius (this must be consistent!)
# and directionally-subtending an angle $delta.
$to->{A}= $beta= $from->{A} + $fromadj + $delta;
$to->{X}= $ctr->{X} - $radius * sin($beta);
$to->{Y}= $ctr->{Y} + $radius * cos($beta);
- parametric_segment($endstatuses, 0.0,1.0, abs($radius*$delta), sub {
- my ($beta) = $from->{A} + $delta * $p;
+ parametric_segment(0.0,1.0, abs($radius*$delta), sub {
+ my ($beta) = $from->{A} + $delta * $param;
return { X => $ctr->{X} - $radius * sin($beta),
Y => $ctr->{Y} + $radius * cos($beta),
A => $beta }
if ($how eq 'arcsline') {
$radius= can(\&cva_len);
}
-
- my ($sigma,$distfact, $theta,$phi, $a,$b,$c,$d2, $r,$cfrom);
- $sigma= v_bearing($from,$to);
- $distfact= v_dist($from,$to);
- $theta= $from - $sigma;
- $phi= $to + 2 * $pi - $sigma;
- $a= 2 * (1 + sin($theta - $phi));
- $b= 2 * (sin($theta) - sin($phi));
- $c= -1;
- die "too close" if $a<1.1e-10;
- $d2= $b*$b - 4*$a*$c;
- $pm = $how =~ /m$/ ? -1 : +1;
- $r= (-$b + $pm*sqrt($d2))/$a;
- $rf= $r*$distfact;
- $cfrom= ev_compose({}, $from, { Y => $rf, X => 0, A => 0 });
- $cto= ev_compose({}, $to, { Y => -$rf, X => 0, A => 0 });
- $cbearing= v_bearing($cfrom,$cto);
- arc({}, IS, $cfrom,$from,1.0, $rf, $cbearing - $cfrom->{A});
- arc({}, IS, $cto, $to, -1.0, -$rf, $cbearing - $cfrom->{A} + 2*$pi);
+ my (@paths);
+ if ($how eq 'arcs') {
+ my ($sigma,$distfact, $theta,$phi, $a,$b,$c,$d, $m,$r);
+ my ($cvec,$cfrom,$cto,$midpt, $delta1,$delta2, $path);
+ $sigma= ev_bearing($from,$to);
+ $distfact= v_dist($from,$to);
+ $theta= 0.5 * $pi - ($from->{A} - $sigma);
+ $phi= 0.5 * $pi - ($to->{A} + $pi - $sigma);
+ $a= 2 * (1 + cos($theta - $phi));
+ $b= 2 * (cos($theta) - cos($phi));
+ $c= -1;
+ $d= sqrt($b*$b - 4*$a*$c);
+ foreach $m (qw(-1 1)) {
+ $r= -0.5 * (-$b + $m*$d) / $a;
+ $radius= -$r * $distfact;
+ $cvec= { X => 0, Y => -$radius, A => 0.5*$pi };
+ $cfrom= ev_compose({}, $from, $cvec);
+ $cto= ev_compose({}, $to, $cvec);
+ $midpt= ev_lincomb({}, $cfrom, $cto, 0.5);
+ $delta1= ev_bearing($cfrom, $midpt);
+ $delta2= ev_bearing($cto, $midpt);
+ $delta2 -= 2*$pi;
+ $path= [{ T=>Arc, F=>$from, C=>$cfrom, R=>$radius, D=>$delta1 },
+ { T=>Arc, F=>$to, C=>$cto, R=>$radius, D=>$delta2 }];
+ push @paths, $path;
+ }
+ }
+ my ($path,$segment,$bestpath,$len,$bestlen);
+ foreach $path (@paths) {
+ o("% possible path $path\n");
+ $len= 0;
+ foreach $segment (@$path) {
+ if ($segment->{T} eq Arc) {
+ o("% Arc C ".loc2dbg($segment->{C}).
+ " R $segment->{R} D ".ang2deg($segment->{D})."\n");
+ $len += abs($radius * $segment->{D});
+ } else {
+ die "unknown segment $segment->{T}";
+ }
+ }
+ o("% length $len\n");
+ if (!defined($bestpath) || $len < $bestlen) {
+ $bestpath= $path;
+ $bestlen= $len;
+ }
+ }
+ die unless defined $bestpath;
+ o("% chose path $bestpath\n");
+ foreach $segment (@$bestpath) {
+ if ($segment->{T} eq 'Arc') {
+ arc({}, $segment->{C}, $segment->{F}, 1.0,
+ $segment->{R}, $segment->{D});
+ } else {
+ die "unknown segment";
+ }
+ }
}
sub cmd_extend {
- my ($from,$to,$radius,$ctr,$beta,$ang,$how,$sign_r);
+ my ($from,$to,$radius,$len,$upto,$ctr,$beta,$ang,$how,$sign_r);
$from= can(\&cva_idex);
$to= can(\&cva_idnew);
printf DEBUG "from $from->{X} $from->{Y} $from->{A}\n";
elsif ($how eq 'parallel' || $how eq 'upto') { $upto= can(\&cva_idex); }
$radius= cano(\&cva_len, 'Inf'); # +ve is right hand bend
if ($radius eq 'Inf') {
- print DEBUG "extend inf $len\n";
+# print DEBUG "extend inf $len\n";
if ($how eq 'upto') {
$len= ($upto->{X} - $from->{X}) * cos($from->{A})
+ ($upto->{Y} - $from->{Y}) * sin($from->{A});
$to->{X}= $from->{X} + $len * cos($from->{A});
$to->{Y}= $from->{Y} + $len * sin($from->{A});
$to->{A}= $from->{A};
- parametric_segment(II, 0.0, 1.0, abs($len), sub {
- ev_lincomb({}, $from, $to, $p);
+ parametric_segment(0.0, 1.0, abs($len), sub {
+ ev_lincomb({}, $from, $to, $param);
});
} else {
+ my ($sign_r, $sign_ang, $ctr, $beta_interval, $beta, $delta);
print DEBUG "radius >$radius<\n";
$radius *= $ctx->{Trans}{R};
$sign_r= signum($radius);
$beta -= $sign_ang * $sign_r * $beta_interval * $pi;
}
printf DEBUG "ctr->{Y}=$ctr->{Y} radius=$radius beta=$beta\n";
- arc($to, II, ,$ctr,$from,1.0, $radius,$delta);
+ arc($to, ,$ctr,$from,1.0, $radius,$delta);
}
printf DEBUG "to $to->{X} $to->{Y} $to->{A}\n";
}
+sub loc2dbg ($) {
+ my ($loc) = @_;
+ return "$loc->{X} $loc->{Y} ".ang2deg($loc->{A});
+}
sub ang2deg ($) {
return $_[0] * 180 / $pi;
}
};
}
+our $defobj_save;
+
sub cmd_defobj {
my ($id);
$id= can(\&cva_idstr);
sub cmd__obj ($) {
my ($flipsignum)=@_;
my ($obj_id, $ctx_save, $pfx, $actual, $formal_id, $formal, $formcv);
- my ($c, $ctx_inobj);
+ my ($c, $ctx_inobj, $obj, $id, $newid, $newpt);
$obj_id= can(\&cva_idstr);
$actual= can(\&cva_idex);
$formal_id= can(\&cva_idstr);
$io= defined $ctx->{InDefObj} ? "$ctx->{InDefObj}!" : $ctx->{InRunObj};
o("%L cmd $io $cmd @al\n");
$ctx->{LocsMade}= [ ];
- &{ "cmd_$cmd" };
+ {
+ no strict 'refs';
+ &{ "cmd_$cmd" };
+ };
die "too many args" if @al;
foreach $id (@{ $ctx->{LocsMade} }) {
$loc= $ctx->{Loc}{$id};
$ad= ang2deg($loc->{A});
- ol("%L point $io$id $loc->{X} $loc->{Y} $ad\n");
+ ol("%L point $io$id ".loc2dbg($loc)."\n");
if (length $ctx->{Draw}{L}) {
ol(" gsave\n".
" $loc->{X} $loc->{Y} translate $ad rotate\n");
~ijackson / trains.git / commitdiff