576 lines
13 KiB
Perl
576 lines
13 KiB
Perl
# $Id: SparseMap.pm,v 1.1 2003/06/04 00:27:53 marka Exp $
|
|
#
|
|
# Copyright (c) 2001 Japan Network Information Center. All rights reserved.
|
|
#
|
|
# By using this file, you agree to the terms and conditions set forth bellow.
|
|
#
|
|
# LICENSE TERMS AND CONDITIONS
|
|
#
|
|
# The following License Terms and Conditions apply, unless a different
|
|
# license is obtained from Japan Network Information Center ("JPNIC"),
|
|
# a Japanese association, Kokusai-Kougyou-Kanda Bldg 6F, 2-3-4 Uchi-Kanda,
|
|
# Chiyoda-ku, Tokyo 101-0047, Japan.
|
|
#
|
|
# 1. Use, Modification and Redistribution (including distribution of any
|
|
# modified or derived work) in source and/or binary forms is permitted
|
|
# under this License Terms and Conditions.
|
|
#
|
|
# 2. Redistribution of source code must retain the copyright notices as they
|
|
# appear in each source code file, this License Terms and Conditions.
|
|
#
|
|
# 3. Redistribution in binary form must reproduce the Copyright Notice,
|
|
# this License Terms and Conditions, in the documentation and/or other
|
|
# materials provided with the distribution. For the purposes of binary
|
|
# distribution the "Copyright Notice" refers to the following language:
|
|
# "Copyright (c) 2000-2002 Japan Network Information Center. All rights reserved."
|
|
#
|
|
# 4. The name of JPNIC may not be used to endorse or promote products
|
|
# derived from this Software without specific prior written approval of
|
|
# JPNIC.
|
|
#
|
|
# 5. Disclaimer/Limitation of Liability: THIS SOFTWARE IS PROVIDED BY JPNIC
|
|
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
|
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
|
|
# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL JPNIC BE LIABLE
|
|
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
|
|
# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
|
# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
|
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
|
# ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
|
|
#
|
|
|
|
package SparseMap;
|
|
|
|
use strict;
|
|
use Carp;
|
|
|
|
my $debug = 0;
|
|
|
|
sub new {
|
|
# common options are:
|
|
# BITS => [8, 7, 6], # 3-level map, 2nd level bits=7, 3rd = 6.
|
|
# MAX => 0x110000 # actually, max + 1.
|
|
my $class = shift;
|
|
my $self = {@_};
|
|
|
|
croak "BITS unspecified" unless exists $self->{BITS};
|
|
croak "BITS is not an array reference"
|
|
unless ref($self->{BITS}) eq 'ARRAY';
|
|
croak "MAX unspecified" unless exists $self->{MAX};
|
|
|
|
$self->{MAXLV} = @{$self->{BITS}} - 1;
|
|
$self->{FIXED} = 0;
|
|
|
|
my $lv0size = (indices($self, $self->{MAX} - 1))[0] + 1;
|
|
|
|
my @map = (undef) x $lv0size;
|
|
$self->{MAP} = \@map;
|
|
|
|
bless $self, $class;
|
|
}
|
|
|
|
sub add1 {
|
|
my ($self, $n, $val) = @_;
|
|
|
|
croak "Already fixed" if $self->{FIXED};
|
|
carp("data ($n) out of range"), return if $n >= $self->{MAX};
|
|
|
|
my @index = $self->indices($n);
|
|
my $r = $self->{MAP};
|
|
my $maxlv = $self->{MAXLV};
|
|
my $idx;
|
|
my $lv;
|
|
|
|
for ($lv = 0; $lv < $maxlv - 1; $lv++) {
|
|
$idx = $index[$lv];
|
|
$r->[$idx] = $self->create_imap($lv + 1, undef)
|
|
unless defined $r->[$idx];
|
|
$r = $r->[$idx];
|
|
}
|
|
$idx = $index[$lv];
|
|
$r->[$idx] = $self->create_dmap() unless defined $r->[$idx];
|
|
$self->add_to_dmap($r->[$idx], $index[$maxlv], $val);
|
|
}
|
|
|
|
sub fix {
|
|
my $self = shift;
|
|
my $map = $self->{MAP};
|
|
my $maxlv = $self->{MAXLV};
|
|
my @tmp;
|
|
my @zero;
|
|
|
|
carp "Already fixed" if $self->{FIXED};
|
|
$self->collapse_tree();
|
|
$self->fill_default();
|
|
$self->{FIXED} = 1;
|
|
}
|
|
|
|
sub indices {
|
|
my $self = shift;
|
|
my $v = shift;
|
|
my @bits = @{$self->{BITS}};
|
|
my @idx;
|
|
|
|
print "indices($v,", join(',', @bits), ") = " if $debug;
|
|
for (my $i = @bits - 1; $i >= 0; $i--) {
|
|
my $bit = $bits[$i];
|
|
unshift @idx, $v & ((1 << $bit) - 1);
|
|
$v = $v >> $bit;
|
|
}
|
|
print "(", join(',', @idx), ")\n" if $debug;
|
|
@idx;
|
|
}
|
|
|
|
sub get {
|
|
my $self = shift;
|
|
my $v = shift;
|
|
my $map = $self->{MAP};
|
|
my @index = $self->indices($v);
|
|
|
|
croak "Not yet fixed" unless $self->{FIXED};
|
|
|
|
my $lastidx = pop @index;
|
|
foreach my $idx (@index) {
|
|
return $map->{DEFAULT} unless defined $map->[$idx];
|
|
$map = $map->[$idx];
|
|
}
|
|
$map->[$lastidx];
|
|
}
|
|
|
|
sub indirectmap {
|
|
my $self = shift;
|
|
|
|
croak "Not yet fixed" unless $self->{FIXED};
|
|
|
|
my @maps = $self->collect_maps();
|
|
my $maxlv = $self->{MAXLV};
|
|
my @bits = @{$self->{BITS}};
|
|
|
|
my @indirect = ();
|
|
for (my $lv = 0; $lv < $maxlv; $lv++) {
|
|
my $offset;
|
|
my $chunksz;
|
|
my $mapsz = @{$maps[$lv]->[0]};
|
|
if ($lv < $maxlv - 1) {
|
|
# indirect map
|
|
$offset = @indirect + @{$maps[$lv]} * @{$maps[$lv]->[0]};
|
|
$chunksz = (1 << $bits[$lv + 1]);
|
|
} else {
|
|
# direct map
|
|
$offset = 0;
|
|
$chunksz = 1;
|
|
}
|
|
my $nextmaps = $maps[$lv + 1];
|
|
foreach my $mapref (@{$maps[$lv]}) {
|
|
croak "mapsize inconsistent ", scalar(@$mapref),
|
|
" should be ", $mapsz, " (lv $lv)\n" if @$mapref != $mapsz;
|
|
foreach my $m (@$mapref) {
|
|
my $idx;
|
|
for ($idx = 0; $idx < @$nextmaps; $idx++) {
|
|
last if $nextmaps->[$idx] == $m;
|
|
}
|
|
croak "internal error: map corrupted" if $idx >= @$nextmaps;
|
|
push @indirect, $offset + $chunksz * $idx;
|
|
}
|
|
}
|
|
}
|
|
@indirect;
|
|
}
|
|
|
|
sub cprog_imap {
|
|
my $self = shift;
|
|
my %opt = @_;
|
|
my $name = $opt{NAME} || 'map';
|
|
my @indirect = $self->indirectmap();
|
|
my $prog;
|
|
my $i;
|
|
my ($idtype, $idcol, $idwid);
|
|
|
|
my $max = 0;
|
|
$max < $_ and $max = $_ foreach @indirect;
|
|
|
|
if ($max < 256) {
|
|
$idtype = 'char';
|
|
$idcol = 8;
|
|
$idwid = 3;
|
|
} elsif ($max < 65536) {
|
|
$idtype = 'short';
|
|
$idcol = 8;
|
|
$idwid = 5;
|
|
} else {
|
|
$idtype = 'long';
|
|
$idcol = 4;
|
|
$idwid = 10;
|
|
}
|
|
$prog = "static const unsigned $idtype ${name}_imap[] = {\n";
|
|
$i = 0;
|
|
foreach my $v (@indirect) {
|
|
if ($i % $idcol == 0) {
|
|
$prog .= "\n" if $i != 0;
|
|
$prog .= "\t";
|
|
}
|
|
$prog .= sprintf "%${idwid}d, ", $v;
|
|
$i++;
|
|
}
|
|
$prog .= "\n};\n";
|
|
$prog;
|
|
}
|
|
|
|
sub cprog {
|
|
my $self = shift;
|
|
$self->cprog_imap(@_) . "\n" . $self->cprog_dmap(@_);
|
|
}
|
|
|
|
sub stat {
|
|
my $self = shift;
|
|
my @maps = $self->collect_maps();
|
|
my $elsize = $self->{ELSIZE};
|
|
my $i;
|
|
my $total = 0;
|
|
my @lines;
|
|
|
|
for ($i = 0; $i < $self->{MAXLV}; $i++) {
|
|
my $nmaps = @{$maps[$i]};
|
|
my $mapsz = @{$maps[$i]->[0]};
|
|
push @lines, "level $i: $nmaps maps (size $mapsz) ";
|
|
push @lines, "[", $nmaps * $mapsz * $elsize, "]" if $elsize;
|
|
push @lines, "\n";
|
|
}
|
|
my $ndmaps = @{$maps[$i]};
|
|
push @lines, "level $i: $ndmaps dmaps";
|
|
my $r = $maps[$i]->[0];
|
|
if (ref($r) eq 'ARRAY') {
|
|
push @lines, " (size ", scalar(@$r), ")";
|
|
}
|
|
push @lines, "\n";
|
|
join '', @lines;
|
|
}
|
|
|
|
sub collapse_tree {
|
|
my $self = shift;
|
|
my @tmp;
|
|
|
|
$self->_collapse_tree_rec($self->{MAP}, 0, \@tmp);
|
|
}
|
|
|
|
sub _collapse_tree_rec {
|
|
my ($self, $r, $lv, $refs) = @_;
|
|
my $ref = $refs->[$lv];
|
|
my $maxlv = $self->{MAXLV};
|
|
my $found;
|
|
|
|
return $r unless defined $r;
|
|
|
|
$ref = $refs->[$lv] = [] unless defined $ref;
|
|
|
|
if ($lv == $maxlv) {
|
|
$found = $self->find_dmap($ref, $r);
|
|
} else {
|
|
for (my $i = 0; $i < @$r; $i++) {
|
|
$r->[$i] = $self->_collapse_tree_rec($r->[$i], $lv + 1, $refs);
|
|
}
|
|
$found = $self->find_imap($ref, $r);
|
|
}
|
|
unless ($found) {
|
|
$found = $r;
|
|
push @$ref, $found;
|
|
}
|
|
return $found;
|
|
}
|
|
|
|
sub fill_default {
|
|
my $self = shift;
|
|
my $maxlv = $self->{MAXLV};
|
|
my $bits = $self->{BITS};
|
|
my @zeros;
|
|
|
|
$zeros[$maxlv] = $self->create_dmap();
|
|
for (my $lv = $maxlv - 1; $lv >= 0; $lv--) {
|
|
my $r = $zeros[$lv + 1];
|
|
$zeros[$lv] = $self->create_imap($lv, $r);
|
|
}
|
|
_fill_default_rec($self->{MAP}, 0, $maxlv, \@zeros);
|
|
}
|
|
|
|
sub _fill_default_rec {
|
|
my ($r, $lv, $maxlv, $zeros) = @_;
|
|
|
|
return if $lv == $maxlv;
|
|
for (my $i = 0; $i < @$r; $i++) {
|
|
if (defined($r->[$i])) {
|
|
_fill_default_rec($r->[$i], $lv + 1, $maxlv, $zeros);
|
|
} else {
|
|
$r->[$i] = $zeros->[$lv + 1];
|
|
}
|
|
}
|
|
}
|
|
|
|
sub create_imap {
|
|
my ($self, $lv, $v) = @_;
|
|
my @map;
|
|
@map = ($v) x (1 << $self->{BITS}->[$lv]);
|
|
\@map;
|
|
}
|
|
|
|
sub find_imap {
|
|
my ($self, $maps, $map) = @_;
|
|
my $i;
|
|
|
|
foreach my $el (@$maps) {
|
|
next unless @$el == @$map;
|
|
for ($i = 0; $i < @$el; $i++) {
|
|
last unless ($el->[$i] || 0) == ($map->[$i] || 0);
|
|
}
|
|
return $el if $i >= @$el;
|
|
}
|
|
undef;
|
|
}
|
|
|
|
sub collect_maps {
|
|
my $self = shift;
|
|
my @maps;
|
|
_collect_maps_rec($self->{MAP}, 0, $self->{MAXLV}, \@maps);
|
|
@maps;
|
|
}
|
|
|
|
sub _collect_maps_rec {
|
|
my ($r, $lv, $maxlv, $maps) = @_;
|
|
my $mapref = $maps->[$lv];
|
|
|
|
return unless defined $r;
|
|
foreach my $ref (@{$mapref}) {
|
|
return if $ref == $r;
|
|
}
|
|
push @{$maps->[$lv]}, $r;
|
|
if ($lv < $maxlv) {
|
|
_collect_maps_rec($_, $lv + 1, $maxlv, $maps) foreach @{$r};
|
|
}
|
|
}
|
|
|
|
sub add {confess "Subclass responsibility";}
|
|
sub create_dmap {confess "Subclass responsibility";}
|
|
sub add_to_dmap {confess "Subclass responsibility";}
|
|
sub find_dmap {confess "Subclass responsibility";}
|
|
sub cprog_dmap {confess "Subclass responsibility";}
|
|
|
|
1;
|
|
|
|
package SparseMap::Bit;
|
|
|
|
use strict;
|
|
use vars qw(@ISA);
|
|
use Carp;
|
|
#use SparseMap;
|
|
|
|
@ISA = qw(SparseMap);
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $self = $class->SUPER::new(@_);
|
|
$self->{DEFAULT} = 0;
|
|
bless $self, $class;
|
|
}
|
|
|
|
sub add {
|
|
my $self = shift;
|
|
|
|
$self->add1($_, undef) foreach @_;
|
|
}
|
|
|
|
sub create_dmap {
|
|
my $self = shift;
|
|
my $bmbits = $self->{BITS}->[-1];
|
|
|
|
my $s = "\0" x (1 << ($bmbits - 3));
|
|
\$s;
|
|
}
|
|
|
|
sub add_to_dmap {
|
|
my ($self, $map, $idx, $val) = @_;
|
|
vec($$map, $idx, 1) = 1;
|
|
}
|
|
|
|
sub find_dmap {
|
|
my ($self, $ref, $r) = @_;
|
|
foreach my $map (@$ref) {
|
|
return $map if $$map eq $$r;
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub cprog_dmap {
|
|
my $self = shift;
|
|
my %opt = @_;
|
|
my $name = $opt{NAME} || 'map';
|
|
my @maps = $self->collect_maps();
|
|
my @bitmap = @{$maps[-1]};
|
|
my $prog;
|
|
my $bmsize = 1 << ($self->{BITS}->[-1] - 3);
|
|
|
|
$prog = <<"END";
|
|
static const struct {
|
|
unsigned char bm[$bmsize];
|
|
} ${name}_bitmap[] = {
|
|
END
|
|
|
|
foreach my $bm (@bitmap) {
|
|
my $i = 0;
|
|
$prog .= "\t{{\n";
|
|
foreach my $v (unpack 'C*', $$bm) {
|
|
if ($i % 16 == 0) {
|
|
$prog .= "\n" if $i != 0;
|
|
$prog .= "\t";
|
|
}
|
|
$prog .= sprintf "%3d,", $v;
|
|
$i++;
|
|
}
|
|
$prog .= "\n\t}},\n";
|
|
}
|
|
$prog .= "};\n";
|
|
$prog;
|
|
}
|
|
|
|
1;
|
|
|
|
package SparseMap::Int;
|
|
|
|
use strict;
|
|
use vars qw(@ISA);
|
|
use Carp;
|
|
#use SparseMap;
|
|
|
|
@ISA = qw(SparseMap);
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $self = $class->SUPER::new(@_);
|
|
$self->{DEFAULT} = 0 unless exists $self->{DEFAULT};
|
|
bless $self, $class;
|
|
}
|
|
|
|
sub add {
|
|
my $self = shift;
|
|
while (@_ > 0) {
|
|
my $n = shift;
|
|
my $val = shift;
|
|
$self->add1($n, $val);
|
|
}
|
|
}
|
|
|
|
sub create_dmap {
|
|
my $self = shift;
|
|
my $tblbits = $self->{BITS}->[-1];
|
|
my $default = $self->{DEFAULT};
|
|
|
|
my @tbl = ($default) x (1 << $tblbits);
|
|
\@tbl;
|
|
}
|
|
|
|
sub add_to_dmap {
|
|
my ($self, $map, $idx, $val) = @_;
|
|
$map->[$idx] = $val;
|
|
}
|
|
|
|
sub find_dmap {
|
|
my ($self, $ref, $r) = @_;
|
|
foreach my $map (@$ref) {
|
|
if (@$map == @$r) {
|
|
my $i;
|
|
for ($i = 0; $i < @$map; $i++) {
|
|
last if $map->[$i] != $r->[$i];
|
|
}
|
|
return $map if $i == @$map;
|
|
}
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub cprog_dmap {
|
|
my $self = shift;
|
|
my %opt = @_;
|
|
my $name = $opt{NAME} || 'map';
|
|
my @maps = $self->collect_maps();
|
|
my @table = @{$maps[-1]};
|
|
my $prog;
|
|
my $i;
|
|
my ($idtype, $idcol, $idwid);
|
|
my $tblsize = 1 << $self->{BITS}->[-1];
|
|
|
|
my ($min, $max);
|
|
foreach my $a (@table) {
|
|
foreach my $v (@$a) {
|
|
$min = $v if !defined($min) or $min > $v;
|
|
$max = $v if !defined($max) or $max < $v;
|
|
}
|
|
}
|
|
if (exists $opt{MAPTYPE}) {
|
|
$idtype = $opt{MAPTYPE};
|
|
} else {
|
|
my $u = $min < 0 ? '' : 'unsigned ';
|
|
my $absmax = abs($max);
|
|
$absmax = abs($min) if abs($min) > $absmax;
|
|
|
|
if ($absmax < 256) {
|
|
$idtype = "${u}char";
|
|
} elsif ($absmax < 65536) {
|
|
$idtype = "${u}short";
|
|
} else {
|
|
$idtype = "${u}long";
|
|
}
|
|
}
|
|
|
|
$idwid = decimalwidth($max);
|
|
$idwid = decimalwidth($min) if decimalwidth($min) > $idwid;
|
|
|
|
$prog = <<"END";
|
|
static const struct {
|
|
$idtype tbl[$tblsize];
|
|
} ${name}_table[] = {
|
|
END
|
|
|
|
foreach my $a (@table) {
|
|
my $i = 0;
|
|
my $col = 0;
|
|
$prog .= "\t{{\n\t";
|
|
foreach my $v (@$a) {
|
|
my $s = sprintf "%${idwid}d, ", $v;
|
|
$col += length($s);
|
|
if ($col > 70) {
|
|
$prog .= "\n\t";
|
|
$col = length($s);
|
|
}
|
|
$prog .= $s;
|
|
}
|
|
$prog .= "\n\t}},\n";
|
|
}
|
|
$prog .= "};\n";
|
|
$prog;
|
|
}
|
|
|
|
sub decimalwidth {
|
|
my $n = shift;
|
|
my $neg = 0;
|
|
my $w;
|
|
|
|
if ($n < 0) {
|
|
$neg = 1;
|
|
$n = -$n;
|
|
}
|
|
if ($n < 100) {
|
|
$w = 2;
|
|
} elsif ($n < 10000) {
|
|
$w = 4;
|
|
} elsif ($n < 1000000) {
|
|
$w = 6;
|
|
} elsif ($n < 100000000) {
|
|
$w = 8;
|
|
} else {
|
|
$w = 10;
|
|
}
|
|
$w + $neg;
|
|
}
|
|
|
|
1;
|