Perl 6 - Starting with the basics - Case Study: Data Structure Selection(Building the Huffman Code, Huffman coding of a DNA)

開発環境

macOS Sierra - Apple (OS)
Emacs (Text Editor)
Perl 6 (プログラミング言語)
Rakudo(コンパイラ、実装)

Think Perl 6: How to Think Like a Computer Scientist (Laurent Rosenfeld(著)、Allen B. Downey(著)、Oreilly & Associates Inc)のPart 1(Starting with the basics)、Chapter 11(Case Study: Data Structure Selection)の Building the Huffman Code、Exercise 11-9: Huffman coding of a DNA:1、2、3、4.を取り組んでみる。

Exercise 11-9: Huffman coding of a DNA:1、2、3、4.

コード(Emacs)

#!/usr/bin/env perl6
# -*- coding: utf-8 -*-

say '1.';
my $dna = 'CCTATCCTCGACTCCAGTCCA';

my $frequency = bag $dna.comb;
my @frequency;
for sort {$frequency{$_}}, $frequency.keys {
    push @frequency, $_ => $frequency{$_};
}
say @frequency;

my %huffman-tree;
while @frequency > 2 {
    say %huffman-tree;
    say @frequency;    
    my $letter1 = shift @frequency;
    my $letter2 = shift @frequency;
    my $t = $letter1.key ~ $letter2.key;
    %huffman-tree{$letter1.key} = "[$t].";
    %huffman-tree{$letter2.key} = "[$t]-";
    my $pair = $t => $letter1.value + $letter2.value;
    push @frequency, $pair;    
    @frequency = sort {$_.value}, @frequency;
}
my $letter1 = shift @frequency;
my $letter2 = shift @frequency;
%huffman-tree{$letter1.key} = ".";
%huffman-tree{$letter2.key} = "-";

say %huffman-tree;
say @frequency;    

my %huffman-code;
for grep {$_.chars === 1}, %huffman-tree.keys -> $letter {
    my $result = '';
    my $val = %huffman-tree{$letter};
    while $val.chars > 1 {
        my @val = $val.comb;
        $result = @val[@val.end] ~ $result;
        $val = %huffman-tree{@val[1..@val.end - 2].join};
    }
    %huffman-code{$letter} = $val ~ $result;
}

say %huffman-code;

say '2.'; 
my $s = 'think perl 6, think python, think';
$frequency = bag $s.comb;
@frequency = ();
for sort {$frequency{$_}}, $frequency.keys {
    push @frequency, $_ => $frequency{$_};
}
say @frequency;

%huffman-tree = ();
while @frequency > 2 {
    say %huffman-tree;
    say @frequency;    
    my $letter1 = shift @frequency;
    my $letter2 = shift @frequency;
    my $t = $letter1.key ~ $letter2.key;
    %huffman-tree{$letter1.key} = "[$t].";
    %huffman-tree{$letter2.key} = "[$t]-";
    my $pair = $t => $letter1.value + $letter2.value;
    push @frequency, $pair;    
    @frequency = sort {$_.value}, @frequency;
}
$letter1 = shift @frequency;
$letter2 = shift @frequency;
%huffman-tree{$letter1.key} = ".";
%huffman-tree{$letter2.key} = "-";

say %huffman-tree;
say @frequency;    

%huffman-code = ();
for grep {$_.chars === 1}, %huffman-tree.keys -> $letter {
    my $result = '';
    my $val = %huffman-tree{$letter};
    while $val.chars > 1 {
        my @val = $val.comb;
        $result = @val[@val.end] ~ $result;
        $val = %huffman-tree{@val[1..@val.end - 2].join};
    }
    %huffman-code{$letter} = $val ~ $result;
}

say %huffman-code;
dd %huffman-code;

say '3.';
my $filename = 'the_gold_bug.txt';
$s = $filename.IO.lines.pick(10).join(' ');

$frequency = bag $s.comb;
@frequency = ();
for sort {$frequency{$_}}, $frequency.keys {
    push @frequency, $_ => $frequency{$_};
}

