• Publicidad

Comprobar varios elementos de un array

Así que programas sin strict y las expresiones regulares son otro modo de hablar. Aquí encontrarás respuestas de nivel avanzado, no recomendable para los débiles de corazón.

Comprobar varios elementos de un array

Notapor merentah » 2008-10-16 04:50 @243

Hola, tengo un código en que un array (@h2) tiene una serie de elementos que a su vez contienen un array de direcciones de memoria. Ahora quiero recorrer todo el array y eliminar todo elemento cuyas direcciones de memoria ya estén incluidas en otro elemento. Por ejemplo, si tengo el elemento: d1, d2, d3 y otro elemento d1,d3.
Este segundo quiero que lo elimine, porque ya está incluido en el primero. Y si tengo otro que sea: d1, d2, d3, d4 quiero que elimine el primero ya que ese primero está incluido en este último.
El caso es que lo he implementado con grep() (código de abajo) y el script va superlento cuando tengo muchos elementos. ¿Se os ocurre otra estrategia para resolver el problema?
Gracias por adelantado,

Iam.

Sintáxis: [ Descargar ] [ Ocultar ]
Using perl Syntax Highlighting
# 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;
Coloreado en 0.002 segundos, usando GeSHi 1.0.8.4
Avatar de Usuario
merentah
Perlero nuevo
Perlero nuevo
 
Mensajes: 5
Registrado: 2008-10-16 04:39 @235

Publicidad

Notapor kidd » 2008-10-16 08:03 @377

Bienvenido a los foros de Perl en Español, merentah.

En vez de usar la función grep(), podrías usar un hash para llevar control de qué elementos ya se han visto:

Sintáxis: [ Descargar ] [ Ocultar ]
Using perl Syntax Highlighting
# 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;
    }
}
Coloreado en 0.001 segundos, usando GeSHi 1.0.8.4
Uriel Lizama Perl programmer fundador de Perl en Español
Perl Programming Language
Avatar de Usuario
kidd
Creador de Perl en Español
Creador de Perl en Español
 
Mensajes: 1166
Registrado: 2003-10-15 16:52 @744
Ubicación: México

Notapor merentah » 2008-10-16 09:02 @418

El problema es que elementos individuales sí que pueden repetirse, pero no colecciones completas. Por ejemplo, si ya he cogido la colección d1, d2, d3, esta otra colección ya no la quiero: d1, d2. Sin embargo, esta otra sí: d1, d2, d4.
Avatar de Usuario
merentah
Perlero nuevo
Perlero nuevo
 
Mensajes: 5
Registrado: 2008-10-16 04:39 @235

Notapor salva » 2008-10-16 10:45 @489

Aquí va un algoritmo que permite hacer lo que tu quieres, aunque tendrás que adaptarlo para que funcione con tu tipo de datos específico:

Sintáxis: [ Descargar ] [ Ocultar ]
Using perl Syntax Highlighting
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;
Coloreado en 0.001 segundos, usando GeSHi 1.0.8.4


La complejidad del algoritmo es O(N^2), no se me ocurre otra forma más eficiente de hacerlo
Avatar de Usuario
salva
Perlero nuevo
Perlero nuevo
 
Mensajes: 200
Registrado: 2008-01-03 15:19 @680

Notapor salva » 2008-10-16 11:07 @505

Otra implementación que cambia el orden en el que las repeticiones son descartadas y que es más eficiente.

En el peor caso sigue siendo O(N^2) pero para casos con alto número de repeticiones tiende a O(N):

Sintáxis: [ Descargar ] [ Ocultar ]
Using perl Syntax Highlighting
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;
Coloreado en 0.001 segundos, usando GeSHi 1.0.8.4


Actualización: si tus conjuntos se pueden representar como una cadena de bits (por ejemplo, si son enteros pequeños), entonces, el algoritmo se podría hacer aun más eficaz usando esa representación y operaciones booleanas para comprobar cuándo un conjunto es subconjunto de otro.
Última edición por salva el 2008-10-16 11:36 @525, editado 1 vez en total
Avatar de Usuario
salva
Perlero nuevo
Perlero nuevo
 
Mensajes: 200
Registrado: 2008-01-03 15:19 @680

Notapor explorer » 2008-10-16 11:17 @512

Yo he usado teorí­a de conjuntos
Sintáxis: [ Descargar ] [ Ocultar ]
Using perl Syntax Highlighting
#!/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;
Coloreado en 0.002 segundos, usando GeSHi 1.0.8.4
Sale:
Código: Seleccionar todo
(d1 d2)
        (d2 d3 d5) ->
        (d1 d3 d4) ->
        (d1 d2) -> (d1 d2)<=
