our ($mistakes, $currentline);
our (%segs);
-# $segs{$seg}{Inv}
+# ->{BoOb}{Kind} 'pt' 'sense' 'reverse' 'waggle'
+# ->{BoOb}{Board}
+# ->{BoOb}{Obj}
+# ->{BoOb}{Indiv} for `indiv' board objects like wagglers
+# $segs{$seg}{InvBoOb}
# $segs{$seg}{BoOb}
# $segs{$seg}{Posns}
-# $segs{$seg}{FeatCount} does not include Fixed
-# $segs{$seg}{Feats}{$pt}{Kind} Point or Fixed
-# $segs{$seg}{Feats}{$pt}{Weight} ) for Point only
-# $segs{$seg}{Feats}{$pt}{Posns} ) for Point only
-# $segs{$seg}{Feats}{$pt}{BoOb}[] ) for Point only
-# $segs{$seg}{Feats}{$pt}{Fixed} position, for Fixed only
-# $segs{$seg}{Inter}{Seg} ) calculated
-# $segs{$seg}{Inter}{Map} ) in writeout
+# $segs{$seg}{FeatCount} does not include Fixed
+# $segs{$seg}{Feats}{$feat}{Kind} Point, Fixed, or Relay
+# $segs{$seg}{Feats}{$feat}{Weight} ) for Point or Relay only
+# $segs{$seg}{Feats}{$feat}{Posns} ) for Point or Relay only
+# $segs{$seg}{Feats}{$feat}{BoObs}[] ) for Point or Relay only
+# $segs{$seg}{Feats}{$feat}{Fixed} position, for Fixed only
+# $segs{$seg}{Inter}{Seg} ) calculated
+# $segs{$seg}{Inter}{Map} ) in writeout
# $segs{$seg}{Num}
# $segs{$seg}{Ends}[$combpos][$end] = [ $node,$side ]
# $nodes{$node}[$side]{End}
our ($maxptixln2) = 5;
+our ($maxwaggleixln2) = 4;
our ($nextboardnum,@boardtype,@sensesin,$maxreverseobjnum);
our (@reversersboardnum,@sensesbase,@objkinds,%pin_used);
# $pin_used{$objkind}[$objnum] = [ $boardnum, $pin_info, $objonboard ]
$nextboardnum= 0;
$sensesin[0]= 0;
-@objkinds= qw(pt sense reverse);
+@objkinds= qw(pt sense reverse waggle);
-our (%kind_count,%pin_info); # from BOARD.pin-info
+our (%kind_count,%pin_info,%pin_info_indiv); # from BOARD.pin-info
our ($mode,$invertible);
$mode= 'barf';
print STDERR "info: ditching $m\n";
}
+sub seg_wiring ($$$) {
+ my ($seg,$feat,$hash) = @_;
+ mistake("unknown wiring for $seg in $seg/$feat")
+ unless exists $segs{$seg};
+ mistake("duplicate wiring for $seg/$feat")
+ if exists $segs{$seg}{Feats}{$feat};
+ if (exists $hash->{Posns}) {
+ $hash->{Weight}= $segs{$seg}{Posns};
+ $segs{$seg}{Posns} *= 2;
+ $segs{$seg}{FeatCount}++;
+ }
+ $segs{$seg}{Feats}{$feat}= $hash;
+}
+
sub begin_points () { }
sub line_points () {
- my ($seg,$pt,@boob,$bodef);
+ my ($seg,$pt,@boobstr,$bodef);
m,^\s+(\w+)/([A-Za-z]+)\s+((\d+)\.\d+)\s+(\d*\.\d+)$, or
return syntaxerror();
- ($seg,$pt,$boob[0],$bodef,$boob[1])=($1,$2,$3,$4,$5);
- $boob[1] =~ s/^\./$bodef./;
- mistake("unknown wiring for $seg in $seg/$pt") unless exists $segs{$seg};
- mistake("duplicate wiring for $seg/$pt") if exists $segs{$seg}{Feats}{$pt};
- $segs{$seg}{Feats}{$pt}= {
+ ($seg,$pt,$boobstr[0],$bodef,$boobstr[1])=($1,$2,$3,$4,$5);
+ $boobstr[1] =~ s/^\./$bodef./;
+ seg_wiring($seg,$pt, {
Kind => Point,
- Weight => $segs{$seg}{Posns},
Posns => 2,
- BoOb => [ map { pa_boob($_) } @boob ]
- };
- $segs{$seg}{Posns} *= 2;
- $segs{$seg}{FeatCount}++;
-}
+ BoObs => [ map { pa_boob('pt',$_) } @boobstr ],
+ });
+}
+
+sub begin_relays () { }
+sub line_relays () {
+ my ($seg,$rly,$waggle);
+ m,^\s+(\w+)/([A-Za-z]+)\s+([1-9]\d*|0)\.(\w+)$, or return syntaxerror();
+ ($seg,$rly)= ($1,$2);
+ $waggle= { Kind => 'waggle', Board => $3, Indiv => $4 };
+ seg_wiring($seg,$rly, {
+ Kind => Relay,
+ Posns => 2,
+ BoObs => [ $waggle ],
+ });
+}
sub begin_fixed () { }
sub line_fixed () {
- my ($seg,$pt,$pos);
+ my ($seg,$feat,$pos);
m,^\s+(\w+)/([A-Za-z]+)(\d+)$, or return syntaxerror();
- ($seg,$pt,$pos)=($1,$2,$3);
- mistake("unknown wiring for $seg in $seg/$pt") unless exists $segs{$seg};
- mistake("duplicate fixed $seg/$pt") if exists $segs{$seg}{Feats}{$pt};
- $segs{$seg}{Feats}{$pt}= {
+ ($seg,$feat,$pos)=($1,$2,$3);
+ seg_wiring($seg,$feat, {
Kind => Fixed,
- Fixed => $pos
- };
+ Fixed => $pos,
+ });
}
sub begin_segment () { }
sub line_segment () {
- my ($seg,$boob);
+ my ($seg,$boobstr,$boob);
m/^\s+(\w+)\s+(\d+\.\d+)$/ or return syntaxerror();
- ($seg,$boob)=($1,$2);
+ ($seg,$boobstr)=($1,$2);
mistake("duplicate topology for $seg") if exists $segs{$seg};
- $boob= pa_boob($boob);
+ $boob= pa_boob('sense', $boobstr);
$segs{$seg}= {
BoOb => $boob,
- Inv => $invertible,
+ InvBoOb => $invertible ? { Kind => 'reverse',
+ Board => $boob->{Board},
+ Obj => $boob->{Obj} } : undef,
Posns => 1,
Feats => { },
FeatCount => 0
sub line_segment_vanilla ($) { }
sub line_segment_invertible ($) {
my ($boob) = @_;
- $reversersboardnum[$boob->[0]]= -1;
+ $reversersboardnum[ $boob->{Board} ]= -1;
}
sub begin_interferences () {
print STDOUT $_[0] or die $!;
}
-sub pa_boob ($) {
- my ($boob) = @_;
- if ($boob !~ m/^([1-9]\d*|0)\.([1-9]\d*|0)$/) {
- mistake("invalid board object $boob");
- return [ 0,0 ];
+sub pa_boob ($$) {
+ my ($kind,$str) = @_;
+ if ($str !~ m/^([1-9]\d*|0)\.([1-9]\d*|0)$/) {
+ mistake("invalid board object $str");
+ return { Kind => $kind, Board => 0, Obj => 0 };
}
- return [ $1,$2 ];
+ return { Kind => $kind, Board => $1, Obj => $2 };
}
-# boob2objnum_KIND($boardnum,$objnum,$boardtype,$mkused
+# boob2objnum_KIND($boob,$boardnum,$objnum,$boardtype,$mkused ...)
# -> global object number
+sub boob2objnum_waggle {
+ my ($boob,$boardnum,$objnum) = @_;
+ mistake("waggle encoding out of range") if
+ $boardnum >= (1 << (9 - $maxwaggleixln2));
+ die if $objnum >= (1 << $maxwaggleixln2);
+ return ($boardnum << ($maxwaggleixln2+1)) | $objnum;
+}
+
sub boob2objnum_pt {
- my ($boardnum,$obj)=@_;
+ my ($boob,$boardnum,$obj)=@_;
mistake("point encoding out of range") if
$boardnum >= (1 << (10 - $maxptixln2));
die if $obj >= (1 << $maxptixln2);
}
sub boob2objnum_reverse {
- my ($orgboardnum,$obj,$boardtype)=@_;
+ my ($boob,$orgboardnum,$obj,$boardtype)=@_;
# Converts board and object number (in canonical pic number plus
# and reverse0...reverse5 as seen on pinout diagrams), to the
# segment number for POLARITY command numbered as shown in
}
sub boob2objnum_sense {
- my ($boardnum,$obj)=@_;
+ my ($boob,$boardnum,$obj)= @_;
my $type= $boardtype[$boardnum];
my $bitnum= $sensepermute{$type}[$obj];
die "$type $obj ($boardnum)" unless defined $bitnum;
return $base+$bitnum;
}
-sub boob2objnum ($$$$) {
- my ($boardnum,$obj,$kind,$mkused) = @_;
- my ($type);
+sub boob2objnum ($$) {
+ my ($mkused,$boob) = @_;
+ my ($kind,$boardnum,$type);
+ $kind= $boob->{Kind};
+ $boardnum= $boob->{Board};
+#use Data::Dumper;
+#print STDERR "boob2objnum($mkused, ", Dumper($boob), " )\n";
$type= $boardtype[$boardnum];
- return &{"boob2objnum_$kind"}($boardnum,$obj,$type,$mkused);
+ return &{"boob2objnum_$kind"}
+ ($boob, $boardnum, $boob->{Obj}, $type, $mkused);
}
-sub boob_used ($$$) {
- my ($boardnum,$obj,$kind) = @_;
+sub boob_used ($) {
+ my ($boob) = @_;
my ($objnum);
- $objnum= boob2objnum($boardnum, $obj, $kind, 0);
- return $pin_used{$kind}[$objnum];
+ $objnum= boob2objnum(0, $boob);
+ return $pin_used{$boob->{Kind}}[$objnum];
}
-sub boob_used_bit ($$$) {
- my ($boardnum,$obj,$kind) = @_;
- return defined boob_used($boardnum,$obj,$kind) ? 1 : 0;
+sub boob_used_bit ($) {
+ my ($boob) = @_;
+ return defined boob_used($boob) ? 1 : 0;
}
-sub so_boob ($$$;$) {
- my ($kind,$mkused,$bo, $objnum_rr) = @_;
- my ($type,$pi);
+sub boardtype ($) {
+ my ($board)=@_;
+#print STDERR ">$board<\n";
+ mistake("unknown board number $board") unless defined $boardtype[$board];
+ return $boardtype[$board];
+}
+
+sub kind2genkind ($) {
+ my ($k) = @_;
+ return 'indiv' if $k eq 'waggle';
+ return $k;
+}
+
+sub boob2genkind ($) {
+ my ($boob) = @_;
+ return kind2genkind($boob->{Kind});
+}
+
+sub so_boob ($$;$) {
+ my ($mkused,$bo, $objnum_rr) = @_;
+ my ($type,$objnum,$pi,$genkind);
if (defined $bo) {
- my ($board,$obj)= @$bo;
- my ($objnum,$type,$pi);
- mistake("unknown board number $board")
- unless defined $boardtype[$board];
- $type= $boardtype[$board];
- $pi= $pin_info{$type}{$kind};
- mistake("object reference $kind $board.$obj out of range for".
- " board type $type")
+ my ($kind,$board,$obj) = map { $bo->{$_} } qw(Kind Board Obj);
+#print STDERR "so_boob >$kind|$board$obj<\n";
+ $genkind= boob2genkind($bo);
+#print STDERR "so_boob >$board|$obj<\n";
+ $type= boardtype($board);
+ $pi= $pin_info{$type}{$genkind};
+ mistake("object reference $genkind ($kind) $board.$obj out of range".
+ " for board type $type")
unless defined $pi->[$obj];
- $objnum= boob2objnum($board,$obj,$kind,$mkused);
+print STDERR "so_boob >$kind|$board $obj|$pi->[$obj]<\n" if $kind eq 'waggle';
+ $objnum= boob2objnum($mkused,$bo);
#print "so_boob >$objnum_rr|$$objnum_rr< = $objnum\n";
$$objnum_rr= $objnum;
$pin_used{$kind}[$objnum]= [ $board, $pi->[$obj], $obj ]
}
}
-sub so_objboob ($$$;$) {
- my ($kind,$mkused,$obj, $objnum_rr) = @_;
- return so_boob($kind,$mkused,
- defined $obj ? $obj->{BoOb} : undef,
+sub so_objboob ($$;$) {
+ my ($mkused,$obj,$objnum_rr) = @_;
+ return so_boob($mkused, defined $obj ? $obj->{BoOb} : undef,
$objnum_rr);
}
s/\s+$//;
next unless m/\S/;
last if m/^end$/;
- if (m/^(invertible|vanilla|points|fixed|endwiring|boards|interferences)$/) {
+ if (m/^(invertible|vanilla|points|relays|fixed|endwiring|boards|interferences)$/) {
$mode= $1;
$invertible= ($mode eq 'invertible');
$mode= 'segment' if $mode =~ m/^(?:vanilla|invertible)$/;
}
}
+sub redact_indir ($$) {
+ my ($r, $what)= @_;
+#use Data::Dumper;
+#print STDERR "redact ", Dumper($r), "\n";
+ return unless exists $r->{Indiv};
+ my ($board,$indiv);
+ $board= $r->{Board};
+ $indiv= $r->{Indiv};
+#print STDERR "redact >$board|$indiv<\n";
+ my $boardtype= boardtype($board);
+ mistake("unknown pin name $boardtype.$indiv for $what")
+ unless defined $pin_info_indiv{$boardtype}{$indiv};
+ $r->{Obj}= $pin_info_indiv{$boardtype}{$indiv};
+}
+
sub redaction () {
my ($num,$mappednum,$i,$objnum);
$maxreverseobjnum= 0;
die if $reversersboardnum[$num] != -1;
$reversersboardnum[$num]= $mappednum;
for ($i=0; $i<6; $i++) {
- $objnum= boob2objnum($mappednum,$i,'reverse',0);
+ $objnum= boob2objnum(0, { Kind => 'reverse',
+ Board => $num,
+ Obj => $i });
$maxreverseobjnum= $objnum+1 if $objnum >= $maxreverseobjnum;
}
$mappednum++;
}
+ my ($seg,$segr,$feat,$featr,$board,$indir,$boardtype);
+ foreach $seg (keys %segs) {
+ $segr= $segs{$seg};
+ foreach $feat (keys %{ $segr->{Feats} }) {
+ $featr= $segr->{Feats}{$feat};
+ map {
+ redact_indir($_,"segment $featr->{Kind} $seg/$feat");
+ } @{ $featr->{BoObs} };
+ }
+ }
}
sub nummap ($) {
}
sub writeout () {
- my (@segs,$segn,$seg,$segr,$pt,$ptv, $delim);
- my ($comb,$pi,$feat,$featr,$end,$boob);
+ my (@segs,$segn,$seg,$segr,$feat,$featv, $delim);
+ my ($comb,$pi,$end,$boob);
my ($node,$side,$otherend,$nodeotherside,$otherseg,$otherbackrelus);
my ($ourinter,$pcname,$intere,$intother);
o("/* autogenerated - do not edit */\n\n");
for ($comb=0; $comb < $segr->{Posns}; $comb++) {
$pi='';
foreach $feat (keys %{ $segr->{Feats} }) {
- $featr= $segr->{Feats}{$feat};
- next if exists $featr->{Fixed};
+ $featv= $segr->{Feats}{$feat};
+ next if exists $featv->{Fixed};
$pi.= sprintf("%s%d", $feat,
- ($comb / $featr->{Weight}) % $featr->{Posns});
+ ($comb / $featv->{Weight}) % $featv->{Posns});
}
o("$delim\n");
o(sprintf " { %-7s%4d, { ",
next unless $segr->{FeatCount};
- for $pt (keys %{ $segr->{Feats} }) {
- $ptv= $segr->{Feats}{$pt};
- next if exists $ptv->{Fixed};
- o("static const BoardObject mfbo_${seg}_${pt}"."[]= {");
+ for $feat (keys %{ $segr->{Feats} }) {
+ $featv= $segr->{Feats}{$feat};
+ next if exists $featv->{Fixed};
+ o("static const BoardObject mfbo_${seg}_${feat}"."[]= {");
$delim=' ';
- foreach $boob (@{ $ptv->{BoOb} }) {
+ foreach $boob (@{ $featv->{BoObs} }) {
o($delim);
- o(so_boob('pt',1, $boob));
+ o(so_boob(1, $boob));
$delim= ', ';
}
o(" };\n");
o("static const MovFeatInfo mfi_${seg}"."[]= {");
$delim='';
- for $pt (keys %{ $segr->{Feats} }) {
- $ptv= $segr->{Feats}{$pt};
- next if exists $ptv->{Fixed};
+ for $feat (keys %{ $segr->{Feats} }) {
+ $featv= $segr->{Feats}{$feat};
+ next if exists $featv->{Fixed};
o("$delim\n");
- o(" { \"$pt\", mfk_".lc($ptv->{Kind}).",".
- " $ptv->{Posns}, $ptv->{Weight}, mfbo_${seg}_$pt }");
+ o(" { \"$feat\", mfk_".lc($featv->{Kind}).",".
+ " $featv->{Posns}, $featv->{Weight}, mfbo_${seg}_$feat }");
$delim=',';
}
o("\n};\n");
$segr= $segs{$seg};
o("$delim\n");
o(sprintf " { %-7s%d,%d,%2d,%-9s%d,%-10s%-6s,%-7s",
- "\"$seg\",",$segr->{Inv},$segr->{Inter}{Invert},
+ "\"$seg\",",$segr->{InvBoOb}?1:0,$segr->{Inter}{Invert},
$segr->{FeatCount}, ($segr->{FeatCount} ? "mfi_$seg," : '0,'),
$segr->{Posns}, "spci_$seg,",
- so_objboob('sense',1, $segr, \$sensenum),
- so_objboob('reverse',1, $segr->{Inv} ? $segr : undef).',');
+ so_objboob(1, $segr, \$sensenum),
+ so_boob(1, $segr->{InvBoOb}).',');
$ourinter= $segr->{Inter};
if (defined $ourinter->{Seg}) {
o(sprintf "%4s,0%o ", so_segnum($ourinter->{Seg}),
o_section_end_fill($num, 0, 2);
}
-sub writeasm_pt {
+sub writeasm_pt ($$) { writeasm_ptwag('pt',$maxptixln2); }
+sub writeasm_waggle ($$) { writeasm_ptwag('waggle',$maxwaggleixln2); }
+sub writeasm_ptwag ($$) {
+ my ($ptwag, $maxthingixln2) = @_;
+ my $bitmapbitsperpic= 1<<$maxthingixln2;
+ my $bitmapbytesperpic= 1<<($maxthingixln2-3);
my ($num, $elemsize, $byte, $bit, $objnum);
- o_section('picno2ptmap',<<'END');
-; Bitmap indexed first by pic no, and then by point no. on that board,
-; saying whether the point is present or not. Each pic has 4 bytes,
-; ie 32 bits. First byte is points 0 to 7, in bits 0 to 7 respectively
-; so that MSbit of byte 3 (4th byte) is point no.31. Unused boards
-; or boards with no points are all-bits-0.
+ o_section("picno2${ptwag}map",<<"END");
+; Bitmap indexed first by pic no, and then by thing no. on that board,
+; saying whether the thing is present or not. Each pic has
+; $bitmapbytesperpic bytes, ie $bitmapbitsperpic bits. First byte is
+; objects 0 to 7, in bits 0 to 7 respectively so that MSbit of byte 3
+; (4th byte) is object no.31. Unused boards or boards with no such
+; objects are all-bits-0.
END
for ($num=0; $num<@boardtype; $num++) {
if (!defined $boardtype[$num]) { o(" dw 0\t\t\t\t; $num"); next; }
- die if $maxptixln2 < 4; # must be whole no. of 16-bit words
- $elemsize= 1 << ($maxptixln2-3);
+ die if $maxthingixln2 < 4; # must be whole no. of 16-bit words
+ $elemsize= $bitmapbytesperpic;
for ($byte=0; $byte < $elemsize; $byte++) {
o_db($byte, 0);
o("b'");
for ($bit=7; $bit>=0; $bit--) {
- o(boob_used_bit($num, $byte*8 + $bit, 'pt'));
+ o(boob_used_bit({ Kind => $ptwag,
+ Board => $num,
+ Obj => $byte*8 + $bit }));
}
o("'");
}
o("\n");
o_section_end_fill($num, 0, $elemsize);
- my($typeix,$type,$pt,$pi);
- o_section('bkptix2portnumbitnum',<<"END");
-; Table giving physical ports and pins for points for each
-; kind of board. Index is point number (for reversers boards)
-; or point number + 2^$maxptixln2 (for detectors boards).
+ my ($typeix,$type,$pi,$indexpr);
+ $indexpr= '0'x(7-$maxthingixln2). 'D'. 'o'x$maxthingixln2;
+ o_section("bk${ptwag}ix2portnumbitnum",<<"END");
+; Table giving physical ports and pins for points/wagglers for each
+; kind of board. Index is object number (for reversers boards)
+; or object number + 2^$maxthingixln2 (for detectors boards).
; Value is one byte, either 0xff meaning that board type has
-; no such point, or top nybble being port number (0 for A, 1 for B,
+; no such object, or top nybble being port number (0 for A, 1 for B,
; etc.) and bottom nybble being bit number. Ie,
-; Index: 00Dppppp where D is 1 iff detectors board and p is pt ix
+; Index: $indexpr where D is 1 iff detectors board and o is obj
; Value: 0ppp0bbb where p is port num and b is bit num; or 0xff
END
o(" radix hex\n");
$type= qw(reversers detectors)[$typeix];
die $type unless $pin_info{$type};
o("; $type:");
- for ($pt=0; $pt < (1 << $maxptixln2); $pt++) {
- o_db($pt);
- $pi= $pin_info{$type}{'pt'}[$pt];
+ for ($objnum=0; $objnum < (1 << $maxthingixln2); $objnum++) {
+ o_db($objnum);
+ $pi= $pin_info{$type}{kind2genkind($ptwag)}[$objnum];
if (defined $pi) {
$pi =~ m/^(\d)\,(\d)\,/ or die;
o($1.$2);
@portae= ([],[]);
$kc= $kind_count{$boardtype[$num]}{'reverse'};
for ($bit= $kc-1; $bit>=0; $bit--) {
- $pu= boob_used($num, $bit, 'reverse');
+ $pu= boob_used({ Board => $num,
+ Obj => $bit,
+ Kind => 'reverse' });
next unless $pu;
$pu->[1] =~ m/^([04])\,\d,(0x\w{2})$/ or die;
push @{ $portae[!!$1] }, $2;
~ijackson / trains.git / commitdiff