# $objs{$id}{CmdLog}
# $objs{$id}{Loc}
-#$debug=1;
+$debug=1;
open DEBUG, ($debug ? ">&2" : ">/dev/null") or die $!;
if ($debug) {
return $r;
}
sub cva_idnew ($) {
- my ($sp,$id)=@_;
+ my ($sp)=@_;
+ my ($id);
$id=cva_idstr($sp);
die "duplicate $id" if exists $ctx->{Loc}{$id};
exists $ctx->{Loc}{$id}{X};
push @{ $ctx->{LocsMade} }, $id;
return $ctx->{Loc}{$id};
}
-sub cva_cmd ($) { return cva_idstr($_); }
+sub cva_cmd ($) { return cva_idstr($_[0]); }
sub cva__enum ($$) {
my ($sp,$el)=@_;
return $sp if grep { $_ eq $sp } @$el;
sub evr ($) {
my ($v) = @_;
return $v if $v !~ m/\W/ && $v =~ m/[A-Z]/ && $v =~ m/^[a-z_]/i;
- return $v if $v eq ($v+0.0);
+ return $v if $v =~ m/^[0-9.]+/;
$v =~ s/[\\\']/\\$&/g;
return "'$v'";
}
1;
}
sub dv1 ($$$) {
- return ;0 unless $debug;
+ return 0 unless $debug;
my ($pfx,$expr,$v) = @_;
$ref= ref $v;
#print STDERR "dv1 >$pfx|$ref<\n";
$psu_ulen= 4.5;
$psu_edgelw= 0.5;
$psu_ticklw= 0.1;
-$psu_ticksperu= 3;
-$psu_ticklen= 3.0;
+$psu_ticksperu= 1;
+$psu_ticklen= 5.0;
$psu_allwidth= 37.0/2;
$psu_gauge= 9;
$psu_sleeperlen= 17;
# $calcfn is invoked with $p set and should return a loc
# (ie, ref to X =>, Y =>, A =>).
my ($pa,$pb,@ends,$side,$ppu,$e,$v,$tick);
+ return if defined $ctx->{InDefObj};
$ppu= $psu_ulen/$lenperp;
my ($railctr)=($psu_gauge + $psu_raillw)*0.5;
my ($tickend)=($psu_allwidth - $psu_ticklen);
});
} else {
print DEBUG "radius >$radius<\n";
+ $radius *= $ctx->{Trans}{AA};
$signum= $radius / abs($radius);
$ctr->{X}= $from->{X} + $radius * sin($from->{A});
$ctr->{Y}= $from->{Y} - $radius * cos($from->{A});
&{ "cmd_$cmd" };
die "too many args" if @al;
foreach $id (@{ $ctx->{LocsMade} }) {
- $loc= $ctx->{Locs}{$id};
+ $loc= $ctx->{Loc}{$id};
o("% point $id $loc->{X} $loc->{Y} ".ang2deg($loc->{A})."\n");
}
}
cmd__do();
}
+sub ang2deg ($) {
+ return $_[0] * 180 / $pi;
+}
sub input_absang ($) {
- return $_ * $ctx->{Trans}{AA} + $ctx->{Trans}{A0};
+ return $_[0] * $ctx->{Trans}{AA} + $ctx->{Trans}{A0};
}
sub input_abscoords ($$) {
my ($in,$out, $i);
$ctx= { Trans => { X0 => 0.0, Y0 => 0.0,
XY => 0.0, YX => 0.0,
A0 => 0.0, AA => 1.0,
- XX => 1.0, YY => 1.0; } }
+ XX => 1.0, YY => 1.0 } }
}
sub cmd_defobj {
- $defobj_id= can(\&cva_idstr);
+ my ($id);
+ $id= can(\&cva_idstr);
die "nested defobj" if $defobj_save;
- die "repeated defobj" if exists $objs{$defobj_id};
+ die "repeated defobj" if exists $objs{$id};
$defobj_save= $ctx;
newctx();
- $ctx= { CmdLog => [ ] }
+ $ctx->{CmdLog}= [ ];
+ $ctx->{InDefObj}= $id;
}
sub cmd_enddefobj {
- die "unmatched enddefobj" unless $defobj_save;
- my ($bit);
+ my ($bit,$id);
+ $id= $ctx->{InDefObj};
+ die "unmatched enddefobj" unless defined $id;
foreach $bit (qw(CmdLog Loc)) {
- $objs{$defobj_id}{$bit}= $ctx->{$bit};
+ $objs{$id}{$bit}= $ctx->{$bit};
}
$ctx= $defobj_save;
$defobj_save= undef;
my ($obj_id, $ctx_save, $pfx);
$obj_id= can(\&cva_idstr);
$actual= can(\&cva_idex);
- $formal= can(\&cva_idstr);
+ $formal_id= can(\&cva_idstr);
$obj= $objs{$obj_id};
+ dv("cmd__obj ",'$obj',$obj);
die "unknown obj $obj_id" unless $obj;
+ $formal= $obj->{Loc}{$formal_id};
+ die "unknown formal $formal_id" unless $formal;
$ctx_save= $ctx;
newctx();
o("% obj $obj_id\n");
$ctx->{Trans}{AA}= $flipsignum;
- $ctx->{Trans}{A0}= $formal->{A} - $actual->{A}/$flipsignum;
+ $ctx->{Trans}{A0}= $actual->{A} - $formal->{A}/$flipsignum;
$ctx->{Trans}{XX}= cos($ctx->{Trans}{A0});
$ctx->{Trans}{YY}= $flipsignum * cos($ctx->{Trans}{A0});
- $ctx->{Trans}{XY}= sin($ctx->{Trans}{A0});
+ $ctx->{Trans}{XY}= $flipsignum * sin($ctx->{Trans}{A0});
$ctx->{Trans}{YX}= -$flipsignum * sin($ctx->{Trans}{A0});
($xformcv,$yformcv)= input_abscoords($formal->{X}, $formal->{Y});
+print STDERR ">$xformcv|$yformcv<\n";
$ctx->{Trans}{X0}= $actual->{X} - $xformcv;
$ctx->{Trans}{Y0}= $actual->{Y} - $yformcv;
{
local (@al);
- foreach $c ($obj->{CmdLog}) {
+ foreach $c (@{ $obj->{CmdLog} }) {
@al= @$c;
+ next if $al[0] eq 'enddefobj';
cmd__one();
}
}
$pfx= cano(\&cva_idstr,'');
if (length $pfx) {
- foreach $id (keys $ctx->{Loc}) {
+ foreach $id (keys %{ $ctx->{Loc} }) {
$newid= $pfx.$id;
next if exists $ctx_save->{Loc}{$newid};
$pt= $ctx->{Loc}{$id};