RosettaCodeData/Task/De-Bruijn-sequences/Perl/de-bruijn-sequences.pl
2023-07-01 13:44:08 -04:00

38 lines
1.1 KiB
Perl

use strict;
use warnings;
use feature 'say';
my $seq;
for my $x (0..99) {
my $a = sprintf '%02d', $x;
next if substr($a,1,1) < substr($a,0,1);
$seq .= (substr($a,0,1) == substr($a,1,1)) ? substr($a,0,1) : $a;
for ($a+1 .. 99) {
next if substr(sprintf('%02d', $_), 1,1) <= substr($a,0,1);
$seq .= sprintf "%s%02d", $a, $_;
}
}
$seq .= '000';
sub check {
my($seq) = @_;
my %chk;
for (0.. -1 + length $seq) { $chk{substr($seq, $_, 4)}++ }
say 'Missing: ' . join ' ', grep { ! $chk{ sprintf('%04d',$_) } } 0..9999;
say 'Extra: ' . join ' ', sort grep { $chk{$_} > 1 } keys %chk;
}
my $n = 130;
say "de Bruijn sequence length: " . length $seq;
say "\nFirst $n characters:\n" . substr($seq, 0, $n );
say "\nLast $n characters:\n" . substr($seq, -$n, $n);
say "\nIncorrect 4 digit PINs in this sequence:";
check $seq;
say "\nIncorrect 4 digit PINs in the reversed sequence:";
check(reverse $seq);
say "\nReplacing the 4444th digit, '@{[substr($seq,4443,1)]}', with '5'";
substr $seq, 4443, 1, 5;
say "Incorrect 4 digit PINs in the revised sequence:";
check $seq;