#!/bin/sh
#\
exec wish "$0" ${1+"$@"}

package require Tk

option add *Dialog.msg.font {Arial 10}

set about {=== passgen ===\n
Tom Krehbiel (2009)\n
Version - 1.0\n
Licence - G.P.L
}

set help {
The passgen application creates pronounceable passwords and allow
a user to test their muscle memory of the generated password.\n\n  Passwords
are created using letter frequency statistics for the
predecessor-to-successor character relationship within
words.\n\n  To create a new password click on the 'New Password'
button. The password template controls the length and format of the
generated password. Use the following characters in the
template field:\n
  S - upper case alpha\n
  s - lower case alpha\n
  N - number in range 2-9\n
  9 - number in range 0-9\n
  X - one of: ! @ # $ % ^ & * ( ) _ - +\n\n
After a new password has been created hide it, using the
Hide/Show toggle button, and repeatedly enter the password in the
entry box until feel comfortable that your muscle have memorized
the password. Statistics concerning your muscle memory accuracy
are updated after each entry and the statistics background
briefly flashes red when you make and error.
}

# The predecessor-successor table was created from information found in:
#
# "Case-sensitive letter and bigram frequency counts from large-scale English corpora"
# Behavior Research Methods, Instruments, & Computers; 2004, 36 (3), 388-396
# Michael N. Jones & D. J. K. Mewhort

set p2s_freqs {
{a {33 2039 4105 3715 215 829 2253 172 5014 172 1236 10097 3041 20333 50 1845 59 12333 9136 15063 1367 2253 750 317 3361 211}}
{b {10602 962 85 79 28818 6 4 24 6430 407 4 11717 121 32 11717 23 0 4764 3193 595 9593 137 85 0 10602 2}}
{c {12961 3 1754 17 17495 1 0 14324 6436 0 4768 3532 7 7 19335 2 140 3904 692 9602 3904 0 1 0 1096 18}}
{d {10319 144 215 2302 34260 164 1758 180 18802 178 22 1639 1190 899 8448 42 87 4195 5663 140 5663 1045 585 0 2042 15}}
{e {06905 513 4628 11384 3789 1394 1141 221 1541 37 407 4628 3103 12581 765 1703 260 20743 12581 4188 194 2080 1882 1541 1703 87}}
{f {7756 9 14 4 11571 9473 48 4 17261 8 26 2853 62 24 28459 3 0 11571 410 5746 4257 5 16 0 418 2}}
{g {11551 28 5 117 25706 64 1853 15592 7743 3 14 2820 274 4249 7743 25 1 10451 3845 1487 5190 2 50 1 1181 5}}
{h {19062 142 22 99 51816 29 7 19 11562 1 14 316 208 643 9466 14 7 1565 435 2851 1049 7 125 0 542 1}}
{i {3300 736 8116 5441 4030 1483 2986 16 27 30 736 6013 2986 26947 7344 814 73 3300 10956 10956 136 2702 18 233 18 603}}
{j {7712 8 48 54 18408 12 0 5 2144 15 66 17 78 45 33878 8 0 6 15 20 37442 3 0 0 6 9}}
{k {3261 287 31 250 48031 273 187 706 19528 15 200 3293 223 5882 1480 178 0 1012 11845 340 567 74 376 0 1958 4}}
{l {12716 257 219 6979 18971 1044 134 62 15532 3 659 15532 758 113 7713 633 1 240 3830 2567 2567 686 231 1 8524 25}}
{m {17639 3561 27 23 29081 159 10 23 13067 3 6 109 3936 228 13067 10698 0 27 3222 28 3561 7 11 0 1507 1}}
{n {4950 138 6047 18165 11017 818 16436 264 5471 135 1105 740 554 1648 5471 85 48 133 7385 14872 1349 904 122 58 2013 71}}
{o {895 989 1802 1992 453 10901 989 307 1208 118 989 4432 7307 19864 2971 2971 13 16263 3629 4898 9864 2432 4010 137 467 99}}
{p {13912 78 27 29 18780 55 209 2809 5118 12 55 11390 498 23 13912 5656 1 16992 2300 2809 4631 0 30 0 672 3}}
{q {49 13 0 2 4 4 2 0 1391 0 0 5 0 2 2 0 5 0 5 13 98489 11 4 0 0 0}}
{r {10881 457 2197 3277 26764 448 1799 205 9846 8 2683 1473 2428 2966 10881 731 15 1799 8061 5972 1799 1799 197 7 3277 30}}
{s {7711 231 2837 384 17160 238 33 6977 11503 3 1153 1409 1044 416 6977 3465 164 263 8521 23164 5169 27 404 0 735 17}}
{t {6337 108 430 36 14103 76 53 34689 12761 2 11 1048 439 182 12761 36 0 4695 4695 2109 2109 16 858 0 2331 115}}
{u {3382 3060 5046 3382 4566 612 4131 34 3060 25 202 9194 3738 11230 316 4566 19 13716 13716 15158 14 93 39 120 476 105}}
{v {7525 0 65 10 61451 0 14 1 24984 0 4 26 2 32 5044 0 0 78 95 6 132 17 0 0 511 0}}
{w {20479 112 50 301 15171 57 5 18530 20479 0 134 794 170 5050 13727 29 1 1567 2508 298 12 0 2 0 522 1}}
{x {9248 45 9248 1 15248 274 3 2398 9248 0 1 162 83 19 1794 30401 120 4 97 17539 2928 103 460 162 412 1}}
{y {3483 1361 1764 867 32718 210 208 188 7448 8 142 3183 4845 3313 14701 2050 2 2881 16247 2580 261 103 1137 30 11 259}}
{z {21436 616 70 198 42737 23 260 976 13264 4 348 1831 708 188 5960 255 40 204 255 221 1657 221 321 2 2423 5783}}
}

