Foro - Perl en Español

# Check for repeated or inclusive windows
my $repeat = 0;
for (my $i = 0; $i <= $#w; $i++) {
    my $rep = 0;
    foreach my $h2 (@h2) {
        next unless (grep /$h2/, @{$w[$i]});
        $rep++;
    }
    if ($rep == $#h2 + 1) { # for repeated window
        $repeat = 1;
        last;
    } elsif ($rep == $#{$w[$i]} + 1) { # for new window larger than a previous one
        splice (@w, $i, 1);
        next;
    }
}

# Only non-repeated window (good result)
next if ($repeat == 1 || $#h2 < 1);
push @w, \@h2;

# Check for repeated or inclusive windows
my $repeat = 0;

my %seen;

for (my $i = 0; $i <= $#w; $i++) {
    my $rep = 0;

    foreach my $h2 (@h2) {
        next if $seen{$h2};;
        $rep++;
        $seen{$h2} = 1;
    }

    if ($rep == $#h2 + 1) { # for repeated window
        $repeat = 1;
        last;
    } elsif ($rep == $#{$w[$i]} + 1) { # for new window larger than a previous one
        splice (@w, $i, 1);
        next;
    }
}

use Data::Dumper;

# Generamos algunos datos de ejemplo. Nótese que están ordenados, si no
# fuese así, habría que ordenarlos para que el algoritmo funcione.
my @data = map [grep rand > .7, 1..7], 1..25;

# Ordenamos @data por el numero de elementos en cada array.
# En el fondo lo que vamos a comprobar es si un conjunto A es un
# subconjunto de otro B y eso implica que el número de elementos de A
# <= num. elem. de B y así nos ahorramos la mitad de las operaciones.
@data = sort { @$a <=> @$b } @data;

# Convertimos los datos de un array a una cadena de manera que podamos
# procesarla usando regexps:
@data = map join(',', @$_, ''), @data;

print Dumper \@data;

my @unique; # aquí vamos guardando los conjuntos que no son
            # subconjuntos de ningún otro
for (@data) {
    # generamos una expresión regular que nos permite ver si un
    # conjunto es subconjunto de otro
    my @parts = split /,/;
    my $re_str = join '', map '(?:'.quotemeta($_).',)?', @parts;
    my $re = qr/^$re_str$/;
 
   # y la usamos para filtrar los elementos de @unique
    @unique = grep $_ !~ $re, @unique;

    # finalmente añadimos el elemento actual a la lista de conjuntos
    # @unique dado que como es el más grande examinado hasta el
    # momento, no puede ser subconjunto de ningún otro:
    push @unique, $_;
}

print Dumper \@unique;

use Data::Dumper;

my @data = map [grep rand > .7, 1..7], 1..25;
@data = sort { @$a <=> @$b } @data;
@data = map join(',', @$_, ''), @data;

print Dumper \@data;

my @unique;
while (@data) {
    my $top = pop @data;
    unshift @unique, $top;
    my @parts = split /,/, $top;
    my $re_str = join '', map '(?:'.quotemeta($_).',)?', @parts;
    my $re = qr/^$re_str$/;
    @data = grep $_ !~ $re, @data;
}

print Dumper \@unique;

#!/usr/bin/perl
use strict;
use warnings;
use diagnostics;

use Data::Dumper::Names;
use Set::Scalar;

my @w = (
    [ qw(d2 d3 d5) ],
    [ qw(d1 d3 d4) ],
    [ qw(d1 d2   ) ],
    [ qw(d1 d5   ) ],
);

my @h2 = (
    [ qw(d1 d2      ) ],
    [ qw(d1 d2 d3   ) ],
    [ qw(d1 d2 d4   ) ],
    [ qw(d1 d2 d3 d4) ],
    [ qw(d1         ) ],
);

## Convertimos las secuencias originales en objetos
my @w_set
    = map {
            Set::Scalar->new( @$_ )
    } @w
    ;
my @h2_set
    = map {
            Set::Scalar->new( @$_ )
    } @h2
    ;

## Bucle para todo lo nuevo
for my $h2_set (@h2_set) {
    print "$h2_set\n";

    ## Bucle para todo lo viejo
    my $encontrado;
    for my $i (0 .. $#w_set) {
        my $w_set = $w_set[$i];
        print "\t$w_set -> ";

        ## Comparación
        my $comparacion = $h2_set <=> $w_set;

        if ($comparacion eq 'proper superset') {    # Encontrado superconjunto
            if (!$encontrado) {
                $w_set[$i] = $h2_set;                       # Lo sobreescribimos
                print "$h2_set+\n";
                $encontrado=1;
            }
            else {
                delete $w_set[$i];
                print "><\n";
            }
            next;
        }
        elsif ($comparacion eq 'proper subset'      # Encontrado subconjunto
            or $comparacion eq 'equal') {           # o conjuntos iguales
            print "$h2_set<=\n";
            undef $h2_set;                          # Nos lo cargamos
            last;
        }

        print "\n";
    }

    ## Si no hemos encontrado coincidencia, lo agregamos
    if ($h2_set and !$encontrado) {
        push @w_set, $h2_set;
        print "\t\t+$h2_set\n";
    }
}

## Deshacemos
@w =
    grep { $_ }
    map {
            $_ ? [ sort $_->members ] : ''
    } @w_set
    ;

print Dumper \@w;

#!/usr/bin/perl
use strict;
use warnings;
use diagnostics;

use Data::Dumper;
use Set::Scalar;

my @h2 = (
    [ qw(d1 d5      ) ],
    [ qw(d1 d2      ) ],
    [ qw(d1 d2 d3   ) ],
    [ qw(d1 d3 d4   ) ],
    [ qw(d2 d3 d5   ) ],
    [ qw(d1 d2 d4   ) ],
    [ qw(d1 d2 d3 d4) ],
    [ qw(d1         ) ],
);

## Convertimos las secuencias originales en objetos
@h2 = map { Set::Scalar->new( @$_ ) } @h2;

for (my $i = 0; $i < @h2; $i++) {
    my $h2 = $h2[$i] or next;
    print "$h2 ";

    for (my $j = 0; $j < @h2; $j++) {
        my $w = $h2[$j] or next;

        next if $i == $j;

        if ($h2 >= $w) {
            delete $h2[$j];
            print " del $h2 >= $w";
        }
        elsif ($h2 < $w) {
            delete $h2[$i];
            print " del $h2 < $w";
            last;
        }
    }
    print "\n";
}

## Deshacemos
@h2 = map { [ sort $_->members ] } grep { $_ } @h2;
print Dumper \@h2;