From: ian Date: Sun, 25 Jan 2004 17:07:53 +0000 (+0000) Subject: use strict (no subs) X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=commitdiff_plain;h=3ee1133bb0cd3ad39fd0403338d76be0c5101c52;p=trains.git use strict (no subs) --- diff --git a/layout/layout b/layout/layout index 5552581..bba4cb4 100755 --- a/layout/layout +++ b/layout/layout @@ -1,6 +1,31 @@ #!/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 @@ -19,6 +44,16 @@ use POSIX; # $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 $!; @@ -53,7 +88,8 @@ sub ev_byang ($$;$) { } 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) = @_; @@ -85,13 +121,17 @@ sub ev_lincomb ($$$$) { 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) @@ -116,11 +156,10 @@ sub canf ($$) { 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); } @@ -227,6 +266,7 @@ sub dv1_kind ($$$$$$$) { sub dv1 ($$$) { return 0 unless $debug; my ($pfx,$expr,$v) = @_; + my ($ref); $ref= ref $v; #print STDERR "dv1 >$pfx|$ref<\n"; if (!$ref) { @@ -255,30 +295,11 @@ sub dv { } } -$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'; @@ -305,7 +326,7 @@ sub psu_coords ($$$) { 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); @@ -317,10 +338,9 @@ sub psu_coords ($$$) { 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 @@ -336,8 +356,8 @@ sub parametric_segment ($$$$$) { 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; @@ -368,8 +388,8 @@ print DEBUG "ps $p0 $p1 $lenperp ($ppu)\n"; } } -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. @@ -381,8 +401,8 @@ sub arc ($$$$$$$) { $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 } @@ -397,29 +417,66 @@ sub cmd_join { 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"; @@ -429,7 +486,7 @@ sub cmd_extend { 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}); @@ -441,10 +498,11 @@ sub cmd_extend { $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); @@ -478,11 +536,15 @@ sub cmd_extend { $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; } @@ -505,6 +567,8 @@ sub newctx () { }; } +our $defobj_save; + sub cmd_defobj { my ($id); $id= can(\&cva_idstr); @@ -533,7 +597,7 @@ sub cmd_objflip { cmd__obj(-1); } 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); @@ -582,12 +646,15 @@ dv("cmd__do $ctx @al ",'$ctx',$ctx); $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");