chiark - git - mdw - wordchain/blob - chain.perl

   1 #! /usr/bin/perl -w
   2
   3 use autodie;
   4 use strict;
   5
   6 use constant { WORD => 0, LEN => 1, UP => 2, DOWN => 3, RIGHT => 4 };
   7
   8 my %WORD;
   9 while (<>) {
  10   chomp;
  11   $WORD{$_} = [$_, 1, undef, undef, undef];
  12 }
  13
  14 my $MAX = 0; my @WINNERS;
  15 WORD: while (my ($word, $node) = each %WORD) {
  16   my $len = length $word;
  17   next WORD unless $len >= 2;
  18   my $parent = $WORD{substr $word, 0, $len - 1};
  19   next WORD unless defined $parent;
  20   $node->[UP] = $parent;
  21   my $nlen = $node->[LEN];
  22   UP: for (;;) {
  23     unless (defined $parent) {
  24       if ($nlen >= $MAX) {
  25         if ($nlen > $MAX) { $MAX = $nlen; @WINNERS = (); }
  26         push @WINNERS, $node;
  27       }
  28       last UP;
  29     }
  30     my $plen = $parent->[LEN]; $nlen++;
  31     if ($plen > $nlen)
  32       { last UP; }
  33     elsif ($plen == $nlen)
  34       { $node->[RIGHT] = $parent->[DOWN]; $parent->[DOWN] = $node; last UP; }
  35     else {
  36       $parent->[DOWN] = $node; $node->[RIGHT] = undef;
  37       $parent->[LEN] = $nlen;
  38       $node = $parent; $parent = $node->[UP];
  39     }
  40   }
  41   if ($nlen > $MAX) { $MAX = $nlen; }
  42 }
  43
  44 sub print_chain ($);
  45 sub print_chain ($) {
  46   my ($node) = @_;
  47
  48   if (!defined $node->[RIGHT]) {
  49     print $node->[WORD];
  50     if (defined $node->[DOWN]) { print " "; print_chain $node->[DOWN]; }
  51   } else {
  52     print "{ ";
  53     ALT: for (;;) {
  54       print $node->[WORD];
  55       if (defined $node->[DOWN]) { print " "; print_chain $node->[DOWN]; }
  56       $node = $node->[RIGHT]; last ALT unless defined $node;
  57       print " | ";
  58     }
  59     print " }";
  60   }
  61 }
  62
  63 for my $node (@WINNERS) { print_chain $node; print "\n"; }