%huffman-tree = ();
while @frequency > 2 {
    my $letter1 = shift @frequency;
    my $letter2 = shift @frequency;
    my $t = $letter1.key ~ $letter2.key;
    %huffman-tree{$letter1.key} = "[$t].";
    %huffman-tree{$letter2.key} = "[$t]-";
    my $pair = $t => $letter1.value + $letter2.value;
    push @frequency, $pair;    
    @frequency = sort {$_.value}, @frequency;
}
$letter1 = shift @frequency;
$letter2 = shift @frequency;
%huffman-tree{$letter1.key} = ".";
%huffman-tree{$letter2.key} = "-";

my %huffman-table = ();
for grep {$_.chars === 1}, %huffman-tree.keys -> $letter {
    my $result = '';
    my $val = %huffman-tree{$letter};
    while $val.chars > 1 {
        my @val = $val.comb;
        $result = @val[@val.end] ~ $result;
        $val = %huffman-tree{@val[1..@val.end - 2].join};
    }
    %huffman-table{$letter} = $val ~ $result;
}
for %huffman-table.pick(10) {
    say $_;
}

sub encode-morse-huffuman-table($s, %huffman-table) {
    my $result = '';
    for $s.comb -> $letter {
        $result ~= %huffman-table{$letter};
    }
    return $result;
}

my $encoded = encode-morse-huffuman-table($s, %huffman-table);

say '4.';
sub decode-morse-huffman-table($s, %huffman-table) {
    my %table = map {%huffman-table{$_} => $_}, %huffman-table.keys;
    my $result = '';
    my $morse = '';
    for $s.comb -> $letter {
        $morse ~= $letter;
        if %table{$morse}.defined {
            $result ~= %table{$morse};
            $morse = '';
        }
    }
    return $result;
}

my $decoded = decode-morse-huffman-table($encoded, %huffman-table);
say $decoded eq $s;

入出力結果(Terminal, REPL)