(d1 d2 d3)
        (d2 d3 d5) ->
        (d1 d3 d4) ->
        (d1 d2) -> (d1 d2 d3)+
        (d1 d5) ->
(d1 d2 d4)
        (d2 d3 d5) ->
        (d1 d3 d4) ->
        (d1 d2 d3) ->
        (d1 d5) ->
                +(d1 d2 d4)
(d1 d2 d3 d4)
        (d2 d3 d5) ->
        (d1 d3 d4) -> (d1 d2 d3 d4)+
        (d1 d2 d3) -> ><
        (d1 d5) ->
        (d1 d2 d4) -> ><
(d1)
        (d2 d3 d5) ->
        (d1 d2 d3 d4) -> (d1)<=
@w = (
       [
         'd2',
         'd3',
         'd5'
       ],
       [
         'd1',
         'd2',
         'd3',
         'd4'
       ],
       [
         'd1',
         'd5'
       ]
     );
El programa va sustituyendo los conjuntos con los superconjuntos que va encontrando. Si un elemento no está, se agrega.

Actualización: Ya encontré la forma de eliminar los conjuntos de @w que son subconjuntos de otros. Ahora ya sale la solución mínima. Y salen ordenados con la adición del sort().

Actualización: Volviendo a leer el problema, ahora me surge la duda de si merentah se refería a un solo array o a dos, porque en el código suyo he visto dos. Bueno, da igual, se hace @h2 = @w al principio, y listo.
JF^D Perl programming & Raku programming. Grupo en Telegram: https://t.me/Perl_ES
Avatar de Usuario
explorer
Administrador
Administrador
 
Mensajes: 14480
Registrado: 2005-07-24 18:12 @800
Ubicación: Valladolid, España

Notapor merentah » 2008-10-17 11:34 @524

Muchas gracias, este fin de semana lo intento adaptar y ya os cuento. Aunque llevo años programando en Perl, no soy informático y hay funciones como map() que no estoy habituado a usar. Además, lo de los conjuntos me ha gustado y voy a probarlo también.
Realmente utilizo un sólo array, lo que pasa es que desde el inicial (h2) creo el segundo (w) para quedarme con los conjuntos no redundantes.
Un saludo y gracias de nuevo,

Iam.
Avatar de Usuario
merentah
Perlero nuevo
Perlero nuevo
 
Mensajes: 5
Registrado: 2008-10-16 04:39 @235

Notapor explorer » 2008-10-17 20:52 @911

¡Ah!, pues si es un solo array, la solución es más sencilla:

Sintáxis: [ Descargar ] [ Ocultar ]
Using perl Syntax Highlighting
#!/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;
Coloreado en 0.001 segundos, usando GeSHi 1.0.8.4
JF^D Perl programming & Raku programming. Grupo en Telegram: https://t.me/Perl_ES
Avatar de Usuario
explorer
Administrador
Administrador
 
Mensajes: 14480
Registrado: 2005-07-24 18:12 @800
Ubicación: Valladolid, España

Notapor merentah » 2008-10-18 11:48 @533

Magnífico, funciona mucho mejor que lo que yo tenía. Ahora sólo me queda entender todo el código. Gracias,

Iam.
Avatar de Usuario
merentah
Perlero nuevo
Perlero nuevo
 
Mensajes: 5
Registrado: 2008-10-16 04:39 @235

Notapor explorer » 2008-10-18 16:49 @742

Hay cosillas ocultas, como lo de usar '<=' y '>', que están siendo sobrecargados por el módulo Set::Scalar.

Y otro detalle es ver que, en situaciones normales, si en un 'if' tenemos una condición '<=', se supone que la alternativa no sería necesario poner otro 'if' para ver si es '>', pero es que en nuestro caso estamos hablando de conjuntos, así que no se trata de comparaciones numéricas, sino diferencias entre conjuntos: si un conjunto no es superconjunto de otro, no implica que sea un subconjunto. Podrían ser disjuntos.

No he visto cómo hace Set::Scalar para realizar su labor, pero sería interesante saber el ratio de mejora de velocidad con respecto a lo tuyo. Y luego ver si puedes probar la solución de salva, usando la opción de las expresiones regulares.
JF^D Perl programming & Raku programming. Grupo en Telegram: https://t.me/Perl_ES
Avatar de Usuario
explorer
Administrador
Administrador
 
Mensajes: 14480
Registrado: 2005-07-24 18:12 @800
Ubicación: Valladolid, España

Siguiente

Volver a Avanzado

¿Quién está conectado?

Usuarios navegando por este Foro: No hay usuarios registrados visitando el Foro y 53 invitados

cron