our %subsegcmap;
our %segcmap;
-our $drawers= 'arqscldmnog';
+our $drawers= 'arqscldmnoge';
our %chdraw_emap= qw(A ARScgd
R aRscgD
S aRScgd
our $psu_raillw= 1.0;
our $psu_thinlw= 1.0;
our %psu_subseglw;
+
$psu_subseglw{'e'}= 20.0;
$psu_subseglw{'m'}= 15.0;
$psu_subseglw{'q'}= 20.0;
+our $lmu_segtpt= 25;
+our $lmu_segtxtoff= -8;
our $lmu_marklw= 4;
our $lmu_marktpt= 11;
#
# $subsegcmap{$csss} = "$green $blue"
# # $csss is canonical subseg spec; always has '/'
+# $segcmap{$bareseg} = "$postscript"
+#
+# $seggraphends{"$bareseg"}[]{X}
+# $seggraphends{"$bareseg"}[]{Y}
+# $seggraphends{"$bareseg"}[]{A}
+# $seggraphends{"-$bareseg"}[]...
+# $seggraphend[0]{X}
+# $seggraphend[0]{Y}
+# $seggraphend[1]{X}
+# $seggraphend[1]{Y}
our $ctx;
our %objs;
+our %seggraphends;
+our @seggraphend;
our @al; # current cmd
our $o='';
# v_add(A,B,...)
# vector sum of all inputs
my (@i) = @_;
+#print STDERR "add ".join('|',keys %{$i[0]}),"<\n";
+#map { print STDERR " ".join('|',keys %{$_}),"<\n"; } @i;
my ($r,$i);
$r= { X => 0.0, Y => 0.0 };
foreach $i (@i) { $r->{X} += $i->{X}; $r->{Y} += $i->{Y}; }
return $r;
-}
+}
+sub v_mean (;@) {
+ my (@i) = @_;
+#print STDERR "mean ".join('|',keys %{$i[0]}),"<\n";
+#map { print STDERR " ".join('|',keys %{$_}),"<\n"; } @i;
+ my ($r) = v_add($i[0],@i[1..$#i]);
+ $r->{X} /= @i;
+ $r->{Y} /= @i;
+ return $r;
+}
sub v_subtract ($$) {
# v_subtract(A,B)
# returns vector from A to B, ie B - A
o(" stroke\n");
}
+sub o_transform ($) {
+ my ($pt) = @_;
+ my ($ad);
+ $ad= ang2deg($pt->{A});
+ ol(" gsave\n".
+ " $pt->{X} $pt->{Y} translate\n".
+ " $ad rotate\n");
+}
+
sub o_line ($$$) {
my ($a,$b,$width)=@_;
o_path_begin();
$r->[0]++;
}
+sub segment__check_graphends () {
+ my ($bare,$ge,$i,$key);
+ @seggraphend= ();
+ $segments[0] =~ m/^\-?(\w+)/ or return;
+ $bare= $1;
+ foreach $i (qw(0 1)) {
+ $key= ('', '-')[$i].$bare;
+ $ge= $seggraphends{$key};
+ defined $ge or return;
+#print STDERR "$key @$ge\n";
+#map { print STDERR " ".join('|',keys %{$_}),"<\n"; } @$ge;
+ $seggraphend[$i]= v_mean(@$ge);
+#print STDERR "SGE $i $seggraphend[$i]{X} $seggraphend[$i]{Y}\n";
+ }
+}
+
sub segment_used_begin ($) {
$segused_incurrent= 0;
$segused_currentpt= $_[0];
+ segment__check_graphends();
}
sub segment_used_middle ($$) {
my ($used,$pt) = @_;
segment_used__len($used,$pt);
+ segment__check_graphends();
}
sub segment_used_end ($$) {
my ($used,$pt) = @_;
# must have a uniform `density' in parameter space
# $calcfn is invoked with $param set and should return a loc
# (ie, ref to X =>, Y =>, A =>).
- my ($pa,$pb,@ends,$side,$ppu,$e,$v,$tick,$draw,$allwidth);
- return unless $ctx->{Draw} =~ m/[ARSCGQ]/;
+ my ($pa,$pb,@ends,$side,$ppu,$e,$v,$tick,$draw,$allwidth,%seglabel);
+ return unless $ctx->{Draw} =~ m/[ARSCGQE]/;
$ppu= $psu_ulen/$lenperp;
$allwidth= allwidth($minradius);
my ($railctr)=($psu_gauge + $psu_raillw)*0.5;
my ($sleeperend)=($psu_sleeperlen*0.5);
print DEBUG "ps $p0 $p1 $lenperp ($ppu)\n";
$draw= current_draw();
- if ($draw =~ m/[QG]/) {
+ if ($draw =~ m/[QGE]/) {
my ($pt,$going,$red,$csegbare,$movfeat,$movstroke);
- my ($used_last,$me,$segsave);
+ my ($used_last,$me,$segsave,$diff);
o("gsave\n");
$segsave= segment_state_save();
foreach $me ($draw =~ m/Q/ ? qw(q) : qw(e m)) {
($me eq 'e' && $csegbare =~ m,^/,)) {
$movstroke= "% no-stroke ";
}
+ } else {
+ $movstroke= "!! seglabels-only ";
}
$movstroke .=
" $psu_subseglw{$me} setlinewidth stroke\n";
}
- o_path_begin();
- parametric__o_pt($pt);
-
+ if ($draw =~ m/[QG]/) {
+ o_path_begin();
+ parametric__o_pt($pt);
+ }
$param += $ppu;
last if $param>=$p1;
$pt= &$calcfn;
+ if ($draw =~ m/E/ && @seggraphend==2) {
+ $diff= v_len(v_subtract($pt, $seggraphend[0])) -
+ v_len(v_subtract($pt, $seggraphend[1]));
+ if (abs($diff) < $psu_ulen*3) {
+ $segments[0] =~ m/^(\-?)(\w+)/;
+ $seglabel{$2}{X}= $pt->{X};
+ $seglabel{$2}{Y}= $pt->{Y};
+ $seglabel{$2}{A}= $pt->{A};
+ $seglabel{$2}{A} += $pi if length($1);
+ }
+ }
segment_used_middle($psu_ulen,$pt);
- parametric__o_pt($pt);
- o($movstroke);
+ if ($draw =~ m/[QG]/) {
+ parametric__o_pt($pt);
+ o($movstroke);
+ }
}
$used_last= $p1-($param-$ppu);
$param=$p1;
parametric__o_pt(&$calcfn);
o(" stroke\n");
}
+ if ($draw =~ m/E/) {
+ my ($pt,$seg);
+ foreach $seg (keys %seglabel) {
+ $pt= $seglabel{$seg};
+ ol(" gsave\n");
+ o_transform($pt);
+ ol(" /s ($seg) def\n".
+ " sf setfont\n".
+ " 0 0 moveto\n".
+ " s stringwidth pop -0.5 mul $lmu_segtxtoff moveto\n".
+ " s show\n".
+ " grestore\n");
+ }
+ }
if ($draw =~ m/[ARS]/) { for ($pa= $p0; $pa<$p1; $pa=$pb) {
$pb= $pa + $ppu;
$param= $pa; $ends[0]= @ends ? $ends[1] : &$calcfn;
o(" grestore\n");
} }
if ($draw =~ m/D/) {
- my ($pt,$ad,$len,$off);
+ my ($pt,$len,$off);
$param= ($p0+$p1)*0.5;
$pt= &$calcfn;
- $ad= ang2deg($pt->{A});
$len= sprintf "%.0f", $lenperp * abs($p1-$p0);
$off= $draw =~ m/C/ ? $lmu_lenlabeloff : $lmu_lenlabeloffctr;
- ol(" gsave\n".
- " $pt->{X} $pt->{Y} translate\n".
- " $ad rotate\n".
- " lf setfont\n".
+ ol(" gsave\n");
+ o_transform($pt);
+ ol(" lf setfont\n".
" 0 $off moveto\n".
" ($len) show\n".
" grestore\n");
sub cva_segment ($) {
my ($sp)=@_;
- die "invalid segment" if $sp =~ m/[^0-9A-Za-z_]/;
+ die "invalid segment" if $sp =~ m/\W/;
+ return $sp;
+}
+
+sub cva_segment_n ($) {
+ my ($sp)=@_;
+ die "invalid segment" if $sp =~ m/[^-0-9A-Za-z_]/;
return $sp;
}
$sp =~ m,^[a-zA-Z_]+$, or die "invalid segment mapping M' \`$sp'";
return $sp;
}
-
+
sub cmd_segmap {
my ($s,$d);
while (@al) {
}
}
-sub cmd_segend {
- @al=();
-};
-
sub cmd_segcmap {
my ($seg,$colour);
$seg= can(\&cva_segment);
@al= ();
};
+sub cmd_segend {
+ my ($from,$sp) = @_;
+ $from= can(\&cva_idex);
+ $sp= can(\&cva_segment_n);
+#print STDERR "setting $from ".join('|',keys %$from),"<\n";
+ push @{ $seggraphends{$sp} }, $from;
+};
+
sub layer_draw ($$) {
my ($k,$l) = @_;
my ($eo,$cc, $r);
o("%!\n".
" /lf /Courier-New findfont $lmu_marktpt scalefont def\n".
+ " /sf /Courier-Bold findfont $lmu_segtpt scalefont def\n".
" $ps_page_shift 0 translate 90 rotate\n".
" gsave\n");
~ijackson / trains.git / blobdiff