use POSIX;
# Data structures:
-# $loc{$id}{X}
-# $loc{$id}{Y}
-# $loc{$id}{A} may be undef
+# $ctx->{CmdLog}= undef } not in defobj
+# $ctx->{CmdLog}[]= [ command args ] } in defobj
+# $ctx->{LocsMade}[]= $id
+# $ctx->{Loc}{$id}{X}
+# $ctx->{Loc}{$id}{Y}
+# $ctx->{Loc}{$id}{A} may be undef
+# $ctx->{Trans}{X0} } transformation
+# $ctx->{Trans}{Y0} } matrix
+# $ctx->{Trans}{XY} }
+# $ctx->{Trans}{YX} }
+# $ctx->{Trans}{XX} }
+# $ctx->{Trans}{YY} }
+# $ctx->{Trans}{AA} }
+# $ctx->{Trans}{AS} }
+#
+# $objs{$id}{CmdLog}
+# $objs{$id}{Loc}
#$debug=1;
open DEBUG, ($debug ? ">&2" : ">/dev/null") or die $!;
sub cva_len ($) { my ($sp)=@_; cva_units($sp,\%units_len); }
sub cva_ang ($) { my ($sp)=@_; cva_units($sp,\%units_ang); }
+sub cva_absang ($) { input_absang(cva_ang($_[0])) }
sub cva_units ($$) {
my ($sp,$ua)=@_;
my ($n,$u,$r);
}
sub cva_idstr ($) {
my ($sp)=@_;
- die "invalid id" unless $sp =~ m/^[-0-9a-z]+$/;
+ die "invalid id" unless $sp =~ m/^[a-z][_0-9A-Za-z]*$/;
return $&;
}
sub cva_idex ($) {
my ($sp,$id)=@_;
my ($r,$d,$k);
$id=cva_idstr($sp);
- die "unknown $id" unless defined $loc{$id};
- $r= $loc{$id};
+ die "unknown $id" unless defined $ctx->{Loc}{$id};
+ $r= $ctx->{Loc}{$id};
$d= "idex $id";
foreach $k (sort keys %$r) { $d .= " $k=$r->{$k}"; }
printf DEBUG "%s\n", $d;
sub cva_idnew ($) {
my ($sp,$id)=@_;
$id=cva_idstr($sp);
- die "duplicate $id" if exists $loc{$id};
- exists $loc{$id}{X};
- return $loc{$id};
-}
-sub cva_cmd ($) {
- my ($sp)=@_;
- die "command lexically invalid" if $sp =~ m/[^-0-9a-z]/i;
- $sp =~ y/-/_/;
- return $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__enum ($$) {
my ($sp,$el)=@_;
return $sp if grep { $_ eq $sp } @$el;
}
sub cvam_enum { my (@e) = @_; return sub { cva__enum($_[0],\@e); }; }
-sub cmd_mark {
- $mark= 1;
- &cmd__do;
-}
-
sub cmd_abs {
+ my ($x,$y);
$nl= can(\&cva_idnew);
- $nl->{X}= can(\&cva_len);
- $nl->{Y}= can(\&cva_len);
- $nl->{A}= cano(\&cva_ang, undef);
-dv('cmd_abs ','$nl',$nl,'\\%loc',\%loc);
+ $x= can(\&cva_len);
+ $y= can(\&cva_len);
+ ($nl->{X}, $nl->{Y})= input_abscoords($x,$y);
+ $nl->{A}= cano(\&cva_absang, undef);
}
sub cmd_rel {
$to->{X}= $from->{X} + $len * cos($from->{A}) + $right * sin($from->{A});
$to->{Y}= $from->{Y} + $len * sin($from->{A}) - $right * cos($from->{A});
$to->{A}= $from->{A} + $turn;
-dv('cmd_abs ','$to',$to);
}
sub evreff ($) {
$beta= $upto->{A};
$beta_interval= 1.0;
} elsif ($how eq 'uptoang') {
- $beta= $ang;
+ $beta= input_absang($ang);
$beta_interval= 2.0;
} elsif ($how eq 'len') {
$beta= $from->{A} - $signum * $len / abs($radius);
}
sub cmd__do {
+ my ($id, $cmd, $loc);
+ $ctx->{LocsMade}= [ ];
$cmd= can(\&cva_cmd);
&{ "cmd_$cmd" };
-}
+ die "too many args" if @al;
+ foreach $id (@{ $ctx->{LocsMade} }) {
+ $loc= $ctx->{Locs}{$id};
+ o("% point $id $loc->{X} $loc->{Y} ".ang2deg($loc->{A})."\n");
+ }
+}
+
+sub cmd__one {
+ cmd__do();
+}
+
+sub input_absang ($) {
+ return $_ * $ctx->{Trans}{AA} + $ctx->{Trans}{A0};
+}
+sub input_abscoords ($$) {
+ my ($in,$out, $i);
+ ($in->{X}, $in->{Y})= @_;
+ foreach $o (qw(X Y)) {
+ $out->{$o}= $ctx->{Trans}{$o.0};
+ foreach $i (qw(X Y)) {
+ $out->{$o} += $ctx->{Trans}{"$i$o"} * $in->{$i};
+ }
+ }
+ return ($out->{X}, $out->{Y});
+}
+
+sub newctx () {
+ $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; } }
+}
+
+sub cmd_defobj {
+ $defobj_id= can(\&cva_idstr);
+ die "nested defobj" if $defobj_save;
+ die "repeated defobj" if exists $objs{$defobj_id};
+ $defobj_save= $ctx;
+ newctx();
+ $ctx= { CmdLog => [ ] }
+}
+
+sub cmd_enddefobj {
+ die "unmatched enddefobj" unless $defobj_save;
+ my ($bit);
+ foreach $bit (qw(CmdLog Loc)) {
+ $objs{$defobj_id}{$bit}= $ctx->{$bit};
+ }
+ $ctx= $defobj_save;
+ $defobj_save= undef;
+}
+
+sub cmd_obj { cmd__obj(1); }
+sub cmd_objflip { cmd__obj(-1); }
+sub cmd__obj ($) {
+ my ($flipsignum)=@_;
+ my ($obj_id, $ctx_save, $pfx);
+ $obj_id= can(\&cva_idstr);
+ $actual= can(\&cva_idex);
+ $formal= can(\&cva_idstr);
+ $obj= $objs{$obj_id};
+ die "unknown obj $obj_id" unless $obj;
+ $ctx_save= $ctx;
+ newctx();
+ o("% obj $obj_id\n");
+ $ctx->{Trans}{AA}= $flipsignum;
+ $ctx->{Trans}{A0}= $formal->{A} - $actual->{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}{YX}= -$flipsignum * sin($ctx->{Trans}{A0});
+ ($xformcv,$yformcv)= input_abscoords($formal->{X}, $formal->{Y});
+ $ctx->{Trans}{X0}= $actual->{X} - $xformcv;
+ $ctx->{Trans}{Y0}= $actual->{Y} - $yformcv;
+ {
+ local (@al);
+ foreach $c ($obj->{CmdLog}) {
+ @al= @$c;
+ cmd__one();
+ }
+ }
+ $pfx= cano(\&cva_idstr,'');
+ if (length $pfx) {
+ foreach $id (keys $ctx->{Loc}) {
+ $newid= $pfx.$id;
+ next if exists $ctx_save->{Loc}{$newid};
+ $pt= $ctx->{Loc}{$id};
+ $newpt= { A => input_absang($pt->{A}) };
+ ($newpt->{X}, $newpt->{Y})= input_abscoords($pt->{X}, $pt->{Y});
+ $ctx_save->{Loc}{$newid}= $newpt;
+ }
+ }
+ $ctx= $ctx_save;
+}
$ptscale= 72/25.4 / 5.0;
o("%!\n".
" $ptscale $ptscale scale\n");
+newctx();
+
while (<>) {
next if m/^\s*\#/;
chomp; s/^\s+//; s/\s+$//;
@al= split /\s+/, $_;
next unless @al;
print DEBUG "=== @al\n";
- $mark= 0;
- cmd__do();
+ push @{ $ctx->{CmdLog} }, [ @al ] if exists $ctx->{CmdLog};
+ cmd__one();
}
-dv('','\\%loc',\%loc);
o(" showpage\n");
~ijackson / trains.git / commitdiff