6 # $ctx->{CmdLog}= undef } not in defobj
7 # $ctx->{CmdLog}[]= [ command args ] } in defobj
8 # $ctx->{LocsMade}[]= $id
11 # $ctx->{Loc}{$id}{A} may be undef
12 # $ctx->{Trans}{X0} } transformation
13 # $ctx->{Trans}{Y0} } matrix
25 open DEBUG, ($debug ? ">&2" : ">/dev/null") or die $!;
33 my ($converter,$defaulter)=@_;
35 return &$defaulter unless @al;
37 $v= &$converter($spec);
38 dv('canf ','$spec',$spec, '$v',$v);
41 sub can ($) { my ($c)=@_; canf($c, sub { die "too few args"; }); }
42 sub cano ($$) { my ($c,$def)=@_; canf($c, sub { return $def }); }
46 %units_len= qw(- mm mm 1 cm 10 m 1000);
47 %units_ang= qw(- d r 1); $units_ang{'d'}= 2*$pi / 360;
49 sub cva_len ($) { my ($sp)=@_; cva_units($sp,\%units_len); }
50 sub cva_ang ($) { my ($sp)=@_; cva_units($sp,\%units_ang); }
51 sub cva_absang ($) { input_absang(cva_ang($_[0])) }
55 $sp =~ m/^([-0-9eE.]*[0-9.])([A-Za-z]*)$/
56 or die "lexically invalid quantity";
58 $u=$ua->{'-'} unless length $u;
59 defined $ua->{$u} or die "unknown unit $u";
61 print DEBUG "cva_units($sp,)=$r ($n $u $ua->{$u})\n";
66 die "invalid id" unless $sp =~ m/^[a-z][_0-9A-Za-z]*$/;
73 die "unknown $id" unless defined $ctx->{Loc}{$id};
76 foreach $k (sort keys %$r) { $d .= " $k=$r->{$k}"; }
77 printf DEBUG "%s\n", $d;
83 die "duplicate $id" if exists $ctx->{Loc}{$id};
84 exists $ctx->{Loc}{$id}{X};
85 push @{ $ctx->{LocsMade} }, $id;
86 return $ctx->{Loc}{$id};
88 sub cva_cmd ($) { return cva_idstr($_); }
91 return $sp if grep { $_ eq $sp } @$el;
92 die "invalid option (permitted: @$el)";
94 sub cvam_enum { my (@e) = @_; return sub { cva__enum($_[0],\@e); }; }
98 $nl= can(\&cva_idnew);
101 ($nl->{X}, $nl->{Y})= input_abscoords($x,$y);
102 $nl->{A}= cano(\&cva_absang, undef);
106 $from= can(\&cva_idex);
107 $to= can(\&cva_idnew);
108 $len= can(\&cva_len);
109 $right= can(\&cva_len);
110 $turn= cano(\&cva_ang, 0);
111 $to->{X}= $from->{X} + $len * cos($from->{A}) + $right * sin($from->{A});
112 $to->{Y}= $from->{Y} + $len * sin($from->{A}) - $right * cos($from->{A});
113 $to->{A}= $from->{A} + $turn;
118 $pfx . ($pfx =~ m/\}$|\]$/ ? '' : '->');
122 return $v if $v !~ m/\W/ && $v =~ m/[A-Z]/ && $v =~ m/^[a-z_]/i;
123 return $v if $v eq ($v+0.0);
124 $v =~ s/[\\\']/\\$&/g;
128 sub dv1_kind ($$$$$$$) {
129 my ($pfx,$expr,$ref,$ref_exp,$ixfmt,$ixesfn,$ixmapfn) = @_;
131 return 0 if $ref ne $ref_exp;
133 foreach $ix (&$ixesfn) {
135 my ($v)= &$ixmapfn($ix);
136 #print STDERR "dv1_kind($pfx,$expr,$ref,$ref_exp,$ixmapfn) ix=$ix v=$v\n";
137 dv1($pfx,$expr.sprintf($ixfmt,evr($ix)),$v);
140 printf DEBUG "%s%s= $ixfmt\n", $pfx, $expr, ' ';
145 return ;0 unless $debug;
146 my ($pfx,$expr,$v) = @_;
148 #print STDERR "dv1 >$pfx|$ref<\n";
150 printf DEBUG "%s%s= %s\n", $pfx,$expr, evr($v);
152 } elsif ($ref eq 'SCALAR') {
153 dv1($pfx, ($expr =~ m/^\$/ ? "\$$expr" : '${'.$expr.'}'), $$v);
156 $expr.='->' unless $expr =~ m/\]$|\}$/;
157 return if dv1_kind($pfx,$expr,$ref,'ARRAY','[%s]',
158 sub { ($[ .. $#$v) },
159 sub { $v->[$_[0]] });
160 return if dv1_kind($pfx,$expr,$ref,'HASH','{%s}',
161 sub { sort keys %$v },
162 sub { $v->{$_[0]} });
163 printf DEBUG "%s%s is %s\n", $pfx, $expr, $ref;
175 sub loc_lin_comb ($$$) {
178 map { $r->{$_} = $q * $a->{$_} + $p * $b->{$_} } qw(X Y A);
179 # dv("loc_lin_comb ",'$a',$a,'$b',$b,'$p',$p,'$r',$r);
188 $psu_allwidth= 37.0/2;
195 # fixme optional marking
196 print "$_[0]" or die $!;
199 sub o_path_begin () {
201 $o_path_verb= 'moveto';
203 sub o_path_point ($) {
205 o(" $pt $o_path_verb\n");
206 $o_path_verb= 'lineto';
208 sub o_path_stroke ($) {
210 o(" $width setlinewidth stroke\n");
214 my ($a,$b,$width)=@_;
218 o_path_stroke($width);
221 sub psu_coords ($$$) {
222 my ($ends,$inunit,$across)=@_;
223 # $ends->[0]{X} etc.; $inunit 0 to 1 (but go to 1.5);
224 # $across in mm, +ve to right.
226 $ea_zo{X}=$ea_zo{Y}=0;
227 foreach $zo (qw(0 1)) {
228 $prop= $zo ? $inunit : (1.0 - $inunit);
229 $ea_zo{X} += $prop * ($ends->[$zo]{X} - $across * sin($ends->[0]{A}));
230 $ea_zo{Y} += $prop * ($ends->[$zo]{Y} + $across * cos($ends->[0]{A}));
232 # dv("psu_coords ", '$ends',$ends, '$inunit',$inunit, '$across',$across,
233 # '\\%ea_zo', \%ea_zo);
234 return $ea_zo{X}." ".$ea_zo{Y};
237 sub parametric_segment ($$$$$) {
238 my ($endstatuses,$p0,$p1,$lenperp,$calcfn) = @_;
239 # makes $p (global) go from $p0 to $p1 ($p1>$p0)
240 # $ends is II, SI, IS, SS (I=actual lineobj end, S=in mid of lineobj)
241 # $lenperp is the length of one unit p, ie the curve
242 # must have a uniform `density' in parameter space
243 # $calcfn is invoked with $p set and should return a loc
244 # (ie, ref to X =>, Y =>, A =>).
245 my ($pa,$pb,@ends,$side,$ppu,$e,$v,$tick);
246 $ppu= $psu_ulen/$lenperp;
247 my ($railctr)=($psu_gauge + $psu_raillw)*0.5;
248 my ($tickend)=($psu_allwidth - $psu_ticklen);
249 my ($tickpitch)=($psu_ulen / $psu_ticksperu);
250 my ($sleeperctr)=($psu_ulen*0.5);
251 my ($sleeperend)=($psu_sleeperlen*0.5);
252 print DEBUG "ps $p0 $p1 $lenperp ($ppu)\n";
253 for ($pa= $p0; $pa<$p1; $pa=$pb) {
255 $p= $pa; $ends[0]= @ends ? $ends[1] : &$calcfn;
256 $p= $pb; $ends[1]= &$calcfn;
257 #print DEBUG "pa $pa $ends[0]{X} $ends[0]{Y} $ends[0]{A}\n";
258 #print DEBUG "pb $pb $ends[1]{X} $ends[1]{Y} $ends[1]{A}\n";
259 $e= $pb<=$p1 ? 1.0 : ($p1-$pa)/$ppu;
262 o_path_point(psu_coords(\@ends,0,-$psu_allwidth));
263 o_path_point(psu_coords(\@ends,0,$psu_allwidth));
264 o_path_point(psu_coords(\@ends,$e,$psu_allwidth));
265 o_path_point(psu_coords(\@ends,$e,-$psu_allwidth));
266 o(" closepath clip\n");
267 foreach $side qw(-1 1) {
268 o_line(psu_coords(\@ends,0,$side*$psu_allwidth),
269 psu_coords(\@ends,1.5,$side*$psu_allwidth),
271 o_line(psu_coords(\@ends,0,$side*$railctr),
272 psu_coords(\@ends,1.5,$side*$railctr),
274 for ($tick=0; $tick<1.5; $tick+=$tickpitch/$psu_ulen) {
275 o_line(psu_coords(\@ends,$tick,$side*$psu_allwidth),
276 psu_coords(\@ends,$tick,$side*$tickend),
280 o_line(psu_coords(\@ends,$sleeperctr,-$sleeperend),
281 psu_coords(\@ends,$sleeperctr,+$sleeperend),
288 my ($from,$to,$radius,$ctr,$beta,$ang,$how,$signum);
289 $from= can(\&cva_idex);
290 $to= can(\&cva_idnew);
291 printf DEBUG "from $from->{X} $from->{Y} $from->{A}\n";
292 die "no ang" unless defined $from->{A};
293 $how= can(cvam_enum(qw(len upto ang uptoang parallel)));
294 if ($how eq 'len') { $len= can(\&cva_len); }
295 elsif ($how =~ m/ang$/) { $ang= can(\&cva_ang); }
296 elsif ($how eq 'parallel' || $how eq 'upto') { $upto= can(\&cva_idex); }
297 $radius= cano(\&cva_len, 'Inf'); # +ve is right hand bend
298 if ($radius eq 'Inf') {
299 print DEBUG "extend inf $len\n";
300 if ($how eq 'ang') { die "len of straight spec by angle"; }
301 if ($how eq 'upto') {
302 $len= ($upto->{X} - $from->{X}) * cos($from->{A})
303 + ($upto->{Y} - $from->{Y}) * sin($from->{A});
305 printf DEBUG "len $len\n";
306 $to->{X}= $from->{X} + $len * cos($from->{A});
307 $to->{Y}= $from->{Y} + $len * sin($from->{A});
308 $to->{A}= $from->{A};
309 parametric_segment(II, 0.0, 1.0, $len, sub {
310 loc_lin_comb($from, $to, $p);
313 print DEBUG "radius >$radius<\n";
314 $signum= $radius / abs($radius);
315 $ctr->{X}= $from->{X} + $radius * sin($from->{A});
316 $ctr->{Y}= $from->{Y} - $radius * cos($from->{A});
317 if ($how eq 'upto') {
318 $beta= atan2(-$signum * ($upto->{X} - $ctr->{X}),
319 $signum * ($upto->{Y} - $ctr->{Y}));
321 } elsif ($how eq 'parallel') {
324 } elsif ($how eq 'uptoang') {
325 $beta= input_absang($ang);
327 } elsif ($how eq 'len') {
328 $beta= $from->{A} - $signum * $len / abs($radius);
331 $beta= $from->{A} - $signum * $ang;
334 printf DEBUG "ctr->{Y}=$ctr->{Y} radius=$radius beta=$beta\n";
335 $beta += $signum * 4.0 * $pi;
337 $delta= $beta - $from->{A};
338 last if $signum * $delta <= 0;
339 $beta -= $signum * $beta_interval * $pi;
341 printf DEBUG "ctr->{Y}=$ctr->{Y} radius=$radius beta=$beta\n";
343 $to->{X}= $ctr->{X} - $radius * sin($beta);
344 $to->{Y}= $ctr->{Y} + $radius * cos($beta);
345 parametric_segment(II, 0.0, 1.0, abs($radius*$delta), sub {
346 my ($beta) = $from->{A} + $delta * $p;
347 return { X => $ctr->{X} - $radius * sin($beta),
348 Y => $ctr->{Y} + $radius * cos($beta),
352 printf DEBUG "to $to->{X} $to->{Y} $to->{A}\n";
356 my ($id, $cmd, $loc);
357 $ctx->{LocsMade}= [ ];
358 $cmd= can(\&cva_cmd);
360 die "too many args" if @al;
361 foreach $id (@{ $ctx->{LocsMade} }) {
362 $loc= $ctx->{Locs}{$id};
363 o("% point $id $loc->{X} $loc->{Y} ".ang2deg($loc->{A})."\n");
371 sub input_absang ($) {
372 return $_ * $ctx->{Trans}{AA} + $ctx->{Trans}{A0};
374 sub input_abscoords ($$) {
376 ($in->{X}, $in->{Y})= @_;
377 foreach $o (qw(X Y)) {
378 $out->{$o}= $ctx->{Trans}{$o.0};
379 foreach $i (qw(X Y)) {
380 $out->{$o} += $ctx->{Trans}{"$i$o"} * $in->{$i};
383 return ($out->{X}, $out->{Y});
387 $ctx= { Trans => { X0 => 0.0, Y0 => 0.0,
388 XY => 0.0, YX => 0.0,
389 A0 => 0.0, AA => 1.0,
390 XX => 1.0, YY => 1.0; } }
394 $defobj_id= can(\&cva_idstr);
395 die "nested defobj" if $defobj_save;
396 die "repeated defobj" if exists $objs{$defobj_id};
399 $ctx= { CmdLog => [ ] }
403 die "unmatched enddefobj" unless $defobj_save;
405 foreach $bit (qw(CmdLog Loc)) {
406 $objs{$defobj_id}{$bit}= $ctx->{$bit};
412 sub cmd_obj { cmd__obj(1); }
413 sub cmd_objflip { cmd__obj(-1); }
416 my ($obj_id, $ctx_save, $pfx);
417 $obj_id= can(\&cva_idstr);
418 $actual= can(\&cva_idex);
419 $formal= can(\&cva_idstr);
420 $obj= $objs{$obj_id};
421 die "unknown obj $obj_id" unless $obj;
424 o("% obj $obj_id\n");
425 $ctx->{Trans}{AA}= $flipsignum;
426 $ctx->{Trans}{A0}= $formal->{A} - $actual->{A}/$flipsignum;
427 $ctx->{Trans}{XX}= cos($ctx->{Trans}{A0});
428 $ctx->{Trans}{YY}= $flipsignum * cos($ctx->{Trans}{A0});
429 $ctx->{Trans}{XY}= sin($ctx->{Trans}{A0});
430 $ctx->{Trans}{YX}= -$flipsignum * sin($ctx->{Trans}{A0});
431 ($xformcv,$yformcv)= input_abscoords($formal->{X}, $formal->{Y});
432 $ctx->{Trans}{X0}= $actual->{X} - $xformcv;
433 $ctx->{Trans}{Y0}= $actual->{Y} - $yformcv;
436 foreach $c ($obj->{CmdLog}) {
441 $pfx= cano(\&cva_idstr,'');
443 foreach $id (keys $ctx->{Loc}) {
445 next if exists $ctx_save->{Loc}{$newid};
446 $pt= $ctx->{Loc}{$id};
447 $newpt= { A => input_absang($pt->{A}) };
448 ($newpt->{X}, $newpt->{Y})= input_abscoords($pt->{X}, $pt->{Y});
449 $ctx_save->{Loc}{$newid}= $newpt;
455 $ptscale= 72/25.4 / 5.0;
458 " $ptscale $ptscale scale\n");
464 chomp; s/^\s+//; s/\s+$//;
465 @al= split /\s+/, $_;
467 print DEBUG "=== @al\n";
468 push @{ $ctx->{CmdLog} }, [ @al ] if exists $ctx->{CmdLog};