Mostrando entradas con la etiqueta Programacion. Mostrar todas las entradas
Mostrando entradas con la etiqueta Programacion. Mostrar todas las entradas

lunes, 7 de marzo de 2016

Programar en un entorno orientado a eventos con Perl

POE, un entorno orientado a eventos

Si ya has programado una aplicación gráfica usando algo como Tk o Gtk, sabrás que es un poco diferente de la programación procedural diaria. En la programación normal, se escribe una secuencia de cosas que quieres que el programa haga y éste lo hace. Sin embargo, en las GUI's no se trabaja de ésta manera. Se setea un entorno (por ejemplo una ventana) que responde a ciertos eventos (un click de un botón o la selección de un ítem en un menú). A eso se le llama Paradigma Orientado a Eventos.
No sólo se usa en GUI's. Por ejemplo, un servidor en una red no realiza una secuencia de eventos, sino que se sienta a esperar una conexión (un evento) y entonces le sirve a esa conexión según el input del cliente. Cuando el cliente termina y se desconecta, el servidor vuelve a esperar por un próximo evento.
En forma similar se podría escribir un script que mira una carpeta; el script se sienta a mirar y periódicamente busca en los archivos de la carpeta, y cuando detecta cambios dispara una respuesta o realiza algunas acciones.
El núcleo del paradigma orientado a eventos es el bucle principal, a veces llamado 'main loop'. Tk tiene uno, el módulo Event tiene uno, y POE, un entorno orientado a eventos, tiene uno. El bucle principal de POE es manejado por el kernel POE.
POE puede ser pensado como un diminuto sistema operativo que tiene un kernel. Cuando el kernel de un sistema operativo termina de asignar los trabajos en su entorno, se sienta a esperar por nuevos eventos. Éstos pueden ser llamadas al sistema desde el espacio del usuario o interrupciones de hardware. Además de manejar eventos se ocupa también del pasaje de mensajes entre los diferentes componentes, típicamente comunicación entre procesos (IPC).
El kernel POE también sirve a eventos y maneja la comunicación entre las diferentes partes del mundo de POE, aunque su equivalente de los procesos son llamados Sessions.

Hola mundo, POE

Mucha charla y nada de código, rectifiquemos con un breve ejemplo:
    #!/usr/bin/perl
    use strict;
    use warnings;
    use POE;
    POE::Session->create(
        inline_states => {
        _start  => \&start,
        hello   => \&hello,
        },
    );

    print "Running Kernel\n";
    $poe_kernel->run(  );
    print "Exiting\n";
    exit(0);

    sub start {
        my ($kernel) = $_[KERNEL];
        print "Setting up a session\n";
        $kernel->yield("hello");
    }

    sub hello { print "Hola Mundo!\n"; }

Este es el equivalente POE del famoso programa Hola Mundo. Si continuamos con la analogía del sistema operativo (una analogía poco útil pero por ahora la usaremos) entonces iniciamos el kernel de la máquina y creamos un único proceso que imprime "Hola Mundo!" y finaliza.

    use POE;
    print "Running Kernel\n";
    $poe_kernel->run(  );
    print "Exiting\n";
    exit(0);

Aquí está el núcleo de cualquier programa POE, la variable $poe_kernel es provista por el módulo POE y representa el kernel mismo. La llamada a run() en muchos casos no retorna nunca, por ejemplo un servidor que espera en un loop por nuevas conexiones. En nuestro caso, sin embargo, sólo seteamos una pequeña sesión que termina en seguida. En códigos más nuevos se prefiere usar POE::Kernel->run(), en vez de la variable global.

    POE::Session->create(
        inline_states => {
        _start  => \&start,
        hello   => \&hello,
        },
    );

En esta parte se crea una sesión. Una sesión puede ser pensada como una máquina de estados con múltiples estados, o como un manejador de múltiples eventos, las dos representaciones son equivalentes. Hablando de estados, el ejemplo anterior define dos estados en el parámetro inline_states que se pasa al constructor. Los estados cuyos nombres empiezan con guión bajo son predefinidos por POE, mientras que los otros son definidos por el usuario. La sesión entra al estado _start automáticamente después de ser construída.
Hablando en términos de eventos, decimos que nuestra sesión responde al evento _start y al evento hello y que POE envía un evento _start a la sesión tan pronto como ésta es creada.
Hay otros eventos predefinidos, la mayoría de ellos son para hacer relaciones padre-hijos y señales. Está el evento _stop que es enviado cuando la sesión debe finalizar. Veamos cómo se define un manejador de eventos:

    sub start {
        my ($kernel) = $_[KERNEL];
        print "Setting up a session\n";
        $kernel->yield("hello");
    }

    sub hello { print "Hola Mundo!\n"; }

Se le pasa a nuestro manejador start() un número de parámetros, uno de los cuales es un manejador del kernel POE. Se extrae éste de la lista de parámetros usando la constante KERNEL. En aras de la eficiencia, POE utiliza constantes para indexar la variable @_ en vez de un parámetro hash. A menudo se verán manejadores que comienzan con algo como esto:

    my ($kernel, $heap, $session) = @_[KERNEL, HEAP, SESSION];

Esto es un ordinario array slice, con índices constantes. Retornan el kernel POE, la heap y el objeto sesión actual. La heap es un lugar donde la sesión puede almacenar su privado stuff. Volveremos a esto para ver qué tipo de stuff es bueno almacenar en la heap más tarde.
Ahora que tenemos el kernel, qué hacemos con él? Bien, le decimos que queremos pasar a otro estado, el estado hello:

    $kernel->yield("hello");

Usamos yield() para enviar un evento a la sesión actual; si tuviéramos almacenada otra sesión, podríamos comunicarnos con ella enviándole un evento usando el método post(). Veremos un ejemplo más adelante.
Por ahora le dijimos al kernel POE que queremos pasar al estado hello. Pero esto no sucederá hasta que POE corra en su bucle de eventos. Una vez que corre en su bucle con $poe_kernel->run(), el kernel mira en su lista de tareas pendientes, encuentra que la primer cosa para hacer es pasar nuestra sesión al estado hello y dispara el manejador apropiado. Entonces se imprime el mensaje "Hola Mundo!".

Hola de nuevo, POE!

Supongamos que ahora queremos repetir el mensaje cada 5 segundos. Podríamos lograrlo:

    sub hello {
        my ($kernel) = $_[KERNEL];
        print "Hola Mundo!\n";
        sleep 5;
        $kernel->yield("hello");
    }

Funciona, pero no es la manera de comportarse en un entorno cooperativo y multitarea. No podemos colgar el kernel entero por 5 segundos porque otras sesiones podrían tener cosas que hacer: por ejemplo en una red que necesita servicios, etc. En vez, permitimos que el kernel maneje el estado hello dentro de 5 segundos en el futuro. Para hacerlo usamos el método delay_set() del kernel:

    sub hello {
        my ($kernel) = $_[KERNEL];
        print "Hola Mundo!\n";
        $kernel->delay_set("hello", 5);
    }

Nota mental: no usar sleep() dentro de POE porque pueden ocurrir situaciones indeseables.
Ahora seremos más amables. Veamos como podemos hacer con dos sesiones diferentes corriendo.
Se trata de un código ligeramente modificado del maravilloso tutorial de POE de Matt Sergeant:

    use POE;

    for my $session_no (1..2) {
      POE::Session->create(

        inline_states => {
          hello => \&hello,
          _start => sub { $_[KERNEL]->alias_set("session_" . $session_no) },
      });
    }

    $poe_kernel->post("session_1", "hello", "session_2");
    $poe_kernel->run(  );
    exit(0);

    sub hello {
      my ($kernel, $session, $next) = @_[KERNEL, SESSION, ARG0];
      print "Event in ", $kernel->alias_list($session), "\n";
      $kernel->post($next, "hello", $session->ID);
    }

Ambas sesiones van ejecutando hello() en forma alternada, y para lograr esto una sesión le pide a la otra que se ejecute y viceversa.
Veamos con más detalle; creamos las sesiones en un bucle (en este caso dos) que tienen un manejador start() y un manejador para el evento hello(). Las sesiones comparten el código para sus dos manejadores, pero los argumentos que se les pasan serán distintos en cada caso.
Esta vez el manejador start() hace algo un poco diferente del script anterior. Le dice al kernel que registre un alias para la sesión actual. Cada sesión tiene un ID interno (que se usa más tarde en el script) pero que solamente conoce POE cuando crea las sesiones. Registrando un alias amigable para el programador nosotros obtenemos una manera para referirnos a la sesión más adelante. Esta vez start() no hace un yield().
Nuevamente para ser amigables con el programador, le pedimos al kernel cuál es el alias de nuestra sesión para mostrarla en un mensaje:

    print "Event in ", $kernel->alias_list($session), "\n";

Ahora que hay más de una sesión necesitamos decirle al kernel cual de ellas comenzará la acción, por eso hacemos un post al evento hello() de la primera sesión, llamándola por su alias. El tercer parámetro es un argumento más del post, en este caso le pasamos el alias de la segunda sesión:

    $poe_kernel->post("session_1", "hello", "session_2");

