idnkit-1.0-src/util/SparseMap.pm

# $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;