#!/usr/bin/perl

## Calculates a florida DL number given name and BD

###### SOUNDEX

sub soundex {
    my $name = $_[0];
    my $code = substr($name,0,1);
    
    $name =~ s/[HW]//ig;        #remove H and W

    ### ENCODE LETTERS
    $name =~ s/[BFPV]/1/ig;
    $name =~ s/[CGJKQSXZ]/2/ig;
    $name =~ s/[DT]/3/ig;
    $name =~ s/[L]/4/ig;
    $name =~ s/[MN]/5/ig;
    $name =~ s/[R]/6/ig;

    $name =~ s/(.)\1+/$1/g;     #kill double letters
    $name =~ s/[AEIOUY]//ig;    # remove vowels

    # if removed the first letter, put on a pad
    if($code =~ m/[AEIOUYHW]/i) {
        $name = "0" . $name;
    }

    $name = $code . substr($name . "00000", 1,3);

    return $name;
}



###### NAME CODE
sub namecode {
    my ($fname, $initial) = @_;
    my $code = 0;

    my %FNAMELIST = 
        ( 
          Albert => 20, Alice => 20, Ann => 40, Anna => 40, 
          Anne => 40, Annie => 40, Arthur => 40,  
          Bernard => 80, Bette => 80, Bettie => 80,  
          Betty => 80, Carl => 120, Catherine => 120,
          Charles => 140, Dorthy => 180, Edward => 220, 
          Elizabeth => 220, Florence => 260, Donald => 180,
          Clara => 140, Frank => 260, George => 300, Grace => 300, 
          Harold => 340, Harriet => 340, Harry => 360, 
          Hazel => 360, Helen => 380, Henry => 380, 
          James => 440, Jane => 440, Jayne => 440, Jean => 460, 
          Joan => 480, John => 460, Joseph => 480, Margaret => 560, 
          Martin => 560, Marvin => 480, Mary => 580,
          Melvin => 600, Mildred => 600, Patricia => 680,
          Paul => 680, Richard => 740, Robert => 760,
          Ruby => 740, Ruth => 760, Thelma => 820,
          Walter => 900, Wanda => 900, William => 920,
          Wilma => 920 
        );
          
    my %FLETTERLIST = 
        ( A => 0, B => 60, C => 100, D => 160, E => 200, F => 240,
          G => 280, H => 320, I => 400, J => 420, K => 500, L => 520,
          M => 540, N => 620, O => 640, P => 660, Q => 700, R => 720,
          S => 780, T => 800, U => 840, V => 860, W => 880, X => 840,
          Y => 960, Z => 980 );

    my %MINITIALLIST = 
        ( A => 1, B => 2, C => 3, D => 4, E => 5, F => 6, G => 7, 
          H => 8, I => 9, J => 10, K => 11, L => 12, M => 13, N => 14, 
          O => 14, P => 15, Q => 15, R => 16, S => 17, T => 18, U => 18, 
          V => 18, W => 19, X => 19, Y => 19, Z => 19 );


    ## Either take from name list or letter list
    if(exists $FNAMELIST{$fname}) {
        $code += $FNAMELIST{$fname};
    } else {
        $code += $FLETTERLIST{substr($fname,0,1)};
    }

    ## Add in the middle initial
    $code += $MINITIALLIST{$initial} if exists $MINITIALLIST{$initial};

    return $code;
}


sub birthcode { 
    my ($month, $day, $gender) = @_;
    ## NOTE that gender is "M" or "F"!

    my $birthmod = 500; #Florida/Wisconsin Woman birthmod
    #my $birthmod = 600; #Illinois

    my $month_mul = 40; #Florida/Wisconsin month multiplier
    #my $month_mul = 31; #Illinois

    my $code = 0;

    $birthmod = 0 if $gender =~ "M"; #no birthmod for men
    
    $code = ($month-1) * $month_mul + $day + $birthmod;

    return "00$code" if $code < 10;
    return "0$code" if $code < 100;
    return "$code";
    
}


sub overflow {
    return "0";
}


sub determineID {
    my ($first, $mi, $last, $bd, $gender) = @_;

    #BD is formatted MM/DD/YYY
    $_ = $bd;
    my ($bd_m, $bd_d, $yyyy) = m/(\d+)\/(\d+)\/(\d+)/;
    my $yy = substr($yyyy, 2,2);

    my $ssss = &soundex($last);
    my $fff  = &namecode($first, $mi);
    my $ddd  = &birthcode($bd_m, $bd_d, $gender);
    my $nn   = &overflow();
    
    return "$ssss-$fff-$yy-$ddd-$nn";    
}

print "------------------------------------------------------------\n";
print "testing soundex:\n\n";

my @names = ( "Washington", "Wu", "DeSmet", "Gutierrez", 
              "Pfister", "Jackson", "Tymczak", "Ashcraft" );
foreach (@names) {
    print $_ . " = " . soundex($_) . "\n";
}

print "\n------------------------------------------------------------\n";
print "testing namecode:\n\n";

print "Gerald N. = " . namecode("Gerald", "N") . "\n";


print "\n------------------------------------------------------------\n";
print "testing birthcode:\n\n";

print "Male, Feb 11, 1944 = " . birthcode(2, 11, 1944, "M") . "\n";


print "\n------------------------------------------------------------\n";
print "encoding:\n";

while(1) {
    print "First Name (Gerald):  ";
    $fn = <STDIN>; chomp $fn;

    print "Middle initial (N):   ";
    $mi = <STDIN>; chomp $mi;

    print "Last Name (Springer): ";
    $ln = <STDIN>; chomp $ln;

    print "DOB (eg 02/13/1944):  ";
    $dob = <STDIN>; chomp $dob;

    print "Gender (M/F):         ";
    $gen = <STDIN>; chomp $gen;


    print "\nDL = " . &determineID($fn, $mi, $ln, $dob, $gen) . "\n";
}