passphrase-generator.pl

#!/usr/bin/env perl

# Memorable, typeable password generator. See https://blog.kamens.us/?p=5969.
#
# By Jonathan Kamens <jik@kamens.us>.
#
# This script is in the public domain. You are welcome to do whatever you want
# with it, though it would be nice if you'd give me credit somehow or at least
# send me email and let me know how you're using it.
#
# Change the following constants as appropriate.

$min_length = 14;
$max_score = 20;
$num_passwords = 10;
$words_file = '/usr/share/dict/words';

open(WORDS, '<', $words_file) or die;
while (<WORDS>) {
    chomp;
    next if (/\W/);
    next if (length($_) < 4);
    push(@words, $_);
}

sub typing_score {
    local($_) = @_;
    my($left_lower) = "~12345qwertasdfgzxcvb";
    my($left_upper) = "~!\@#$%QWERTASDFGZXCVB";
    my($right_lower) = "67890-=yuiop[]\\hjkl;'nm,./";
    my($right_upper) = "^&*()_+YUIOP{}|HJKL:\"NM<>?";
    my(%left, %right, $lower, $upper);
    map($left{$_}++, split(//, $left_lower), split(//, $left_upper));
    map($right{$_}++, split(//, $right_lower), split(//, $right_upper));
    map($lower{$_}++, split(//, $left_lower), split(//, $right_lower));
    map($upper{$_}++, split(//, $left_upper), split(//, $right_upper));
    my $score = 0;
    # Repeat letters add a point
    my $last_letter = undef;
    foreach my $letter (split(//)) {
        $score++ if ($letter eq $last_letter);
        $last_letter = $letter;
    }
    my(@hands);
    foreach my $letter (split(//)) {
        if ($upper{$letter}) {
            push(@hands, $left{$letter} ? 'right' : 'left', 'both');
        }
        else {
            push(@hands, $left{$letter} ? 'left' : 'right');
        }
    }
    # A point for each keystroke
    $score += scalar @hands;
    # A point for each consecutive letter on the same hand
    my $last_hand = undef;
    foreach my $hand (@hands) {
        $score++ if ($last_hand eq $hand or $last_hand eq 'both');
        $last_hand = $hand;
    }
    return $score;
}

sub random_word {
    return $words[int(rand(scalar @words))];
}

sub random_password {
    my $pw = &random_word;
    my $l = 0;
    while ($l < $min_length) {
        $pw .= '-' . &random_word;
        $l = length($pw);
    }
    return $pw;
}

sub variants {
    local($_) = @_;
    # One of the words has to be capitalized and one of the letters has to be
    # replaced by a number.
    my(@cap_options);
    if (/[A-Z]/) {
        push(@cap_options, $_);
    }
    else {
        my(@fragments) = split(/\b([a-z])/);
        shift @fragments if ! $fragments[0];
        for (my $i = 0; $i < @fragments; $i += 2) {
            my $pw = '';
            for (my $j = 0; $j < $i; $j++) {
                $pw .= $fragments[$j];
            }
            $pw .= uc $fragments[$i];
            $pw .= $fragments[$i+1];
            for (my $j = $i + 2; $j < @fragments; $j++) {
                $pw .= $fragments[$j];
            }
            push(@cap_options, $pw);
        }
    }
    if (/[0-9]/) {
        return(@cap_options);
    }
    my(@num_options);
    for (@cap_options) {
        my(@fragments) = grep($_, split(/([abegis])/));
        for (my $i = 0; $i < @fragments; $i++) {
            my $char = $fragments[$i];
            next if $char !~ /^[abegis]$/;
            $char =~ tr/abegis/483915/;
            my $pw = '';
            for (my $j = 0; $j < $i; $j++) {
                $pw .= $fragments[$j];
            }
            $pw .= $char;
            for (my $j = $i + 1; $j < @fragments; $j++) {
                $pw .= $fragments[$j];
            }
            push(@num_options, $pw);
        }
    }
    return(@num_options);
}

my(%passwords);
while (scalar keys %passwords < $num_passwords) {
    my $pw = &random_password;
    my(@variants) = &variants($pw);
    next if not @variants;
    my $best_score = 999;
    for (@variants) {
        my $score = &typing_score($_);
        if ($score < $best_score) {
            $best_score = $score;
            $pw = $_;
        }
    }
    next if $best_score > $max_score;
    $passwords{$pw} = $best_score;
}

foreach my $pw (sort { $passwords{$a} <=> $passwords{$b} } keys %passwords) {
    print("$pw ($passwords{$pw})\n");
}