1package UDCode;
2
3$VERSION = "1.03";
4
5use base 'Exporter';
6@EXPORT = qw(is_udcode ud_pair);
7
8=head1 NAME
9
10UDCode - Does a set of code words form a uniquely decodable code?
11
12=head1 SYNOPSIS
13
14        use UDCode;
15
16        if (is_udcode(@words)) { ... }
17
18        my ($x1, $x2) = ud_pair(@words);
19
20=head1 DESCRIPTION
21
22A code is a set of strings, called the I<code words>.  A code is
23"uniquely decodable" if any string I<S> that is a concatenation of
24code words is so in I<exactly one way>.
25
26For example, the code C<"ab", "abba", "b"> is I<not> uniquely
27decodable, because C<"abba" . "b" eq "ab" . "b" . "ab">.  But the code
28C<"a", "ab", "abb"> I<is> uniquely decodable, because there is no such
29pair of sequences of code words.
30
31=head2 C<is_udcode>
32
33C<is_udcode(@words)> returns true if and only if the specified code is
34uniquely decodable.
35
36=cut
37
38sub is_udcode {
39  my $N = my ($a, $b) = ud_pair(@_);
40  return $N == 0;
41}
42
43=head2 C<ud_pair>
44
45If C<@words> is not a uniquely decodable code, then C<ud_pair(@words)>
46returns a proof of that fact, in the form of two distinct sequences of
47code words whose concatenations are equal.
48
49If C<@words> is not uniquely decodable, then C<ud_pair> returns
50references to two arrays of code words, C<$a>, and C<$b>, such that:
51
52	join("", @$a) eq join("", @$b)
53
54For example, given C<@words = qw(ab abba b)>, C<ud_pair> might return
55the two arrays C<["ab", "b", "ab"]> and C<["abba", "b"]>.
56
57If C<@words> is uniquely decodable, C<ud_pair> returns false.
58
59=cut
60
61sub ud_pair {
62  # Code words
63  my @c = @_;
64
65  # $h{$x} = [$y, $z]  means that $x$y eq $z
66  my %h;
67
68  # Queue
69  my @q;
70
71  for my $c1 (@c) {
72    for my $c2 (@c) {
73      next if $c1 eq $c2;
74      if (is_prefix_of($c1, $c2)) {
75        my $x = subtract($c1, $c2);
76        $h{$x} = [[$c1], [$c2]];
77        push @q, $x;
78      }
79    }
80  }
81
82  while (@q) {
83    my $x = shift @q;
84    return unless defined $x;
85
86    my ($a, $b) = @{$h{$x}};
87    for my $c (@c) {
88      die unless defined $b;      # Can't happen
89      # $a$x eq $b
90
91      my $y;
92      if (is_prefix_of($c, $x)) {
93        $y = subtract($c, $x);
94        next if exists $h{$y};  # already tried this
95        $h{$y} = [[@$a, $c], $b];
96        push @q, $y;
97      } elsif (is_prefix_of($x, $c)) {
98        $y = subtract($x, $c);
99        next if exists $h{$y};  # already tried this
100        $h{$y} = [$b, [@$a, $c]];
101        push @q, $y;
102      }
103
104      return @{$h{""}} if defined($y) && $y eq "";
105    }
106  }
107  return;                       # failure
108}
109
110sub is_prefix_of {
111  index($_[1], $_[0]) == 0;
112}
113
114sub subtract {
115  substr($_[1], length($_[0]));
116}
117
118=head1 AUTHOR
119
120Mark Jason Dominus (C<mjd@plover.com>)
121
122=head1 COPYRIGHT
123
124This software is hereby released into the public domain.  You may use,
125modify, or distribute it for any purpose whatsoever without restriction.
126
127=cut
128
129unless (caller) {
130  my ($a, $b) = ud_pair("ab", "abba", "b");
131  print "@$a == @$b\n";
132}
133
1341;
135
136