From: ian <ian>
Date: Sat, 23 Oct 2004 17:29:03 +0000 (+0000)
Subject: implement segmap
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=commitdiff_plain;h=7eee86ad0f75d8fe61ecdb1a46ea5b432fbec4c7;p=trains.git

implement segmap
---

diff --git a/layout/layout b/layout/layout
index f50d33d..bf006ce 100755
--- a/layout/layout
+++ b/layout/layout
@@ -194,6 +194,7 @@ our $allwidthmin= allwidth(undef);
 # Data structures:
 #  $ctx->{CmdLog}= undef                  } not in defobj
 #  $ctx->{CmdLog}[]= [ command args ]     } in defobj
+#  $ctx->{Parent}= $parent_ctx or undef
 #  $ctx->{LocsMade}[]{Id}= $id
 #  $ctx->{LocsMade}[]{Neg}= 1 or 0
 #  $ctx->{Loc}{$id}{X}
@@ -213,6 +214,8 @@ our $allwidthmin= allwidth(undef);
 #  $ctx->{SegName}        # initial segment name (at start of object or file)
 #                         #  or nonexistent if in object in unknown segment
 #                         #  may have leading `-'
+#  $ctx->{SegMapN}{$s}= $o
+#  $ctx->{SegMapNM}{$s}= $o
 #  $ctx->{SavedSegment}   # exists iff segment command used, is a $csss
 #  $ctx->{Layer}{Level}
 #  $ctx->{Layer}{Kind}
@@ -427,18 +430,6 @@ sub cva_idstr ($) {
     die "invalid id" unless $sp =~ m/^[a-z][_0-9A-Za-z]*$/;
     return $&;
 }
-sub cva_subsegspec ($) {
-    my ($sp)=@_;
-    die "invalid subsegment spec" unless
-	$sp =~ m,^(\-?)([0-9A-Za-z_]*)(?:/(?:([A-Za-z_]+)(\d+))?)?$,;
-    my ($sign,$segname,$movfeat,$movconf)=($1,$2,$3,$4);
-    $segname= exists $ctx->{SegName} ?
-	$sign.$ctx->{SegName}.$segname
-	    : '';
-    $segname =~ s/^\-(.*)\-/$1/;
-    return $segname.'/'.
-	(defined $movfeat ? sprintf "%s%d", $movfeat, $movconf : '');
-}
 sub cva_idex ($) {
     my ($sp)=@_;
     my ($id,$r,$d,$k,$neg,$na,$obj_id,$vflip,$locs);
@@ -1098,10 +1089,14 @@ sub newctx (;$) {
     $ctx= {
 	Trans => { X => 0.0, Y => 0.0, A => 0.0, R => 1.0 },
 	InRunObj => "",
-	DrawMap => sub { $_[0]; }
+	DrawMap => sub { $_[0]; },
+	SegMapN => { },
+	SegMapNM => { }
 	};
-    %{ $ctx->{Layer} }= %{ $ctx_save->{Layer} }
-        if defined $ctx_save;
+    if (defined $ctx_save) {
+	%{ $ctx->{Layer} }= %{ $ctx_save->{Layer} };
+	$ctx->{Parent}= $ctx_save;
+    }
 }
 
 our $defobj_save;
@@ -1150,6 +1145,42 @@ sub cmd__runobj ($) {
     }
 }
 
+sub cva_subsegspec ($) {
+    my ($sp)=@_;
+    die "invalid subsegment spec" unless
+	$sp =~ m,^(\-?)([0-9A-Za-z_]*)(?:/(?:([A-Za-z_]+)(\d+))?)?$,;
+    my ($sign,$segname,$movfeat,$movconf)=($1,$2,$3,$4);
+
+    if (!exists $ctx->{SegName}) {
+	$segname= '';
+	$sign= '';
+    } else {
+	my ($map_ctx);
+	
+	$ctx->{SegName} =~ m/^\-?/ or die;
+	$sign .= $&;
+	$segname= $'.$segname;
+	
+	for ($map_ctx= $ctx;
+	     defined $map_ctx;
+	     $map_ctx= $map_ctx->{Parent}) {
+	    if (defined $movfeat &&
+		exists $map_ctx->{SegMapNM}{"$segname/$movfeat"}) {
+		$movfeat= $map_ctx->{SegMapNM}{"$segname/$movfeat"};
+	    }
+	    if (exists $map_ctx->{SegMapN}{$segname}) {
+		$map_ctx->{SegMapN}{$segname} =~ m/^\-?/ or die;
+		$sign .= $&;
+		$segname= $';
+	    }
+	}
+	$sign =~ s/\-\-//g;
+    }
+
+    return $sign.$segname.'/'.
+	(defined $movfeat ? sprintf "%s%d", $movfeat, $movconf : '');
+}
+
 sub cmd_segment {
     my ($csss,$length);
     $ctx->{SavedSegment}= pop @segments
@@ -1164,6 +1195,37 @@ sub cmd_segment {
     push @segments, $csss;
 }
 
+sub cva_segmap_s {
+    my ($sp) = @_;
+    $sp =~ m,^\w+(?:/[a-zA-Z_]+)?$,
+        or die "invalid (sub)segment mapping S \`$sp'";
+    return $sp;
+}
+
+sub cva_segmap_n {
+    my ($sp) = @_;
+    $sp =~ m,^\-?\w+$, or die "invalid segment mapping N' \`$sp'";
+    return $sp;
+}
+    
+sub cva_segmap_m {
+    my ($sp) = @_;
+    $sp =~ m,^[a-zA-Z_]+$, or die "invalid segment mapping M' \`$sp'";
+    return $sp;
+}
+    
+sub cmd_segmap {
+    my ($s,$d);
+    while (@al) {
+	$s= can(\&cva_segmap_s);
+	if ($s =~ m,/,) {
+	    $ctx->{SegMapNM}{$s}= can(\&cva_segmap_m);
+	} else {
+	    $ctx->{SegMapN}{$s}= can(\&cva_segmap_n);
+	}
+    }
+}
+
 sub layer_draw ($$) {
     my ($k,$l) = @_;
     my ($eo,$cc, $r);