set alphabet [list a b c d e f g h i j k l m n o p q r s t u v w x y z]
set digits { 0 1 2 3 4 5 6 7 8 9 }
set digits-01 { 2 3 4 5 6 7 8 9 }
set symbols { ! @ # $ % ^ & * ( ) _ - + }

proc unsort { alist } {
    set count [llength ${alist}]
    for {} {${count}>1} {incr count -1} {
        set idx_1 [expr {${count}-1}]
        set idx_2 [expr {int(${count} * rand())}]
        set temp [lindex ${alist} ${idx_1}]
        lset alist ${idx_1} [lindex ${alist} ${idx_2}]
        lset alist ${idx_2} ${temp}
    }
    return ${alist}
}

# -- next_char
#
# Use the predecessor-successor table to determine the
# next character in a work. This code is horribly ineffecent
# but it works and I'm lazy.
#
proc next_char { char } {
    global p2s_freqs alphabet
    set bag ""
    set i [lsearch ${alphabet} ${char}]
    for {set j 0} {${j}<26} {incr j} {
        set a [lindex ${alphabet} ${j}]
        set cnt [lindex ${p2s_freqs} ${i} 1 ${j}]
        if { ${cnt} > 0 } {
            for {set k 0} {${k}<${cnt}} {incr k} {
                lappend bag ${a}
            }
        }
    }
    set bag [unsort ${bag}]
    set pos [expr int(rand() * [llength ${bag}])]
    return [lindex ${bag} ${pos}]
}

proc first_char { } {
    global alphabet
    set pos [expr int(rand() * [llength ${alphabet}])]
    return [lindex ${alphabet} ${pos}]
}

proc getN { } {
    global digits-01
    set len [llength ${digits-01}]
    set pos [expr int(rand() * ${len})]
    return [lindex ${digits-01} ${pos}]
}

proc get9 { } {
    global digits
    set len [llength ${digits}]
    set pos [expr int(rand() * ${len})]
    return [lindex ${digits} ${pos}]
}

proc getX { } {
    global symbols
    set len [llength ${symbols}]
    set pos [expr int(rand() * ${len})]
    return [lindex ${symbols} ${pos}]
}

proc ShowHide { {reset 0} } {
    global show display password
    set show [expr ${show}?0:1]
    if { ${reset} == 1 } {set show 1}
    if { ${show} == 1 } {
        .f1.sh4 configure -text "Hide"
        set display ${password}
        set ::tries 0
        set ::correct 0
        set ::stat_string "0/0 (0.0%)"
    } else {
        .f1.sh4 configure -text "Show"
        set display [string repeat "*" [string length ${password}]]
    }
    update idletasks
}

proc FeedBack { {state off} } {
    if { ${state} eq "on" } {
        .stats configure -background red
        after 200 FeedBack
    } else {
        .stats configure -background white
    }
}

proc CheckPassword { } {
    global password user_entry tries correct stat_string
    if { [string trim ${password}] eq "" || [string trim ${user_entry}] eq "" } {
        set user_entry ""
        return
    }
    incr tries
    if { ${user_entry} eq ${password} } {
        incr correct
    } else {
        FeedBack on
    }
    set user_entry ""
    set percent [expr {100*double(${correct})/double(${tries})}]
    set stat_string [format "${correct}/${tries} (%.1f%%)" ${percent}]
    update idletasks
}

proc Message { title msg } {
    tk_dialog .dlg ${title} [string map {"\n" " " "\\n" "\n"} ${msg}] "" 0 "Close"
}

proc newPass { } {
    global template password
    set password ""
    set start 1
    for {set i 0} {${i}<[string length [string trim ${template}]]} {incr i} {
        set c [string index ${template} ${i}]
        switch -exact -- ${c} {
        "S" -
        "s" {
            if { ${start} == 1 } {
                set a [first_char]
                set start 0
            } else {
                set last [string tolower [string index $password end]]
                set a [next_char ${last}]
            }
            if { ${c} eq "S" } {
                set a [string toupper ${a}]
            }
            append password ${a}
        }
        "N" {
            append password [getN]
            set start 1
        }
        "9" {
            append password [get9]
            set start 1
        }
        "X" {
            append password [getX]
            set start 1
        }
        default {
            Message Error "Error in the password template.\n\nCheck help for information on the password template."
            set password ""
            return
        }}
    }
    ShowHide 1
}

proc main { } {

    wm withdraw .

    labelframe .f0 -text "Password Template"
    entry .f0.template -font {Courier} -textvariable template
    grid configure .f0 -row 0 -sticky ew
    pack .f0.template
    set ::template "SssssN9"

    frame .f1
    button .f1.sh4  -font {CourierBold 10} -text "Hide" -command ShowHide
    button .f1.help -font {CourierBold 10} -text "Help" -command {Message Help $::help}
    button .f1.about -text "About" -font {CourierBold 10} -command {Message About $::about}
    grid configure .f1 -row 1 -sticky ew
    grid configure .f1.sh4 .f1.help .f1.about -row 0 -sticky ew

    label .e4 -font {Courier} -border 4 -relief ridge -textvariable display
    grid configure .e4 -row 2 -sticky ew
    set ::show 1
    set ::display ""
    set ::password ""

    label .stats -textvariable stat_string
    grid configure .stats -row 3 -sticky ew
    set ::tries 0
    set ::correct 0
    set ::stat_string "0/0 (0.0%)"

    entry .try -font {Courier} -show "*" -textvariable user_entry
    grid configure .try -row 4 -sticky ew

    frame .f2
    button .f2.c -text "New Password" -font {CourierBold 10} -command newPass
    button .f2.x -text "Close" -font {CourierBold 10} -command {exit}
    grid configure .f2 -row 5 -sticky ew
    grid configure .f2.c .f2.x -row 0 -sticky ew

    wm title . "passgen"
    wm protocol . WM_DELETE_WINDOW {exit}
    update idletasks
    wm resizable . 0 0
    wm deiconify .
    focus .try
    bind .try <Return> CheckPassword
}

main