Cuando hacemos yield() o posteamos eventos, podemos pasar parámetros adicionales al evento, los cuales pasan al manejador del evento. Estos argumentos llegan en la variable @_ comenzando en la posición ARG0. Si tenemos muchos argumentos, podríamos escribir algo como esto para tomarlos a todos:

      my ($kernel, $session, @args) = @_[KERNEL, SESSION, ARG0..$#_];

Pero aquí nos interesa solamente el primer argumento, que es el nombre de la próxima sesión a llamar. La sesión 1 le pasa el control a la sesión 2 y viceversa. Ahora que empieza a correr no necesitamos ser amigables con el programador, entonces identificamos a la sesión por su ID interno:

    $kernel->post($next, "hello", $session->ID);

Está diciendo: "Yo te estoy llamando a tí ahora, y la próxima vez llamame a mí (por mi ID)".
Con estas dos sesiones corriendo, tenemos un entorno cooperativo y multitarea:

    Event in session_1
    Event in session_2
    Event in session_1
    Event in session_2

    ...
Sin embargo, si vamos a hacer algo interesante con este entorno, tenemos que comenzar a mirar qué nos trae POE para más complejas acciones de I/O.

Wheels

Los Wheels son la fuerza de arrastre (ha, ha!) del sistema de I/O de POE. Un wheel es una conexión al mundo exterior que genera los eventos. Miremos los wheels como un equivalente de los manejadores de ficheros, pero son más que eso.
El más simple wheel para entender es POE::Wheel::FollowTail, el cual sigue de cerca a un archivo que está creciendo. Se le pasa un nombre de archivo y el wheel genera eventos cuando el archivo tiene actualizaciones. Veamos un ejemplo cortito:
    use POE qw(Wheel::FollowTail);

    POE::Session->create(
      inline_states => {
         _start => sub {
            my ($heap) = $_[HEAP];
            my $log_watcher = POE::Wheel::FollowTail->new(
                Filename => "my_log_file.txt",
                InputEvent => "got_record",
            );

            $heap->{watcher} = $log_watcher;
         },
         got_record => sub { my $record = $_[ARG0]; print $record,"\n"; }
      }
    );

    $poe_kernel->run(  );

Primero, notemos la forma compacta de cargar múltiples módulos POE; cualquier parámetro pasado a use POE será interpretado como nombres de módulo bajo POE:: y serán usados.
Como antes, tenemos dos estados. El estado got_record es bonito y fácil de enteder: imprime su argumento. Miremos el estado _start con más detalle:

            my $log_watcher = POE::Wheel::FollowTail->new(
                Filename => "my_log_file.txt",
                InputEvent => "got_record",
            );

El trabajo del evento start es setear nuestro wheel. Le decimos que mire al archivo my_log_file.txt y que postee el evento got_record cada vez que vea una nueva línea.
Y qué hacemos con nuestro wheel? Nosotros queremos que el wheel persista por la duración de la sesión sino sería algo inútil, al ser un objeto ordinario de Perl será destruído al finalizar el bloque de ejecución actual sino lo almacenamos en algún lado. Por eso tener un área de almacenamiento por sesión es muy valioso, la heap:

            my ($heap) = $_[HEAP];
            . . .
            $heap->{watcher} = $log_watcher;

Eso es todo lo que necesitamos; el wheel se sienta a mirar el archivo y va generando los eventos, nuestro manejador imprime las líneas que ha visto. Ahora agregaremos otro wheel en la ecuación.
Nota: el script anterior pierde el primer carácter de la línea aunque no sea un "\n"?
Supongamos por alguna razón que nuestro archivo de log es en realidad un log con datos binarios y queremos imprimir las líneas en exadecimal usando el comando hexdump.
Si no tienes el comando hexdump lo puedes imitar creando tu propio script en Perl, como el siguiente y llamarlo hexdump:

my $i = -16;
binmode(STDIN);
my $data; $|++;
printf "%07x ". ("%02x%02x "x8)."\n", $i+=16, map ord, split//,$data
    while read STDIN, $data, 16;

El POE::Wheel::Run manejará I/O apoyado en programas externos. Podemos crear un wheel que llame a hexdump y enviarle los datos que queramos:

    use POE qw(Wheel::FollowTail Wheel::Run);

    POE::Session->create(
      inline_states => {
         _start => sub {
            my ($heap) = $_[HEAP];
            my $log_watcher  = POE::Wheel::FollowTail->new(
                Filename     => "my_log_file.txt",
                InputEvent   => "redirect",
            );
            my $dumper = POE::Wheel::Run->new(
                Program      => "/usr/bin/hexdump",
                StdoutEvent  => "print"
            );

            $heap->{watcher} = $log_watcher;
            $heap->{dumper}  = $dumper;
         },
         redirect => sub {
            my ($heap, $data) = @_[HEAP, ARG0];
            $heap->{dumper}->put($data);
         },

         print => sub { my $record = $_[ARG0]; print $record, "\n"; }
      }
    );
    $poe_kernel->run(  );

Miremos lo que está sucediendo:


El wheel FollowTail obtiene sus datos y los envía a la sesión, la cual los envía al wheel Run, éste genera un evento print e imprime esos datos. Maravilloso.
Excepto que no funciona. Si ejecutamos el programa con el comando hexdump de Linux, todos nuestros datos desaparecen en el éter y nunca los verás de nuevo. Pero hay algo interesante: si usamos el hexdump echo en Perl, el programa trabaja bien. Cómo es posible?
La clave es el mágico $|++ de nuestra versión. El hexdump del sistema almacena toda la salida si siente que está conectado a un pipe. Como nuestro programa nunca termina, hexdump sólo se queda almacenando datos hasta que nosotros cortamos la ejecución, y entonces todo se pierde. Necesitamos que el comando hexdump piense que está conectado con un terminal real. Por supuesto, POE provee una manera para hacer esto:

            my $dumper = POE::Wheel::Run->new(
                Program      => "/usr/bin/hexdump",
                Conduit      => "pty",
                StdoutEvent  => "print"
            );

Hay otros wheels que pueden trabajar juntos como este: POE::Wheel::Curses lee datos usando una librería no bloqueante de interface Curses, mientras que POE::Wheel::ReadLine usa Term::ReadKey para implementar una interface de consola de entrada basada en líneas. POE::Wheel::ListenAccept es un socket de bajo nivel que se queda escuchando. Veremos a continuacón dos de los más importantes wheels en el próximo ejemplo: POE::Wheel::ReadWrite y POE::Wheel::SocketFactory.

Despachador de puertos

Ya sabes. Estás en el trabajo, detrás de un agresivo firewall que no te permite usar el IRC. Y tú no puedes trabajar sin tu IRC, así que realizas una tramolla algo sucia para conectarte. Seteas un reenvío de puerto para que cuando se intenta conectar al puerto 6667 en la máquina local, sea llevado al puerto 80 (el cual está permitido en tu firewall) en tu hosted box en el mundo real. Entonces otro despachador escuchará en el puerto 80 de esa máquina y enviará las conexiones a través del puerto 6667 al servidor IRC. Luego seteas el cliente IRC para que se conecte a localhost y voilà, estás conectado! Veamos como POE puede ayudarte a perder tu empleo.
Comenzaremos seteando un servidor que escuche conexiones:

        my $office = shift;

        my ($local_address, $local_port, $remote_address, $remote_port);
        ($office ? $remote_address : $local_address) = "mybox.real-world.int";
        ($office ? $local_port     : $remote_port)   = 6667;
        ($office ? $remote_port    : $local_port)    = 80;

        if ($office) {
           $local_address = "127.0.0.1";
        } else {
           $remote_address = "irc.perl.org";
        }

        POE::Session->create(
          inline_states => {
           _start => \&server_start,
            client_connected => \&client_connected,
            on_server_error => \&server_error
          },
          args =>
            [ $local_address, $local_port, $remote_address, $remote_port ]
          );
       $poe_kernel->run;

Una vez que sabemos que despachamos desde la oficina a la máquina hosted o desde la máquina hosted a la oficina, seteamos varias direcciones y puertos en la forma apropiada y creamos una nueva sesión con esos parámetros. Esta sesión iniciará todas las sesiones que necesitemos. Como estamos tratando con tres partes que se unen en este reenvío de puertos vamos a necesitar 3 sesiones y 3 wheels.
Omitiremos el manejo de errores para hacer más clara la explicación. Además en caso de error es poco lo que se puede hacer, más que ignorar y esperar que la próxima conexión sea exitosa.
El primer wheel aparece en el estado start() y tiene que escuchar por el puerto y dirección adecuados, utilizaremos el SocketFactory wheel:

    sub server_start {
        my ( $heap, $local_addr, $local_port, $remote_addr, $remote_port )
        = @_[ HEAP, ARG0,        ARG1,        ARG2,         ARG3 ];

        # Store our parameters
        $heap->{local_addr}  = $local_addr;
        $heap->{local_port}  = $local_port;
        $heap->{remote_addr} = $remote_addr;
        $heap->{remote_port} = $remote_port;

        # Create and store a wheel
        $heap->{server_wheel} = POE::Wheel::SocketFactory->new
          ( BindAddress  => $local_addr,
            BindPort     => $local_port,
            Reuse        => 'yes',
            SuccessEvent => 'client_connected',
            FailureEvent => "on_server_error",
          );
    }

Cuando el wheel SocketFactory acepta una conexión y postea un evento cliente_connected(), pasa el socket y el peer address y el puerto así:

    sub client_connected {
        my ( $heap, $socket, $peer_addr, $peer_port ) =
          @_[ HEAP,  ARG0,    ARG1,       ARG2];
    }

Ahora tenemos un servidor que escucha y acpeta conexiones, pero que hacemos una vez que acepta una? Por lo común, una aplicación no POE, probablemente haría un fork o un hilo para servir el requerimiento y luego volvería a escuchar por nuevas conexiones. En cambio en POE, creamos una nueva sesión para manejar al cliente. Recuerden que hemos almacenado los parámetros de nuestra conexión en la heap de la primera sesión, entonces podemos pasárselos a la nueva sesión:

    sub accept {
        my ( $heap, $socket, $peer_addr, $peer_port ) =
          @_[ HEAP,  ARG0,    ARG1,       ARG2];

        POE::Session->new
          ( _start => \&forwarder_start,
            server_connect => \&connected_to_other_side,
            client_input   => \&forward_outbound,
            server_input   => \&forward_inbound,

            [ $socket, $peer_addr, $peer_port,
              $heap->{remote_addr}, $heap->{remote_port} ]
          );
    }

Cuando esta sesión inicia necesita configurar la conexión con el destino y estar listo para leer y escribir datos desde el cliente. Hacemos esto pasando al cliente $socket que recibimos para nuestro segundo wheel, POE::Wheel::ReadWrite, un wheel genérico de I/O de POE. Igual que en un entorno no POE, nosotros reusamos el socket que tenemos para manejar la conexión como lo hacemos con un filehandle para leer y escribir archivos.
Paremos un momento para mirar el siguiente diagrama:

Hasta ahora nos hemos ocupado del cliente que ha contactado con nosotros; también queremos otro wheel para conectar con el servidor en el otro extremo del túnel de reenvío:

    sub forwarder_start {
        my ( $heap, $session,
            $socket, $peer_host, $peer_port, $remote_addr, $remote_port
          ) =
          @_[ HEAP, SESSION, ARG0, ARG1, ARG2, ARG3, ARG4 ];

        ($heap->{peer_host}, $heap->{peer_port}, 
    $heap->{remote_addr}, $heap->{remote_port})=
                  ($peer_host, $peer_port, $remote_addr, $remote_port);

        $heap->{wheel_client} = POE::Wheel::ReadWrite->new
          ( Handle => $socket,
            Filter     => POE::Filter::Stream->new,
            InputEvent => 'client_input',
          );

        $heap->{wheel_server} = POE::Wheel::SocketFactory->new

          ( RemoteAddress => $remote_addr,
            RemotePort   => $remote_port,
            SuccessEvent => 'server_connect',
          );
    }

Hay un pequeño detalle; desde que intentamos ser lo más asincrónicos posible, tenemos que tener en cuenta el caso en que aún está estableciéndose la conexión con el servidor, pero ya tenemos datos enviados por el cliente. Agregaremos una cola para almacenar cualquier dato que tengamos antes de establecer la conexión:

        $heap->{state} = 'connecting';
        $heap->{queue} = [  ];

Ahora veamos qué sucede cuando los datos llegan del cliente. Si aún esperamos la conexión, los ponemos en cola. En otro caso los enviamos a través del otro wheel al servidor:

    sub forward_outbound {
        my ( $heap, $input ) = @_[ HEAP, ARG0 ];

        if ( $heap->{state} eq 'connecting' ) {
            push @{ $heap->{queue} }, $input;
        }
        else {
            $heap->{wheel_server}->put($input);
        }
    }

Una vez que hemos seteado la conexión con el otro lado, necesitamos hacer lo mismo de nuevo y colocar el socket en nuestro tercer wheel, otro ReadWrite wheel.

    sub connected_to_other_side {
        my ( $kernel, $session, $heap, $socket ) = @_[ KERNEL, SESSION,
    HEAP, ARG0
    ];

        $heap->{wheel_server} = POE::Wheel::ReadWrite->new
          ( Handle => $socket,
            Driver     => POE::Driver::SysRW->new,
            Filter     => POE::Filter::Stream->new,
            InputEvent => 'server_input',
          );
    }

Ahora podemos desencolar la cola en caso de que tenga datos pendientes:

        $heap->{state} = 'connected';
        foreach my $pending ( @{ $heap->{queue} } ) {
            $kernel->call( $session, 'client_input', $pending );
        }
        $heap->{queue} = [  ];

Por cada porción de datos que recibimos, posteamos los datos de regreso al evento client_input; sin embargo, esta vez no seguimos conectados, y el evento pasa los datos al servidor.
Finalmente, necesitamos mover los datos recibidos desde el servidor hacia el tunel al cliente, completando la función forward_inbound:

    my ( $heap, $input ) = @_[ HEAP, ARG0 ];
    $heap->{wheel_client}->put($input);

Miremos el diagrama final del despachador entero antes de pensar en cómo hacerlo más simple:

Sobre este tutorial

Se trata de una traducción libre del original "Programming in an Event-Driven Environment" escrito por Simon Cozens.



domingo, 31 de enero de 2016

Manejar archivos CSV con SQL

Como vimos anteriormente, los archivos CSV representan datos en forma de tabla. Las filas están separadas por saltos de línea y las columnas están separadas por comas o por punto y comas. Hoy vamos a usar el módulo DBI para acceder a los datos de estos archivos. El conjunto de herramientas DBI es una interfaz de acceso a distintas bases de datos, incluidas Oracle, Mysql y otros sistemas relacionales. La interfaz básica para consultar y actualizar la base de datos es el lenguaje SQL. El módulo DBI proporciona instrucciones SQL al módulo DBD::CSV, que a su vez pasa el control a otro módulo de interpretación de SQL.

Objetivo

Supongamos un sistema utilizado para registrar las consultas médicas. Una consulta médica tiene un archivo pacientes.csv con los datos personales de sus pacientes. Cada línea del archivo tiene el rut, el nombre y la edad de un paciente, separados por un símbolo ;. Así se ve el archivo:

12067539-7;Lorena López;32
15007265-4;Saúl Morales;26
8509454-8;Diego Muñoz;45
7752666-8;Gabriel Navarro;49
8015253-1;Darío Pacheco;51
9217890-0;Aldo Pimienta;39
9487280-4;Juan Rosas;42
12393241-2;Felipe Rubio;33
11426761-9;Samanta Pérez;35
15690109-1;José Ruiz;26
6092377-9;Alfonso Iúdica;65
9023365-3;Nancy Toledo;38
10985778-5;Tomás Valdés;38
13314970-8;Adán Vázquez;30
7295601-k;Wilson Muñoz;60
5106360-0;Alejandra Vega;71
8654231-5;Andrés Dib;55
10105321-0;Antonio Cabalgante;31
13087677-3;Walter Álvarez;28
9184011-1;Soledad Andrade;47
12028339-1;Jorge Bogado;29
10523653-0;Francisca Avaria;40
12187197-1;Felipe Mañas;36
5935556-2;Pablo Barriga;80
14350739-4;Eduardo Velo;29
6951420-0;Oscar Benítez;68
11370775-5;Hugo Leguizamón;31
11111756-k;Cristóbal Colón;34

Además, cada vez que alguien se atiende en la consulta, la visita es registrada en el archivo atenciones.csv, agregando una línea que tiene el rut del paciente, la fecha de la visita (en formato dia-mes-año) y el precio de la atención, también separados por ;. El archivo se ve así:

8015253-1;4-5-2016;69580
12393241-2;6-5-2016;57274
10985778-5;8-5-2016;73206
8015253-1;10-5-2016;30796
8015253-1;12-5-2016;47048
12028339-1;12-5-2016;47927
11426761-9;13-5-2016;39117
10985778-5;15-5-2016;86209
7752666-8;18-5-2016;41916
8015253-1;18-5-2016;74101
12187197-1;20-5-2016;38909
8654231-5;20-5-2016;75018
8654231-5;22-5-2016;64944
5106360-0;24-5-2016;53341
8015253-1;27-5-2016;76047
9217890-0;30-5-2016;57726
7752666-8;1-6-2016;54987
8509454-8;2-6-2016;76483
6092377-9;2-6-2016;62106
11370775-5;3-6-2016;67035
11370775-5;7-6-2016;47299
8509454-8;7-6-2016;73254
8509454-8;10-6-2016;82955
11111756-k;10-6-2016;56520
7752666-8;10-6-2016;40820
12028339-1;12-6-2016;79237
11111756-k;13-6-2016;69094
5935556-2;14-6-2016;73174
11111756-k;21-6-2016;70417
11426761-9;22-6-2016;80217
12067539-7;25-6-2016;31555
11370775-5;26-6-2016;75796
10523653-0;26-6-2016;34585
6951420-0;28-6-2016;45433
5106360-0;1-7-2016;48445
8654231-5;4-7-2016;76458

Note que las fechas están ordenadas de menos reciente a más reciente, ya que las nuevas líneas siempre se van agregando al final.

  • Escriba una función costo_total_paciente(rut) que entregue el costo total de las atenciones del paciente con el rut dado:

>>>Calcular el costo total del paciente 
Por favor, ingrese rut del paciente: 8015253-1
Costo total del paciente: 297572 

>>>Calcular el costo total del paciente 
Por favor, ingrese rut del paciente: 14350739-4
Costo total del paciente: 0


  • Escriba una función pacientes_dia(dia, mes, ano) que entregue una lista con los nombres de los pacientes que se atendieron el día señalado:

>>> Pacientes que se atendieron en una fecha dada
Por favor, ingrese el dia: 2
Por favor, ingrese el mes: 6
Por favor, ingrese el año: 2016
['Diego Muñoz', 'Alfonso Iúdica']
>>> Pacientes que se atendieron en una fecha dada
Por favor, ingrese el dia: 23
Por favor, ingrese el mes: 6
Por favor, ingrese el año: 2016
[]

  • Escriba una función pacientes_menores(edad) que construya un archivo CSV con los pacientes con edad <= a la edad dada.
Por ejemplo, el archivo jovenes.csv debe verse así:

>>>Pacientes menores a una edad dada
Por favor, ingrese la edad: 30
>>>jovenes.csv 
15007265-4;"Saúl Morales";26
15690109-1;"José Ruiz";26
13314970-8;"Adán Vázquez";30
13087677-3;"Walter Álvarez";28
12028339-1;"Jorge Bogado";29
14350739-4;"Eduardo Velo";29


Solución en Perl


#!/usr/bin/perl
use strict;
use warnings;
use DBI;
use Data::Dumper;
 
# el costo total de las atenciones del paciente con el rut dado
sub costo_total_paciente{
  my $rut= shift; 
  # conectamos 
  my $dbh= DBI->connect('DBI:CSV:');
  my $tabla= 'atenciones.csv';
  # seteamos el atributo sep_char para que use el separador ; en vez de ,
  $dbh->{csv_sep_char}= ";";
  # describimos los nombres de las columnas del archivo atenciones.csv
  $dbh->{csv_tables}{$tabla} = {
        col_names => [qw( rut fecha costo )]
        };
  # ejecutamos la consulta como un comando SQL
  my $query= "SELECT sum(costo) as costo_total FROM $tabla WHERE rut='$rut'";
  my $sth  = $dbh->prepare($query);
  $sth->execute();
  my $row = $sth->fetchrow_hashref;
  my $costo_total= 0;
  if ($row->{costo_total}){ $costo_total= $row->{costo_total}; }
  $sth->finish();
  return $costo_total;
}

print "Calcular el costo total del paciente \n";
print "Por favor, ingrese rut del paciente: ";
my $rut = <stdin>;
chomp($rut);
my $costo_total= costo_total_paciente($rut);
print "Costo total del paciente: $costo_total \n";

# listar los nombres de los pacientes que se atendieron el día dado
sub pacientes_dia{
  my ($dia, $mes, $anio)= @_;
  # conectamos 
  my $dbh= DBI->connect('DBI:CSV:');
  # seteamos el atributo sep_char para que use el separador ; en vez de ,
  $dbh->{csv_sep_char}= ";";
  # describimos los nombres de las columnas del archivo atenciones.csv
  my $atenciones= 'atenciones.csv';
  $dbh->{csv_tables}{$atenciones} = {
        col_names => [qw( rut fecha costo )]
        };
  # describimos los nombres de las columnas del archivo pacientes.csv
  my $pacientes= 'pacientes.csv';
  $dbh->{csv_tables}{$pacientes} = {
        col_names => [qw( rut nombre edad )]
        };
  # ejecutamos la consulta como un comando SQL
  my $fecha= join('-',$dia,$mes,$anio);
  my $query= "SELECT distinct rut FROM $atenciones WHERE fecha like '$fecha%'";
  my $sth  = $dbh->prepare($query);
  $sth->execute();
  while ( my $row = $sth->fetchrow_hashref ) {
    $query= "SELECT nombre FROM $pacientes WHERE rut='$row->{rut}'";
    my $sth2= $dbh->prepare($query);
    $sth2->execute();
    my $row2= $sth2->fetchrow_hashref;
    print $row2->{nombre} . "\n";
    $sth2->finish();
  }
  $sth->finish();
  return;
}

print "Pacientes que se atendieron en una fecha dada\n";
print "Por favor, ingrese el dia: ";
my $dia = <stdin>;
chomp($dia);
print "Por favor, ingrese el mes: ";
my $mes = <stdin>;
chomp($mes);
print "Por favor, ingrese el año: ";
my $anio = <stdin>;
chomp($anio);
pacientes_dia($dia, $mes, $anio);


# generar un archivo jovenes.csv con los datos de los pacientes menores a cierta edad dada
sub pacientes_menores{
  my $edad= shift;
  # conectamos 
  my $dbh= DBI->connect('DBI:CSV:');
  # seteamos el atributo sep_char para que use el separador ; en vez de ,
  $dbh->{csv_sep_char}= ";";
  # describimos los nombres de las columnas del archivo atenciones.csv
  my $pacientes= 'pacientes.csv';
  $dbh->{csv_tables}{$pacientes} = {
        col_names => [qw( rut nombre edad )]
        };
  # creamos la nueva tabla de menores
  my $jovenes= 'jovenes.csv';
  $dbh->do("CREATE TABLE $jovenes (rut CHAR(12), nombre CHAR(50), edad CHAR(3))")
  || die "No se pudo crear la tabla " . $dbh->errstr();
  # ejecutamos la consulta como un comando SQL
  my $query= "SELECT * FROM $pacientes WHERE edad < '$edad'";
  my $sth  = $dbh->prepare($query);
  $sth->execute();
  while ( my $row = $sth->fetchrow_hashref ) {
    $dbh->do("INSERT INTO $jovenes VALUES (".
      $dbh->quote($row->{rut}) . "," .
      $dbh->quote($row->{nombre}) . "," .
      $dbh->quote($row->{edad}) . ")")
      || die "No puedo insertar un registro, " . $dbh->errstr();
  }
  $sth->finish();
  
  return;
}

print "Pacientes menores a una edad dada\n";
print "Por favor, ingrese la edad: ";
my $edad = <stdin>;
chomp($edad);
pacientes_menores($edad);

viernes, 15 de enero de 2016

Archivos de texto CSV en Perl

Los archivos CSV representan datos en forma de tabla. Las filas están separadas por saltos de línea y las columnas están separadas por comas o por punto y comas.

Objetivo

Supongamos un sistema utilizado para registrar las consultas médicas. Una consulta médica tiene un archivo pacientes.csv con los datos personales de sus pacientes. Cada línea del archivo tiene el rut, el nombre y la edad de un paciente, separados por un símbolo ;. Así se ve el archivo:

12067539-7;Lorena López;32
15007265-4;Saúl Morales;26
8509454-8;Diego Muñoz;45
7752666-8;Gabriel Navarro;49
8015253-1;Darío Pacheco;51
9217890-0;Aldo Pimienta;39
9487280-4;Juan Rosas;42
12393241-2;Felipe Rubio;33
11426761-9;Samanta Pérez;35
15690109-1;José Ruiz;26
6092377-9;Alfonso Iúdica;65
9023365-3;Nancy Toledo;38
10985778-5;Tomás Valdés;38
13314970-8;Adán Vázquez;30
7295601-k;Wilson Muñoz;60
5106360-0;Alejandra Vega;71
8654231-5;Andrés Dib;55
10105321-0;Antonio Cabalgante;31
13087677-3;Walter Álvarez;28
9184011-1;Soledad Andrade;47
12028339-1;Jorge Bogado;29
10523653-0;Francisca Avaria;40
12187197-1;Felipe Mañas;36
5935556-2;Pablo Barriga;80
14350739-4;Eduardo Velo;29
6951420-0;Oscar Benítez;68
11370775-5;Hugo Leguizamón;31
11111756-k;Cristóbal Colón;34

Además, cada vez que alguien se atiende en la consulta, la visita es registrada en el archivo atenciones.csv, agregando una línea que tiene el rut del paciente, la fecha de la visita (en formato dia-mes-año) y el precio de la atención, también separados por ;. El archivo se ve así:

8015253-1;4-5-2016;69580
12393241-2;6-5-2016;57274
10985778-5;8-5-2016;73206
8015253-1;10-5-2016;30796
8015253-1;12-5-2016;47048
12028339-1;12-5-2016;47927
11426761-9;13-5-2016;39117
10985778-5;15-5-2016;86209
7752666-8;18-5-2016;41916
8015253-1;18-5-2016;74101
12187197-1;20-5-2016;38909
8654231-5;20-5-2016;75018
8654231-5;22-5-2016;64944
5106360-0;24-5-2016;53341
8015253-1;27-5-2016;76047
9217890-0;30-5-2016;57726
7752666-8;1-6-2016;54987
8509454-8;2-6-2016;76483
6092377-9;2-6-2016;62106
11370775-5;3-6-2016;67035
11370775-5;7-6-2016;47299
8509454-8;7-6-2016;73254
8509454-8;10-6-2016;82955
11111756-k;10-6-2016;56520
7752666-8;10-6-2016;40820
12028339-1;12-6-2016;79237
11111756-k;13-6-2016;69094
5935556-2;14-6-2016;73174
11111756-k;21-6-2016;70417
11426761-9;22-6-2016;80217
12067539-7;25-6-2016;31555
11370775-5;26-6-2016;75796
10523653-0;26-6-2016;34585
6951420-0;28-6-2016;45433
5106360-0;1-7-2016;48445
8654231-5;4-7-2016;76458

Note que las fechas están ordenadas de menos reciente a más reciente, ya que las nuevas líneas siempre se van agregando al final.

  • Escriba una función costo_total_paciente(rut) que entregue el costo total de las atenciones del paciente con el rut dado:

>>>Calcular el costo total del paciente 
Por favor, ingrese rut del paciente: 8015253-1
Costo total del paciente: 297572 

>>>Calcular el costo total del paciente 
Por favor, ingrese rut del paciente: 14350739-4
Costo total del paciente: 0


  • Escriba una función pacientes_dia(dia, mes, ano) que entregue una lista con los nombres de los pacientes que se atendieron el día señalado:

>>> Pacientes que se atendieron en una fecha dada
Por favor, ingrese el dia: 2
Por favor, ingrese el mes: 6
Por favor, ingrese el año: 2016
['Diego Muñoz', 'Alfonso Iúdica']
>>> Pacientes que se atendieron en una fecha dada
Por favor, ingrese el dia: 23
Por favor, ingrese el mes: 6
Por favor, ingrese el año: 2016
[]

  • Escriba una función pacientes_menores(edad) que construya un archivo CSV con los pacientes con edad <= a la edad dada.
Por ejemplo, el archivo jovenes.csv debe verse así:

>>>Pacientes menores a una edad dada
Por favor, ingrese la edad: 30
>>>jovenes.csv 
15007265-4;"Saúl Morales";26
15690109-1;"José Ruiz";26
13314970-8;"Adán Vázquez";30
13087677-3;"Walter Álvarez";28
12028339-1;"Jorge Bogado";29
14350739-4;"Eduardo Velo";29


Solución en Perl


#!/usr/bin/perl
use strict;
use warnings;
use Text::CSV;

print "Calcular el costo total del paciente \n";
print "Por favor, ingrese rut del paciente: ";
my $rut = <stdin>;
chomp($rut);
my $costo_total= costo_total_paciente($rut);
print "Costo total del paciente: $costo_total \n";

print "Pacientes que se atendieron en una fecha dada\n";
print "Por favor, ingrese el dia: ";
my $dia = <stdin>;
chomp($dia);
print "Por favor, ingrese el mes: ";
my $mes = <stdin>;
chomp($mes);
print "Por favor, ingrese el año: ";
my $anio = <stdin>;
chomp($anio);
pacientes_dia($dia, $mes, $anio);

print "Pacientes menores a una edad dada\n";
print "Por favor, ingrese la edad: ";
my $edad = <stdin>;
chomp($edad);
pacientes_menores($edad);

# el costo total de las atenciones del paciente con el rut dado
sub costo_total_paciente{
  my $rut= shift; 
  # seteamos el atributo sep_char para que use el separador ; en vez de ,
  # seteamos el atributo binary para acentos y eñes
  my $csv = Text::CSV->new ( { sep_char => ';', binary => 1 } )  
  or die "No puedo usar CSV: ".Text::CSV->error_diag ();

  my $costo_total= 0;
  open my $fh, "<:encoding(utf8)", "atenciones.csv" or die "atenciones.csv: $!";
  while ( my $row = $csv->getline( $fh ) ) {
    # si la primera columna concuerda con el rut dado, lo procesamos
    ($row->[0] eq $rut) or next; 
    $costo_total+= $row->[2];
  }
  $csv->eof or $csv->error_diag();
  close $fh;
  return $costo_total;
}

# listar los nombres de los pacientes que se atendieron el día dado
sub pacientes_dia{
  my ($dia, $mes, $anio)= @_;
  # seteamos el atributo sep_char para que use el separador ; en vez de ,
  # seteamos el atributo binary para acentos y eñes
  my $csv = Text::CSV->new ( { sep_char => ';', binary => 1 } )  
  or die "No puedo usar CSV: ".Text::CSV->error_diag ();

  my %pacientes;
  my $fecha= join('-',$dia,$mes,$anio);
  open my $fh, "<:encoding(utf8)", "atenciones.csv" or die "atenciones.csv: $!";
  while ( my $row = $csv->getline( $fh ) ) {
    # si la segunda columna concuerda con el dia dado, lo procesamos
    $row->[1] =~ m/^$fecha/ or next; 
    $pacientes{$row->[0]}= 1;
  }
  $csv->eof or $csv->error_diag();
  close $fh;
  listar_pacientes(keys %pacientes);
  return;
}
sub listar_pacientes{
  my (@pacientes)= @_;
  # seteamos el atributo sep_char para que use el separador ; en vez de ,
  # seteamos el atributo binary para acentos y eñes
  my $csv = Text::CSV->new ( { sep_char => ';', binary => 1 } )  
  or die "No puedo usar CSV: ".Text::CSV->error_diag ();

  open my $fh, "<:encoding(utf8)", "pacientes.csv" or die "pacientes.csv: $!";
  while ( my $row = $csv->getline( $fh ) ) {
    # si la primera columna concuerda con el paciente dado, lo procesamos
    $row->[0] or next;
    grep(/$row->[0]/,@pacientes) or next; 
    print $row->[1] . "\n";
  }
  $csv->eof or $csv->error_diag();
  close $fh;
  
  return;
}

# generar un archivo jovenes.csv con los datos de los pacientes menores a cierta edad dada
sub pacientes_menores{
  my $edad= shift;
  # seteamos el atributo sep_char para que use el separador ; en vez de ,
  # seteamos el atributo binary para acentos y eñes
  my $csv = Text::CSV->new ( { sep_char => ';', binary => 1 } )  
  or die "No puedo usar CSV: ".Text::CSV->error_diag ();

  my @menores;
  open my $fh, "<:encoding(utf8)", "pacientes.csv" or die "pacientes.csv: $!";
  while ( my $row = $csv->getline( $fh ) ) {
    # si la tercera columna es menor o igual a la edad dada, lo procesamos
    $row->[2] or next;
    ($row->[2]<=$edad) or next; 
    push(@menores,$row);
  }
  $csv->eof or $csv->error_diag();
  close $fh;
  
  $csv->eol ("\r\n");
  open $fh, ">:encoding(utf8)", "jovenes.csv" or die "jovenes.csv: $!";
  $csv->print ($fh, $_) for @menores;
  close $fh or die "jovenes.csv: $!";
  
  return;
}

viernes, 18 de diciembre de 2015

Números primos

Primo o compuesto


Luis invitó a su primo Miguel a su casa. Mientras la mamá de Luis preparaba unas galletas caseras al horno para comer con la leche chocolatada, los primos revolvían unos libros de matemática y se encontraron con este teorema:

Para todo número primo p > 3, se tiene que p = 6k+1 ó p = 6k-1 

Luego de pensar un rato se dieron cuenta de que todos los números enteros pueden expresarse exactamente de un de las 6 posibles formas:
6k, 6k+1, 6k+2, 6k+3, 6k-2, ó 6k-1
-Claro! -dijo Luis- 6k es divisible por 6, por lo que no es primo.
-6k+2 es par, por lo que no es primo -agregó Miguel.
-6k-2 es par, así que tampoco es primo -se apuró a conjeturar Luis.
-Pero qué pasa con 6k+3?
-6k+3 es igual a 3(2k+1) que es divisible por 3, por lo que no es primo
-Por lo tanto, los números primos tienen que expresarse de la forma 6k+1 o 6k-1.
-Pero no todos los números de esa forma son primos, por ejemplo...
-Ya están las galletitas! A tomar la leche! -dijo la mamá.



Objetivo

Desarrolle un programa cuya entrada sea un entero positivo n, y cuya salida sea:

    primo, si el número es primo, y
    compuesto, si el número es compuesto.

Por ejemplo, si la entrada es 29, el programa debe decir primo. Si la entrada es 27, el programa debe decir compuesto.


Solución en Perl


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

print "Por favor, ingrese un número mayor a 0: ";
my $n = <stdin>;
chomp($n);
if (primo($n)){ print "Primo!"; }
else{ print "Compuesto!"; }
print "\n";

sub primo{
  my $n= shift;
  if (1==$n){ return 0; }
  if (2==$n){ return 1; }
  if (3==$n){ return 1; }
  return teorema($n);
}
sub teorema{
  my $n= shift;
  my $resto= $n % 6;
  if (($resto != 1) && ($resto != 5)){ return 0; }
  my $raiz= sqrt($n);
  my $i= 1;
  while ((6*$i - 1) <= $raiz){
    if ( !($n % (6*$i + 1)) ){ return 0; }
    if ( !($n % (6*$i - 1)) ){ return 0; }
    $i++;
  }
  return 1;
}

Primeros m primos

Usando como base el programa diseñado en el ejercicio anterior, desarrolle otro programa que reciba como entrada un número entero positivo m y cuya salida sean los m primeros números primos.

Por ejemplo, si la entrada es 12, la salida del programa debe ser:

2
3
5
7
11
13
17
19
23
29
31
37

Solución en Perl


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

print "Por favor, ingrese un número mayor a 0: ";
my $n = <stdin>;
chomp($n);
my $cantidad= 0;
my $i= 1;
while ($cantidad < $n){
  if (primo($i)){ print "$i\n"; $cantidad++; }
  $i++;
}
print "\n";

sub primo{
  my $n= shift;
  if (1==$n){ return 0; }
  if (2==$n){ return 1; }
  if (3==$n){ return 1; }
  return teorema($n);
}
sub teorema{
  my $n= shift;
  my $resto= $n % 6;
  if (($resto != 1) && ($resto != 5)){ return 0; }
  my $raiz= sqrt($n);
  my $i= 1;
  while ((6*$i - 1) <= $raiz){
    if ( !($n % (6*$i + 1)) ){ return 0; }
    if ( !($n % (6*$i - 1)) ){ return 0; }
    $i++;
  }
  return 1;
}

Primos hasta m


Modifique el programa del ejercicio anterior para que muestre los números primos menores o iguales a m.

Por ejemplo, si la entrada es 12, la salida debe ser:

2
3
5
7
11

Solución en Perl


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

print "Por favor, ingrese un número mayor a 0: ";
my $n = <stdin>;
chomp($n);
my $i= 1;
while ($i <= $n){
  if (primo($i)){ print "$i\n"; }
  $i++;
}
print "\n";

sub primo{
  my $n= shift;
  if (1==$n){ return 0; }
  if (2==$n){ return 1; }
  if (3==$n){ return 1; }
  return teorema($n);
}
sub teorema{
  my $n= shift;
  my $resto= $n % 6;
  if (($resto != 1) && ($resto != 5)){ return 0; }
  my $raiz= sqrt($n);
  my $i= 1;
  while ((6*$i - 1) <= $raiz){
    if ( !($n % (6*$i + 1)) ){ return 0; }
    if ( !($n % (6*$i - 1)) ){ return 0; }
    $i++;
  }
  return 1;
}

 Más información

Un ejemplo de algoritmo eficiente y su explicación se puede encontrar en la Criba de Atkin

miércoles, 16 de diciembre de 2015

PI

Un poco de historia

El valor de π se ha obtenido con diversas aproximaciones a lo largo de la historia, siendo una de las constantes matemáticas que más aparece en las ecuaciones de la física, junto con el número e. Por ello, tal vez sea la constante que más pasiones desata entre los matemáticos profesionales y aficionados.
Tomando en cuenta que el número pi forma un decimal infinito, lo habitual es usar una aproximación del mismo.

Los matemáticos han encontrado varias series matemáticas que si se repiten infinitamente pueden calcular con precisión el valor de Pi con una gran cantidad de decimales. Algunas de estas series son tan complejas que se necesitan supercomputadoras para procesarlas. Sin embargo, una de las más simples, es la serie Gregory-Leibniz. Aunque no es muy eficiente, se acerca cada vez más al valor de Pi en cada repetición, produciendo con precisión hasta cinco mil decimales de Pi con 500000 repeticiones.

Objetivo I

Desarolle un programa para estimar el valor de π usando la siguiente suma infinita:
π = 4*(1 − 1/3 + 1/5 − 1/7 + ···)

La entrada del programa debe ser un número entero n que indique cuántos términos de la suma se utilizará.

Por ejemplo, si la entrada es 3, el programa debe entregar como salida:

3.466666666666667

Si la entrada es 1000, la salida debe ser:

3.140592653839794

Mientras más veces repitas la serie, más te acercarás al valor de Pi.


Solución en Perl


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

my $suma= 0;
print "Serie Gregory-Leibniz\n";
print "Por favor, ingrese la cantidad de terminos: ";
my $n = <stdin>;
chomp($n);
my $fin_iteracion= $n-1;
foreach my $i (0..$fin_iteracion){
  my $sumando= 1/($i*2+1);
  if ($i%2){ $suma-= $sumando; }
  else{ $suma+= $sumando; }
}
my $aproximacion= 4 * $suma;
print "El valor aproximado de Pi es $aproximacion \n";



Objetivo II

Utilice la serie Nilakantha. Esta es otra serie infinita que sirve para calcular Pi y que además es bastante fácil de entender. Aunque es más complicada que la fórmula de Gregory-Leibniz, converge en los valores de Pi mucho más rápido.

π = 3 + 4/(2*3*4) - 4/(4*5*6) + 4/(6*7*8) - 4/(8*9*10) + 4/(10*11*12) - 4/(12*13*14) ...
Para esta fórmula, toma un tres y empieza a alternar entre suma y resta de fracciones con un numerador de 4 y un denominador que sea el producto de tres enteros consecutivos que vayan aumentando con cada nueva fracción. El denominador de cada nueva fracción empieza con el mayor entero utilizado en la fracción anterior. Repite la serie aunque sea solo un par de veces y verás que el resultado se acerca bastante a Pi.



Solución en Perl


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

my $suma= 0;
print "Serie Nilakantha\n";
print "Por favor, ingrese la cantidad de terminos: ";
my $n = <stdin>;
chomp($n);
foreach my $i (1..$n){
  my $denominador= ($i*2)*($i*2+1)*($i*2+2);
  my $sumando= 4/$denominador;
  if ($i%2){ $suma+= $sumando; }
  else{ $suma-= $sumando; }
}
my $aproximacion= 3 + $suma;
print "El valor aproximado de Pi es $aproximacion \n";

lunes, 14 de diciembre de 2015

Paradoja de la dicotomía

Problema

Zenón está a ocho metros de un árbol. Llegado un momento, lanza una piedra, tratando de dar al árbol. La piedra, para llegar al objetivo, tiene que recorrer antes la primera mitad de la distancia que le separa de él, es decir, los primeros cuatro metros, y tardará un tiempo (finito) en hacerlo. Una vez llegue a estar a cuatro metros del árbol, deberá recorrer los cuatro metros que le quedan, y para ello debe recorrer primero la mitad de esa distancia. Pero cuando esté a dos metros del árbol, tardará tiempo en recorrer el primer metro, y luego el primer medio metro restante, y luego el primer cuarto de metro... De este modo, la piedra nunca llegará al árbol. Es posible utilizar este razonamiento, de forma análoga, para «demostrar» que la piedra nunca llegará a salir de la mano de Zenón.

Potencias fraccionales de 2


Desarrolle un programa que tabule las potencias fraccionales de 2 (1/2, 1/4, 1/8, 1/16, ...) y sus sumas parciales en forma decimal.

La salida del programa debe comenzar así:

Potencia  Fraccion  Suma
1          0.5       0.5
2          0.25      0.75
3          0.125     0.875
4          0.0625    0.9375
...       ...

El programa debe terminar cuando la fracción sea menor o igual que 0.00001.

La tercera columna contiene la suma de todas las fracciones calculadas hasta esa fila.

Solución en Perl

Usamos printf para imprimir las fracciones con una cantidad específica de decimales por un motivo estético

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

my $n= 1;
my $fraccion= 1/(2**$n);
my $suma= $fraccion;
print "Potencia \t\tFraccion \t\tSuma\n";
while ($fraccion>0.00001){
  print "$n \t\t";
  printf "%.16f \t\t%.5f \n",$fraccion,$suma;
  $n++;
  $fraccion= 1/(2**$n);
  $suma+= $fraccion;
}

miércoles, 26 de agosto de 2015

Saber si un string está contenido dentro de otro string


La función index y rindex en Perl

La función index en Perl devuelve la posición de un substring dentro de un string. Si no lo encuentra devuelve -1. Tiene un tercer parámetro opcional que marca en qué posición comenzar la búsqueda. Por defecto comienza a buscar desde el inicio del string.
La función rindex busca la última posición del substring dentro de un string. El tercer parámetro opcional marca en qué posición comenzar la búsqueda, si no se da ninguna posición empieza por el final del string.

my $cadena = "Mauricio compra todo con tarjeta";
my ($subc1,$subc2) = ('compra','vende');
print index($cadena,$subc1); # imprime 9
print index($cadena,$subc1,10); # imprime -1
print index($cadena,$subc2); # imprime -1

Encontrar todos los substrings


my $abc = "Luis le prestó a Ana lo que Luisa no le pudo prestar a Luisana\n";
my $pos = length($abc) - 1; # Calcular la posición del último carácter 
print "Luis se encontró en las posiciones: ";

while(1)
{
  $pos = rindex($abc, "Luis", $pos);
  last if($pos< 0);
  print $pos--, " ";  # 55 28 0
}

print "\n";


La función strpos y strrpos en Php

La función strpos en Php devuelve la primer ocurrencia de un substring dentro de un string. Si no lo encuentra devuelve false. El valor 0 no debe confundirse con el valor false, 0 es la primer posición del string. Tiene un tercer parámetro opcional que indica desde qué posición empezar la búsqueda.
La función strrpos busca desde el final de la cadena hacia atrás. El tercer parámetro indica desde qué posición empezar a buscar y puede ser negativo, en ese caso cuenta la posición a buscar desde el final del string.

$mystring = 'Daniel sólo vende en efectivo';
$findme   = 'Dan';
$pos = strpos($mystring, $findme);

// Debe usar el operador !== . Usar != podría dar resultados inesperados
// porque la posición de 'Dan' es 0. La comparación (0 != false) evalúa
// a false.
if ($pos !== false) {
     echo "El string '$findme' fue encontrado en el string '$mystring'";
         echo " y existe en la posición $pos";
} else {
     echo "El string '$findme' no fue encontrado en el string '$mystring'";
}
$foo = "0123456789a123456789b123456789c";

var_dump(strrpos($foo, '7', -5));  // Comienza la búsqueda hacia atrás en la 5ta
                                   // posición desde el final. Resultado: int(17)

var_dump(strrpos($foo, '7', 20));  // Comienza la búsqueda desde la posición 20
                                   // del string. Resultado: int(27)

La función indexOf y lastIndexOf en Javascript

La función indexOf en Javascript devuelve la posición de un substring dentro de un string. Si no lo encuentra devuelve -1. Tiene un tercer parámetro opcional que marca en qué posición comenzar la búsqueda. Por defecto comienza a buscar desde el inicio del string.
La función lastIndexOf busca la última posición del substring dentro de un string. El tercer parámetro opcional marca en qué posición comenzar la búsqueda, si no se da ninguna posición empieza por el final del string.

// Ejemplo 1
var str = "Los teléfonos celulares se vuelven cada día más inteligentes";
var n = str.indexOf("e"); 
alert(n); // muestra un 5

// Ejemplo 2
var str = "La inteligencia no se puede medir con un número";
var n = str.lastIndexOf("z", 20); 
alert(n); // muestra un -1

domingo, 23 de agosto de 2015

Calcular la longitud de un string


Función length en Perl

La función length trae la longitud de un string.

#Ejemplo
print length("cadena"); # imprime 6


Función strlen en Php

La función strlen devuelve la longitud de un string.

$str 'abecedario';
echo strlen($str); // imprime 10


Propiedad length en Javascript

La propiedad length devuelve la longitud de un string.

var str = "Hello World!";
var n = str.length; // 12

jueves, 20 de agosto de 2015

Unir un array de strings en un solo string



Comando join en Perl

En Perl la función join une los elementos contenidos en un array y forma un único string, usa un separador opcional. Su primer argumento es el separador, el segundo es el array o incluso un hash.

# Ejemplo 1

my %personales = ('apellido'=>'Perez', 'email'=>'perez@example.com');
my $comma_separated = join(",", %personales);

print $comma_separated . "\n"; # email,perez@example.com,apellido,Perez

# Ejemplo 2

my @frutas = ("Banana", "Naranja", "Manzana", "Mango");
my $energy = join('',@frutas);

print $energy . "$/"; # BananaNaranjaManzanaMango 


Comando implode en Php

En Php la función implode une los elementos contenidos en un array y forma un único string, usa un separador opcional. Si no se especifica utiliza el carácter vacío.


// Ejemplo 1

$personales = array('apellido', 'email', 'dirección');
$comma_separated = implode(",", $personales);

echo $comma_separated; // apellido,email,dirección

// Ejemplo 2

$frutas = ["Banana", "Naranja", "Manzana", "Mango"];
$energy = implode($frutas);

alert($energy); // BananaNaranjaManzanaMango 


Comando join en Javascript

En Javascript la función join une los strings contenidos en un array y forma un único string, usa un separador opcional. Si no se especifica el separador, utiliza el carácter ','.

// Ejemplo 1

var personales = new Array('apellido', 'email', 'dirección');
var comma_separated = personales.join(",");

alert(comma_separated); // apellido,email,dirección

// Ejemplo 2

var frutas = ["Banana", "Naranja", "Manzana", "Mango"];
var energy = frutas.join();

alert(energy); // Banana,Naranja,Manzana,Mango 

martes, 18 de agosto de 2015

Separar un string por un delimitador



Comando split en Perl

En Perl la función split devuelve un array de strings como resultado de dividir un array por un carácter delimitador o por un string. Por ejemplo:

# Ejemplo 1
my $pizza  = "porcion1 porcion2 porcion3 porcion4 porcion5 porcion6";
my @porciones = split(" ", $pizza);
print $porciones[0]; # porcion1
print $porciones[1]; # porcion2

# Ejemplo 2
my $data = "foo:*:1023:1000::/home/foo:/bin/sh";
my ($user, $pass, $uid, $gid, $gecos, $home, $shell) = split(":", $data);
print $user; # foo
print $pass; # *


# Ejemplo 3
use Data::Dumper;

my $str = 'one,two,three,four';

# limite positivo
my @count = split(',', $str, 2);
print Dumper(\@count);

# limite negativo no tiene efecto
@count = split(',',$str,-1);
print Dumper(\@count);
$VAR1 = [
          'one',
          'two,three,four'
        ];
$VAR1 = [
          'one',
          'two',
          'three',
          'four'
        ];


Comando explode en Php

En Php la función explode devuelve un array de strings como resultado de dividir un array por un carácter delimitador o por un string. Por ejemplo:

Array
(
    [0] => one
    [1] => two,three,four
)
Array
(
    [0] => one
    [1] => two
    [2] => three
)


Comando split en Javascript

En Javascript la función split devuelve un array de strings como resultado de dividir un array por un carácter delimitador o por un string. Por ejemplo:

// Ejemplo 1
var pizza  = "porcion1 porcion2 porcion3 porcion4 porcion5 porcion6";
var porciones = pizza.split(" ");
alert(porciones[0]); // porcion1
alert(porciones[1]); // porcion2

// Ejemplo 2
var str = "Hola Mundo!";
// sin usar delimitador devuelve el mismo string
var res = str.split();
alert(res); // Hola Mundo! 


// Ejemplo 3
var str = 'one,two,three,four';

// limite positivo
console.log(str.split(',', 2));

// limite negativo no tiene efecto
console.log(str.split(',', -1));
["one", "two"]

["one", "two", "three", "four"]


martes, 5 de junio de 2012

Una introducción agradable a Moose


Lo que sigue es la versión en español del artículo A gentle introduction to Moose escrita por Jay Kuri en el 2009.


Perl, desde el lanzamiento de su versión 5 en 1994, tiene las características de un lenguaje orientado a objetos. Pero estas características OO siguen siendo algo así como un "hágalo Usted mismo", con el clásico estilo de Perl, ofreciendo un mínimo de apoyo integrado en el lenguaje y el resto se deja a cargo de los demás. 

La principal ventaja de este estilo "hágalo Usted mismo" es que el lenguaje impone muy pocas restricciones sobre la manera de hacer las cosas. Por otro lado tiene la desventaja de ser algo intimidante con los novatos. Por lo bueno y lo malo, se ha vuelto familiar.

Otra ventaja es que las características tienen la libertad de evolucionar, por no estar sujetas por el lenguaje algunos programadores muy inteligentes tuvieron la libertad de explorar formas de hacer las cosas de maneras que no estaban preconcebidas. Moose es el resultado de ésta exploración y rápidamente se convirtió en el estandar defacto para la POO en Perl. Hoy vamos a explorar las bases de la creación y manipulación de objetos en Moose.

En la convencional Programación Orientada a Objetos en Perl hay tres cosas principales que necesitan hacerse. Estas son:
  1. Creación de objetos
  2. Atributos y métodos de acceso
  3. Herencia
Tomaremos un rápido exámen alrededor de estas cuestiones y las compararemos con la técnica Perl y la de Moose.


Creación de objetos
En puro Perl, la forma de crear un objeto es crear una referencia a una variable y luego "bendecirla" con una clase. Podemos hacer esto con cualquier tipo de variable, pero lo más común es usar una referencia a un hash. Esto se hace generalmente en una subrutina 'new':
package FooClass;

  sub new {
      my $class = shift;
      my $foo = {};
      bless $foo, 'FooClass';
      return $foo;
  }

Esto devuelve un objeto. Hay algo más aún. La forma Moose de hacer esto es algo más sencilla:
  package FooClass;
  use Moose;

Eso es todo. Moose crea la subrutina new() por nosotros. Si la clase tiene atributos, Moose también se encargará de gestionarlos basándose ​​en los argumentos que se pueden colocar.
Crear una instancia de una clase sigue la misma convención en un objeto de Moose como un objeto de puro Perl: simplemente llamar a new() en la clase. Moose, sin embargo, permite pasar los valores iniciales de sus atributos en la llamada. Por ejemplo:
  FooClass->new( name => 'bob' );
Este es un poco de funcionalidad útil y gratuita que nos brinda el uso de Moose.


Atributos y métodos de acceso
En Perl, nuestro objeto es (muy a menudo) un hash y sus atributos son simplemente miembros de ese hash. De nuevo a menudo, tales atributos se acceden directamente:
  $foo->{name};
Este generalmente está mal visto, ya que proporciona muy poca estructura y hace fácil declarar mal accidentalmente los atributos. $foo-> {naem} puede ser un error muy difícil de encontrar. La "mejor práctica" generalmente consiste en crear las subrutinas de acceso para las variables, lo que limita a los que utilizan el objeto para trabajar con los atributos que hay creados. (Los geeks OO se refieren a esto como "encapsulación"). El problema es que en Perl OO lo debemos crearlas nosotros mismos:
   sub name {
        my $self = shift;
        if( @_ ) {
            $self->{'name'} = $_[0];
        }
        return $self->{'name'};
    }

Se trata de una gran cantidad de código sólo para escribir los setter/getter del objeto. En puro Perl hay un módulo de CPAN nacido para hacer esto más fácil. Class::Accessor construye estos métodos por nosotros:
  package FooClass;
  use base qw(Class::Accessor);
  FooClass->mk_accessors(qw(name age));

Class::Accessor crea el método new por nosotros. Esto es claramente mejor que hacerlo a mano. Ahora es prácticamente imposible crear accidentalmente atributos o acceder a los equivocados. Hay una cosa que no hace bien. No le impide de ninguna manera poner basura en los atributos. Esto es perfectamente legal:
  $foo = FooClass->new();
  $foo->name(192);
  $foo->age('magdalena');

Moose, por el contrario, no sólo hace lo que Class::Accessor, sino que añade la comprobación de tipos (y algunas otras cosas). El mismo objeto creado con Moose:
  package FooClass;
  use Moose;
  has 'name' => (
    is => 'rw',
    isa => 'Str'
  );

  has 'age' => (
    is => 'rw',
    isa => 'Int'
  );
  1;

Lo anterior proporciona el mismo name() y age() que estamos acostumbrados. Pero si tratamos de establecer la edad como 'magdalena' ahora vamos a obtener un error. Por otro lado también tenemos la capacidad de decir esencialmente "este atributo no se puede cambiar después de crear el objeto". Entre otras cosas, el sistema de atributos y de control de tipos de Moose es increíblemente flexible y merece su propio tutorial dedicado.


Herencia
La herencia en programación orientada a objetos está diseñada para permitir la especialización de una clase. El ejemplo clásico es que se puede tener una clase Figura que puede proporcionar un cierto grado de funcionalidad, y cuando se necesita una clase Cuadrado se puede heredar de Figura y añadir sólo el código que hace particular al Cuadrado. En Perl "puro" OO podríamos hacer esto:
  package Cuadrado;
  @ISA = ("Figura");
  # el resto de la clase Cuadrado

Perl tiene la inteligencia para buscar los métodos que no encuentra en la clase Cuadrado en las clases definidas en @ISA. Funciona bien, pero no es muy intuitivo. Moose tiene herencia también, y lo hace más evidente diciendo:
  package Cuadrado;
  use Moose;
  extends 'Figura';
  # el resto de la clase Cuadrado

Bastante sencillo


Otras cosas de Moose
Moose no hace nada que no se pueda hacer con Perl OO. Moose se basa en las mismas características OO soportadas por el lenguaje Perl. Se ocupa, sin embargo, de una enorme cantidad de trabajo que de lo contrario tendríamos que hacer nosotros mismos, dándole la libertad para trabajar en su "nueva" funcionalidad en lugar de reinventar la rueda una vez más.

En este artículo he mostrado cómo hacer las cosas "normales" de Perl OO con Moose. En este punto, usted sabe cómo hacer uso de la programación orientada a objetos básica y podría comenzar a reemplazar sus enrolladas clases hechas a mano por otras construidas con Moose.

Moose, sin embargo, es más que un poco de sintaxis inteligente y algunos ahorros de tiempo. Moose tiene algunas características adicionales que lo hacen realmente increíble para trabajar con él. Sólo voy a referirme a ellas aquí, ya que requeriría un libro entero para cubrirlas adecuadamente. Algunas de las características disponibles con Moose son las siguientes: 
  • Metadatos de la clase: La posibilidad que tiene su código de examinar la estructura de sus objetos.
  • Coerción: La capacidad de convertir los valores de un tipo a otro cuando sea necesario.
  • Modificadores de métodos: La capacidad de agregar código que se ejecuta antes, después o alrededor de un método existente.
  • Roles: La capacidad de agregar funcionalidad predefinida a las clases sin usar herencia.
Hay muchas otras que vale la pena investigar también. Los roles son especialmente interesantes y proporcionan una flexibilidad que no tiene precedentes en casi cualquier lenguaje orientado a objetos. También digno de mención son las extensiones de Moose que proporcionan una funcionalidad incluso más allá de Moose estándar.

Para obtener más información sobre Moose, eche un vistazo a la documentación. Para ver más en detalle Moose vs Perl OO, eche un vistazo a la versión "sin azúcar" del manual.

También puede consultar la página de inicio de Moose. Por último, he comenzado una lista de "Trampas de Moose" en Catalyzed Wiki para rastrear algunas de las partes más difíciles de Moose que he encontrado. Siéntase libre de agregar las propias, a medida que descubre los placeres de usar Moose.




Con Moose la POO vuela


Moose es un completo sistema de objetos para Perl 5. Defines tu clase en forma declarativa. Está basado en gran parte en el sistema de objetos de Perl 6 tomando las mejores ideas de CLOS, Smalltalk y otros lenguajes.
Crearemos la clase Transporte. Un Colectivo es un medio de Transporte. Entonces en el archivo Colectivo.pm escribimos la clase Colectivo que tiene un número de línea y un color:
  package Colectivo;
  use Moose;
  has 'nombre' => (is => 'rw');
  has 'color' => (is => 'rw');
  1;
Aquí decimos que Colectivo tiene nombre y color, y que son atributos de lectura/escritura. Podemos usar la clase:

  use Colectivo;
  my $rapido = Colectivo->new(nombre => 129);
  print $rapido->nombre; # imprime 129
  $rapido->color("amarillo"); # configura el color

Notar que no se definió el método new, Moose lo hace por nosotros.
Ahora bien, Colectivo hereda de Transporte. Para expresar eso facilmente en Transporte.pm escribimos:

  package Transporte;
  use Moose;
  has 'nombre' => (is => 'rw');
  has 'color' => (is => 'rw');
  1;

Y entonces actualizamos nuestro Colectivo.pm:

  package Colectivo;
  use Moose;
  extends 'Transporte';
  1;

Notar que 'extends' reemplaza el tradicional uso de 'base' y configura el array @ISA.

En este momento, Colectivo y Transporte son identicos. Ellos pueden ser instanciados y tienen sus dos atributos. Lo que distingue a un Colectivo de otros medios de Transporte es su bocina. Nosotros lo agregamos aquí:

  package Colectivo;
  use Moose;
  extends 'Transporte';
  sub bocina { 'tuturururu' }
  1;

y luego hacer referencia a eso en el método común "tocar" de la clase Transporte:

  package Transporte;
  use Moose;
  has 'nombre' => (is => 'rw');
  has 'color' => (is => 'rw');
  sub tocar {
    my $self = shift;
    print $self->nombre, " hace ", $self->bocina, "\n";
  }
  sub bocina { confess shift, " deberia haber definido una bocina!" }
  1;

Notar el uso de "confess", si la clase derivada no tiene definido un método bocina, se quejará. Pero como Colectivo definió su bocina, nunca ejecutará Transporte::bocina(). Ahora puedo crear mi colectivo:

  my $rapido = Colectivo->new(nombre => 129);
  $rapido->tocar; # toca la bocina "tuturururu"

Hasta ahora hemos codificado cosas que sin Moose serian simples de hacer, comenzaremos a complicarnos para ver su verdadero poder. Primero, un Transporte es una clase abstracta que se usa solamente para proveer atributos y métodos comunes a una clase concreta (en este caso, la clase Colectivo). En términos de Moose, esto se describe como un rol. Un rol nunca tiene instancias, porque no es una clase completa.

Cuando convertimos la clase Transporte en un rol obtenemos algo de soporte adicional:

  package Transporte;
  use Moose::Role;
  has 'nombre' => (is => 'rw');
  has 'color' => (is => 'rw');
  sub tocar {
    my $self = shift;
    print $self->nombre, " hace ", $self->bocina, "\n";
  }
  requires 'bocina';
  1;

Notar que reemplazamos el 'confess' por un requires. Esto informa a Moose que este rol debe ser usado con una clase que provea el método 'bocina', lo cual se chequea en tiempo de compilacion. Para el rol, nosotros lo vamos a 'usar' más que 'extenderlo':

  package Colectivo;
  use Moose;
  with 'Transporte';
  sub bocina { 'tuturururu' }
  1;

Si nos faltara incluir 'bocina' obtendríamos una notificación bien temprano. Eso es bueno! En este caso Colectivo trabaja igual que antes.

Qué pasa con 'with' y 'requires'. Debido a que son definidos por Moose y Moose::Role, ellos permanecen como parte del package. Para los puristas que hay en nosotros, no nos gusta este tipo de contaminación, nosotros podemos borrarlos cuando hayamos terminado, usando el correspondiente 'no' (similar al uso de 'strict' y 'no strict'). Por ejemplo, limpiando Colectivo.pm:

  package Colectivo;
  use Moose;
  with 'Animal';
  sub bocina { 'tuturururu' }
  no Moose; # sacando los andamios
  1;

En forma similar, Transporte.pm no requiere Moose::Role al final.

Moose soporta la noción de valor por defecto. Agregaremos un color por defecto y haremos que sea la clase la responsable:

  package Transporte;
  ...
  has 'color' => (is => 'rw', default => sub { shift->default_color });
  requires 'default_color';
  ...

Si el color no es provisto, el color por defecto de la clase será consultado a través del método default_color(), y 'requires' asegura que la clase concreta provea este método. Nuestras clases derivadas de Transporte lucirían así:

  ## Avion.pm:
  package Avion;
  use Moose;
  with 'Transporte';
  sub default_color { 'blanco' }
  sub bocina { 'trom' }
  no Moose;
  1;
  ## Colectivo.pm:
  package Colectivo;
  use Moose;
  with 'Transporte';
  sub default_color { 'amarillo' }
  sub bocina { 'tuturururu' }
  no Moose;
  1;
  ## Bicicleta.pm:
  package Bicicleta;
  use Moose;
  with 'Transporte';
  sub default_color { 'roja' }
  sub bocina { 'tilin' }
  no Moose;
  1;

Ahora tenemos Bicicleta entre nuestras clases implementadas:

  use Bicicleta;
  my $ligera = Bicicleta->new(color => 'azul', nombre => 'Ligera');
  $ligera->tocar; # imprime "Ligera hace tilin"

Bueno, esto fue bastante sencillo. Ahora resolveremos otros problemillas.

La clase Ambulancia es especial, porque cuando toca su bocina los demás transportes deben apartarse del camino. En forma tradicional usaríamos una llamada a SUPER:: para llamar al comportamiento de la clase padre, pero esto no funciona con roles. Los roles no quedan en @ISA, porque son 'pegados' en el lugar en vez de 'encimados'.
Afortunadamente, Moose provee el conveniente 'after' para agregar comportamiento adicional a un método existente. Moose reemplaza el método original conservando el contexto (lista, escalar o void) así como su valor de retorno. Nuestro método 'tocar' para Ambulancia quedaría así:

  package Ambulancia;
  use Moose;
  with 'Transporte';
  sub default_color { 'blanca' }
  sub bocina { 'huuuuuu' }
  after 'tocar' => sub {
    print "Apartense!\n";
  };
  no Moose;
  1;

Esto produce una ambulancia que funciona bien:

  my $ambu = Ambulancia->new(nombre => 'Urgencia');
  $ambu->tocar;

resulta:

  Urgencia hace huuuuuu
  Apartense!

También podemos usar 'before' y 'around' para preceder al comportamiento original o controlar la llamada del comportamiento original, según sea necesario. Por ejemplo, para permitir que 'nombre' sea usado como método de acceso y aún como un método de clase que devuelve un Transporte sin nombre, podemos rodear el 'nombre' con 'around':
  package Transporte;
  ...
  has 'nombre' => (is => 'rw');
  around 'nombre' => sub {
    my $next = shift;
    my $self = shift;
    blessed $self ? $self->$next(@_) : "un $self sin nombre";
  };
El 'has' crea el comportamiento original. El 'around' intercepta la llamada a 'nombre' y toma el coderef como primer parámetro en la variable $next y el original $self como segundo parámetro. Testea $self y si es un objeto llama al original coderef con el resto de los parámetros en @_. Así se obtiene el comportamiento original (un getter o setter) para el objeto, pero si es una clase nos devuelve un string literal.

What if we never gave our animal a nombre? We'll get warnings about undefined values. We can give a default nombre just as we did a default color:
¿Y qué sucede si nunca le damos nombre a nuestro Transporte? Vamos a recibir warnings por valores indefinidos. Podemos dar un 'nombre' por defecto tal como lo hicimos con 'color':
  has 'nombre' => (
    is => 'rw',
    default => sub { 'un '. ref shift .' sin nombre ' },
   );

De nuevo, nos place que 'around' inmediatamente siga este paso.

Si no queremos que la gente cambie el color después de la creación de la instancia inicial, podemos declarar el atributo de sólo lectura:
  has 'color' => (is => 'ro', default => sub { shift->default_color });

Ahora un intento de establecer el color aborta con el mensaje 'Cannot assign a value to a read-only accessor'. Si realmente quisiera tener una manera de establecer el color de vez en cuando, podemos definir un escritor separado:

  has 'color' => (
    is => 'ro',
    writer => 'private_set_color',
    default => sub { shift->default_color },
  );

Por lo tanto, no podemos cambiar el color de una bicileta directamente:

  my $ligera = Bicicleta->new;
  my $color = $ligera->color; # método getter obtiene el color
  $ligera->color('verde'); # MUERE

Sin embargo, podemos utilizar nuestro método privado en su lugar:
  $ligera->private_set_color('verde'); # método setter privado

Mediante el uso de un nombre de largo, hacemos menos probable que accidentalmente lo llamen, a menos que intencionalmente querramos cambiar el color.

Vamos a crear una bicicleta de carreras, BicicletaCarrera, mediante el agregado de características de competición a una bicicleta. En primer lugar definimos las características de competición usando roles, claro:
  package Competidor;
  use Moose::Role;
  has $_ => (is => 'rw', default => 0)
    foreach qw(victorias posicion shows perdidas);
  no Moose::Role;
  1;

Tenga en cuenta que desde que 'has' es solo una llamada a función, podemos utilizar las estructuras tradicionales de control de Perl (en este caso, un bucle foreach). Con un poco de código, hemos añadido otros cuatro atributos.
El valor inicial de 0 significa que no tienes que escribir el código de inicialización independiente en nuestro constructor.
Ahora, podemos añadir algunos métodos de acceso:

  package Competidor;
  ...
  sub gano { my $self = shift; $self->victorias($self->victorias + 1) }
  sub aplazado { my $self = shift; $self->posicion($self->posicion + 1) }
  sub showed { my $self = shift; $self->shows($self->shows + 1) }
  sub perdio { my $self = shift; $self->perdidas($self->perdidas + 1) }

  sub tabla_posiciones {
    my $self = shift;
    join ", ", map { $self->$_ . " $_" } qw(victorias posicion shows perdidas);
  }
  ...

Cada llamada al método 'gano' incrementa el número de victorias. Esto sería más sencillo si se presume que estos objetos se implementan como hashes (que lo son por defecto), como:

  sub gano { shift->{victorias}++; }

Sin embargo, mediante el uso de la interfaz pública (una llamada de método), podríamos cambiar la posterior implementación de adentro hacia afuera del objeto usando arreglos sin romper este código. Esto es especialmente importante cuando se crea un rol genérico, que podría mezclarse con cualquier tipo de objeto.

Para crear la bicicleta de carreras, mezlcamos una Bicicleta con un Competidor:

  package BicicletaCarrera;
  use Moose;
  extends 'Bicicleta';
  with 'Competidor';
  no Moose;
  1;

Y ahora podemos montar las bicicletas!:

  use BicicletaCarrera;
  my $bici = BicicletaCarrera->new(nombre => 'ligera');
  $bici->gano; $bici->gano; $bici->gano;
  $bici->aplazado;
  $bici->perdio; # corremos algunas carreras
  print $bici->tabla_posiciones, "\n";
  # 3 ganadas, 1 aplazada, 0 shows, 1 perdida

Hasta ahora, sólo he arañado la superficie de lo que ofrece Moose. Ahora a codificar y ganar experiencia!