Mastercoder module for T and L encodings, soon messages proper

darcs-hash:20080811031856-4d648-8eb2e3d6ad5e9f8d2a6fa3bbcf76a86614c867f0.gz

diff --git a/code_test.pl b/code_test.pl
deleted file mode 100644 (file)
index e84aaac..0000000
--- a/code_test.pl
+++ /dev/null
@@ -1,26 +0,0 @@
-use warnings;
-
-# use Irssi::Scripts::Instance::Coder; ### XXX
-use code;
-
-while (my $inst = <>) {
-       chomp $inst;
-
-       my $enc = Irssi::Scripts::Instance::Coder::encode_instance($inst);
-
-       unless (defined $enc) {
-               print "Unable to encode input.\n";
-               next;
-       }
-
-       my $dec = Irssi::Scripts::Instance::Coder::decode_instance($enc);
-
-       print $inst.">>".$dec."(".(length $enc)."):";
-
-       foreach my $char (split(//, $enc)) {
-               printf " %2X", ord($char);
-       }
-       print "\n";
-
-       die unless ($inst eq $dec);
-}

diff --git a/code.pm b/instance_1.pm
similarity index 90%
rename from code.pm
rename to instance_1.pm
index 4807645002a0cd543ccd92a402839576747c6440..670fce98f3a07ab4239494cc0d46e9753265a219 100644 (file)
--- a/code.pm
+++ b/instance_1.pm
@@ -1,20 +1,6 @@
 use warnings;
 
-package Irssi::Scripts::Instance::Coder;
-
-# XXX Do we want to make any guarantees about the appearance of this delimiter
-# in our encoded message?
-my $MAGIC_DELIM = "\ f\ f\ f\ f";
-my $END_CODE = "\ f";
-
-#################################################################
-
-my @code_chars = ("\ f", "\16", "\ 3", "\a", "\ 2", "\1f");
-
-my $i = 0;
-foreach (@code_chars) {
-         $code_chars_rev{$_} = $i++;
-}
+#package Irssi::Scripts::Instance::Tagger1;
 
 #################################################################
 

diff --git a/mastercode.pm b/mastercode.pm
new file mode 100644 (file)
index 0000000..2b76620
--- /dev/null
+++ b/mastercode.pm
@@ -0,0 +1,98 @@
+use warnings;
+use strict;
+
+use Math::BaseCalc;
+use POSIX qw( floor );
+
+#package Irssi::Scripts::Instance::Mastercode;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+require Exporter;
+@ISA = qw(Exporter);
+
+@EXPORT = qw(
+            tencode tencode_padded tdecode lencode ldecode
+);
+
+$VERSION = '0.0';
+
+#################################################################
+
+my $MESSAGE_START = "\ f\ f";
+my $MESSAGE_END = "\ f";
+
+#################################################################
+
+#my @code_chars = ("\ 2", "\ 3", "\a", "\ f", "\16", "\1f");
+
+# This version is lovely for visual debugging.
+my @code_chars = ("B", "C", "G", "O", "V", "_");
+my %code_chars_rev;
+
+my $i = 0;
+foreach (@code_chars) {
+         $code_chars_rev{$_} = $i++;
+}
+
+my $code_chars_count = scalar @code_chars;
+
+#################################################################
+
+my $tencoder = new Math::BaseCalc(digits => \@code_chars);
+
+sub tencode ($) { $tencoder->to_base(@_); }
+sub tdecode ($) { $tencoder->from_base(@_); }
+
+sub tencode_padded ($$) {
+    my $in = shift @_;
+    my $minpad = shift @_;
+
+    my $tenc = tencode($in);
+    return $code_chars[0]
+                x ($minpad > length $tenc ? $minpad - length $tenc : 0)
+           . $tenc;
+}
+
+sub lenc_body_len($) {
+    my $in = shift @_;
+    return 0 if $in == 0;
+    return floor( log(($code_chars_count-1)*$in + 1) / log($code_chars_count) );
+}
+
+sub lenc_correction($) {
+    my $enclen = shift @_;
+    return ( ($code_chars_count**($enclen) - 1) / ($code_chars_count-1) );
+}
+
+sub lencode ($) {
+    my $in = shift @_;
+    my $enclen = lenc_body_len($in);
+
+    die "Can't encode numbers that big!" if $enclen >= $code_chars_count - 1;
+
+    return tencode($enclen) if $in == 0;
+
+    $in -= lenc_correction($enclen);
+
+    return tencode($enclen) . tencode_padded($in, $enclen);
+}
+
+sub ldecode($) {
+    my $in = shift @_;
+
+    my $enclen = substr($in, 0, 1);
+    my $reallen = tdecode($enclen);
+
+    die "Can't decode numbers that big!" if $reallen >= $code_chars_count - 1;
+
+    my $encval = substr($in, 1, $reallen);
+
+    my $realval = tdecode($encval);
+    $realval += lenc_correction($reallen);
+
+    return ( $realval, $reallen+1 )
+}
+
+#################################################################
+
+1;

diff --git a/mastercode_test.pl b/mastercode_test.pl
new file mode 100644 (file)
index 0000000..d925ec2
--- /dev/null
+++ b/mastercode_test.pl
@@ -0,0 +1,33 @@
+use warnings;
+
+# use Irssi::Scripts::Instance::Mastercode; ### XXX
+use mastercode qw(lencode ldecode tencode_padded tdecode);
+
+print "Checking T encoding machinery... \n";
+
+foreach my $i (0 .. 35) {
+    my $enc = tencode_padded($i,2);
+    my $dec = tdecode($enc);
+
+    print $i, " ", $enc, " ==> ", $dec, "\n" if $i % 10 == 0;
+
+    die if length $enc != 2;
+    die if $dec != $i;
+}
+
+print "Checking L encoding machinery... \n";
+
+foreach my $i (0 .. 1554) {
+    my $enc = lencode($i);
+    my ($deci, $decsize) = ldecode($enc);
+
+    print $i, " ", $enc, " (", length $enc, 
+               ") ==> ", $deci, " (", $decsize, ")\n"
+               if $i % 100 == 0;
+
+    die if $deci != $i;
+    die if $decsize != length $enc;
+
+}
+
+