$ ./sample9.pl
1.
[G => 2 A => 4 T => 5 C => 10]
{}
[G => 2 A => 4 T => 5 C => 10]
{A => [GA]-, G => [GA].}
[T => 5 GA => 6 C => 10]
{A => [GA]-, C => ., G => [GA]., GA => [TGA]-, T => [TGA]., TGA => -}
[]
{A => ---, C => ., G => --., T => -.}
2.
[e => 1 l => 1 o => 1 y => 1 6 => 1 r => 1 , => 2 p => 2 k => 3 i => 3 h => 4 n => 4 t => 4   => 5]
{}
[e => 1 l => 1 o => 1 y => 1 6 => 1 r => 1 , => 2 p => 2 k => 3 i => 3 h => 4 n => 4 t => 4   => 5]
{e => [el]., l => [el]-}
[o => 1 y => 1 6 => 1 r => 1 , => 2 p => 2 el => 2 k => 3 i => 3 h => 4 n => 4 t => 4   => 5]
{e => [el]., l => [el]-, o => [oy]., y => [oy]-}
[6 => 1 r => 1 , => 2 p => 2 el => 2 oy => 2 k => 3 i => 3 h => 4 n => 4 t => 4   => 5]
{6 => [6r]., e => [el]., l => [el]-, o => [oy]., r => [6r]-, y => [oy]-}
[, => 2 p => 2 el => 2 oy => 2 6r => 2 k => 3 i => 3 h => 4 n => 4 t => 4   => 5]
{, => [,p]., 6 => [6r]., e => [el]., l => [el]-, o => [oy]., p => [,p]-, r => [6r]-, y => [oy]-}
[el => 2 oy => 2 6r => 2 k => 3 i => 3 h => 4 n => 4 t => 4 ,p => 4   => 5]
{, => [,p]., 6 => [6r]., e => [el]., el => [eloy]., l => [el]-, o => [oy]., oy => [eloy]-, p => [,p]-, r => [6r]-, y => [oy]-}
[6r => 2 k => 3 i => 3 h => 4 n => 4 t => 4 ,p => 4 eloy => 4   => 5]
{, => [,p]., 6 => [6r]., 6r => [6rk]., e => [el]., el => [eloy]., k => [6rk]-, l => [el]-, o => [oy]., oy => [eloy]-, p => [,p]-, r => [6r]-, y => [oy]-}
[i => 3 h => 4 n => 4 t => 4 ,p => 4 eloy => 4   => 5 6rk => 5]
{, => [,p]., 6 => [6r]., 6r => [6rk]., e => [el]., el => [eloy]., h => [ih]-, i => [ih]., k => [6rk]-, l => [el]-, o => [oy]., oy => [eloy]-, p => [,p]-, r => [6r]-, y => [oy]-}
[n => 4 t => 4 ,p => 4 eloy => 4   => 5 6rk => 5 ih => 7]
{, => [,p]., 6 => [6r]., 6r => [6rk]., e => [el]., el => [eloy]., h => [ih]-, i => [ih]., k => [6rk]-, l => [el]-, n => [nt]., o => [oy]., oy => [eloy]-, p => [,p]-, r => [6r]-, t => [nt]-, y => [oy]-}
[,p => 4 eloy => 4   => 5 6rk => 5 ih => 7 nt => 8]
{, => [,p]., ,p => [,peloy]., 6 => [6r]., 6r => [6rk]., e => [el]., el => [eloy]., eloy => [,peloy]-, h => [ih]-, i => [ih]., k => [6rk]-, l => [el]-, n => [nt]., o => [oy]., oy => [eloy]-, p => [,p]-, r => [6r]-, t => [nt]-, y => [oy]-}
[  => 5 6rk => 5 ih => 7 nt => 8 ,peloy => 8]
{  => [ 6rk]., , => [,p]., ,p => [,peloy]., 6 => [6r]., 6r => [6rk]., 6rk => [ 6rk]-, e => [el]., el => [eloy]., eloy => [,peloy]-, h => [ih]-, i => [ih]., k => [6rk]-, l => [el]-, n => [nt]., o => [oy]., oy => [eloy]-, p => [,p]-, r => [6r]-, t => [nt]-, y => [oy]-}
[ih => 7 nt => 8 ,peloy => 8  6rk => 10]
{  => [ 6rk]., , => [,p]., ,p => [,peloy]., 6 => [6r]., 6r => [6rk]., 6rk => [ 6rk]-, e => [el]., el => [eloy]., eloy => [,peloy]-, h => [ih]-, i => [ih]., ih => [ihnt]., k => [6rk]-, l => [el]-, n => [nt]., nt => [ihnt]-, o => [oy]., oy => [eloy]-, p => [,p]-, r => [6r]-, t => [nt]-, y => [oy]-}
[,peloy => 8  6rk => 10 ihnt => 15]
{  => [ 6rk].,  6rk => [,peloy 6rk]-, , => [,p]., ,p => [,peloy]., ,peloy => [,peloy 6rk]., ,peloy 6rk => -, 6 => [6r]., 6r => [6rk]., 6rk => [ 6rk]-, e => [el]., el => [eloy]., eloy => [,peloy]-, h => [ih]-, i => [ih]., ih => [ihnt]., ihnt => ., k => [6rk]-, l => [el]-, n => [nt]., nt => [ihnt]-, o => [oy]., oy => [eloy]-, p => [,p]-, r => [6r]-, t => [nt]-, y => [oy]-}
[]
{  => --., , => -..., 6 => ---.., e => -.-.., h => ..-, i => ..., k => ----, l => -.-.-, n => .-., o => -.--., p => -..-, r => ---.-, t => .--, y => -.---}
Hash %huffman-code = {" " => "--.", "," => "-...", "6" => "---..", :e("-.-.."), :h("..-"), :i("..."), :k("----"), :l("-.-.-"), :n(".-."), :o("-.--."), :p("-..-"), :r("---.-"), :t(".--"), :y("-.---")}
3.
h => -.-..
n => -...
, => ...--
I => --.-..-.
- => -..-....-
e => ..-
. => -..-...--
i => .-..
z => -..-...-.
b => -.--.-
4.
True
$

Kamimura's blog

2017年6月1日木曜日

Perl 6 - Starting with the basics - Case Study: Data Structure Selection(Building the Huffman Code, Huffman coding of a DNA)

0 コメント:

コメントを投稿