##+##########################################################################
#
# CryptoAid -- tcl port of VB CryptoAid program
# by Keith Vetter, Oct 2009
#

package require Tcl 8.5
package require Tk
package require textutil
package require http

set C(title) CryptoAid
set C(height) 300
set C(undo) {}
set C(CipherLines) 4

set AB {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}
if {"myFont" in [font names]} { font delete myFont }
font create myFont -family Courier -size 12 -weight bold

proc DoDisplay {} {
    global C

    wm title . $C(title)
    . config -padx .1i -pady .1i
    ::ttk::frame .txt
    canvas .c -width 0 -height $C(height) -highlightthickness 0
    ::ttk::frame .ctrl
    DoCanvas

    pack .txt -side top -fill both
    pack .c -side left -fill both
    pack .ctrl -side bottom -padx {.1i 0} -fill y -expand 1

    # Control panel
    ::ttk::label .ctrl.info -textvariable ::C(sample,info)
    ::ttk::button .ctrl.retype -text Edit -command GetCipherText
    ::ttk::button .ctrl.help -text Help -command Help
    ::ttk::button .ctrl.erase -text Erase -command Erase
    ::ttk::label .ctrl.l1 -text "Type-In\nFields" -font myFont
    entry .ctrl.key1 -width 2 -font myFont -textvariable C(key1) -justify center
    entry .ctrl.key0 -width 2 -font myFont -textvariable C(key0) -justify center
    focus .ctrl.key1
    foreach var {key0 key1} {
        foreach tr [trace vinfo C($var)] {
            eval trace vdelete C($var) $tr
        }
        trace variable C($var) w KeyTrace
    }

    pack .ctrl.key0 -side bottom
    pack .ctrl.key1 -side bottom -pady {0 5}

    set pady .01i
    pack .ctrl.l1 -side bottom -pady {.1i 0}
    pack .ctrl.erase -side bottom -pady $pady
    pack .ctrl.help -side bottom -pady $pady
    pack .ctrl.retype -side bottom -pady $pady
    pack .ctrl.info -side top

    # Solution window
    set opts "-font myFont"
    append opts " -relief sunken -bd 1"
    append opts " -width 0"
    append opts " -state disabled"

    for {set row 0} {$row < $C(CipherLines)} {incr row} {
        set w .txt.f$row
        text ${w}plain {*}$opts -height 1 -foreground red
        text ${w}cipher {*}$opts -height 1
        ${w}cipher tag config highlightLetter -background cyan
        pack ${w}plain -side top -fill x
        pack ${w}cipher -side top -fill x -pady {0 .05i}
    }

    bind all <Key-F1> Help
    bind all <Key-F2> {console show}
    bind all <Control-h> Hint
    bind all <Control-s> Solution
    bind all <Control-c> CheatSheet
    bind all <Control-z> Undo
}
##+##########################################################################
#
# DoCanvas -- draws histogram and cipher/deciphered letters chart
#
proc DoCanvas {} {
    global C XY

    entry .c.c -width 2 -relief sunken -justify center -font myFont
    set eWidth [winfo reqwidth .c.c]
    set eHeight [winfo reqheight .c.c]
    set opts "-width 2 -justify center -state disabled -font myFont"
    append opts " -disabledbackground [.c.c cget -background]"
    append opts " -disabledforeground [.c.c cget -foreground]"
    destroy .c.c

    set x [expr {$eWidth/2}]
    set y0 $C(height)
    set y1 [expr {$y0 - $eHeight - 5}]
    set y2 [expr {$y1 - $eHeight - 5}]
    set XY(bottom) $y2

    foreach ch $::AB {
        set XY($ch) $x
        entry .c.c$ch {*}$opts -textvariable C(key,$ch)
        set C(key,$ch) ""
        .c create window $x $y0 -window .c.c$ch -anchor s

        entry .c.p$ch -width 2 -font myFont -justify center -relief flat \
            -disabledforeground blue -disabledbackground [.c cget -bg]
        .c.p$ch insert end $ch
        .c.p$ch config -state disabled
        bind .c.p$ch <1> [list FauxKey $ch]
        .c create window $x $y1 -window .c.p$ch -anchor s
        incr x $eWidth

    }
    .c config -width $x
}
##+##########################################################################
#
# KeyTrace -- Handles key presses in type-in fields
#
proc KeyTrace {var1 var2 op} {
    global C ch

    set ch [string toupper $C($var2)]
    if {! [string is alpha $ch]} { set ch "" }
    set C($var2) $ch

    if {$var2 eq "key1"} {                      ;# In top, focus to bottom
        if {$ch ne ""} {tk::TabToWindow .ctrl.key0}
        HighlightCipherLetter $C(key1)
        return
    }

    if {$var2 eq "key0" && $C(key1) eq ""} {    ;# In bottom, empty top : refocus
        set C(key0) ""
        tk::TabToWindow .ctrl.key1
        return
    }

    DecipherLetter $C(key1) $C(key0)
    set C(key0) ""
    set C(key1) ""
    Decipher
    tk::TabToWindow .ctrl.key1
    HighlightCipherLetter $C(key1)
    IsSolved
}
##+##########################################################################
#
# DecipherLetter -- substitutes deciphered letter for the ciphered letter
#
proc DecipherLetter {ciphered deciphered {addUndo 1}} {
    global C

    if {$C(key,$ciphered) eq $deciphered} return

    set undo {}

    foreach arr [array names C key,*] { ;# Check for already in use
        if {$C($arr) eq $deciphered && $deciphered ne ""} {
            set txt "The letter '$deciphered' has already been choosen -- Replace?"
            set n [tk_messageBox -icon question -message $txt -type yesno \
                       -title $C(title) -parent .]
            if {$n eq "no"} return

            set ch [lindex [split $arr ","] 1]
            lappend undo $ch $deciphered
            set C($arr) ""
        }
    }

    if {$addUndo} {
        set undo [list $ciphered $C(key,$ciphered) {*}$undo]
        set C(undo) [concat [list $undo] $C(undo)]
    }
    set C(key,$ciphered) $deciphered
}
##+##########################################################################
#
# Undo -- Undoes the last change
#
proc Undo {} {
    global C

    set C(undo) [lassign $C(undo) this]
    foreach {ciphered deciphered} $this {
        DecipherLetter $ciphered $deciphered 0
    }
    Decipher
    set C(key0) ""
    set C(key1) ""
    tk::TabToWindow .ctrl.key1
}
##+##########################################################################
#
# FauxKey -- Produce fake key presses based on mouse clicks
#
proc FauxKey {ltr} {
    global C
    set w [focus]
    if {$w eq ".ctrl.key1"} {
        set C(key1) $ltr
    } elseif {$w eq ".ctrl.key0"} {
        set C(key0) $ltr
    }
}
##+##########################################################################
#
# PrepCipherText -- Turns cipher text into workable format
#
proc PrepCipherText {cipher {plain ""} {hint ""}} {
    global C

    set C(solved) 0
    set C(undo) ""
    set C(cipher) [string trim [string toupper $cipher]]
    regsub -all {\s+} $C(cipher) " " C(cipher)
    set C(plain) [string trim [string toupper $plain]]
    regsub -all {\s+} $C(plain) " " C(plain)
    set C(hint) $hint

    Highlight 0
    set txt [::textutil::adjust $C(cipher) -length 60 -strictlength true]
    set lines [split $txt \n]

    for {set i 0} {$i < $C(CipherLines)} {incr i} {
        set C($i,cipher) [lindex $lines $i]
        regsub -all {[A-Z]} $C($i,cipher) " " C($i,plain)
        foreach who {plain cipher} {
            set w .txt.f${i}$who
            $w config -state normal
            $w delete 1.0 end
            $w insert end $C($i,$who)
            $w config -state disabled
        }
    }
    Histogram
}
##+##########################################################################
#
# Histogram -- Draws histogram of letter usage
#
proc Histogram {} {
    global C XY cnt

    unset -nocomplain cnt

    regsub -all {[^A-Z]} $C(cipher) "" txt
    set max 0
    foreach ch [split $txt ""] {
        incr cnt($ch)
        if {$cnt($ch) > $max} { set max $cnt($ch) }
    }

    set sc [expr {($XY(bottom)-5) / double($max)}]
    .c delete histogram
    foreach ch [array names cnt] {
        set y [expr {$XY(bottom) - $cnt($ch) * $sc}]
        .c create line $XY($ch) $XY(bottom) $XY($ch) $y -tag histogram \
            -width 5 -fill magenta -capstyle round
    }
}
##+##########################################################################
#
# Decipher -- Applies current cipher/deciphered pairings
#
proc Decipher {} {
    global C

    set mapping {}
    foreach ltr $::AB {
        set ltr2 [expr {$C(key,$ltr) eq "" ? " " : $C(key,$ltr)}]
        lappend mapping $ltr $ltr2
    }
    for {set i 0} {$i < $C(CipherLines)} {incr i} {
        if {! [info exists C($i,cipher)]} break
        set C($i,plain) [string map $mapping $C($i,cipher)]
        .txt.f${i}plain config -state normal
        .txt.f${i}plain delete 1.0 end
        .txt.f${i}plain insert end $C($i,plain)
        .txt.f${i}plain config -state disabled
    }
    InUse
}
##+##########################################################################
#
# InUse -- Marks all letters currently used
#
proc InUse {} {
    global C

    array set RC [lreverse [array get C key,*]]
    foreach ch $::AB {
        set clr [expr {[info exists RC($ch)] ? "green" : [.c cget -bg]}]
        .c.p$ch config -disabledbackground $clr
    }
}
##+##########################################################################
#
# Hint -- Shows hint if we have one
#
proc Hint {} {
    global C
    set msg $C(hint)
    if {$C(hint) eq ""} {
        set msg "No hint available"
    }
    tk_messageBox -icon info -message $msg -title "$C(title) Hint" -parent .
}
##+##########################################################################
#
# Solution -- Shows solution if we have one
#
proc Solution {} {
    global C
    set msg [::textutil::adjust $C(plain) -length 60 -strictlength true]
    if {$C(plain) eq ""} {
        set msg "No solution available"
    }
    tk_messageBox -icon info -message $msg -title "$C(title) Solution" -parent .
}
##+##########################################################################
#
# Erase -- Erase current cipher/deciphered letter pairings
#
proc Erase {} {
    global C

    set undo {}
    foreach ch $::AB {
        if {$C(key,$ch) ne ""} {
            lappend undo $ch $C(key,$ch)
            set C(key,$ch) ""
        }
    }
    if {$undo eq {}} {                          ;# Double erase clears undo
        set C(undo) {}
    } else {
        set C(undo) [concat [list $undo] $C(undo)]
    }
    Decipher
    focus .ctrl.key1
}
proc Shuffle {llist} {
    set len [llength $llist]
    set len2 $len
    for {set i 0} {$i < $len-1} {incr i} {
        set n [expr {int($i + $len2 * rand())}]
        incr len2 -1

        # Swap elements at i & n
        set temp [lindex $llist $i]
        lset llist $i [lindex $llist $n]
        lset llist $n $temp
    }
    return $llist
}
##+##########################################################################
#
# GetCipherText -- Puts up dialog for getting cipher text
#
proc GetCipherText {} {
    set W .get
    destroy $W
    toplevel $W -padx .1i -pady .1i
    wm title $W "Enter Cryptogram"
    catch {wm attribute $W -toolwindow 1}
    wm protocol $W WM_DELETE_WINDOW DoneCipherText
    wm transient $W .
    wm withdraw $W

    ::ttk::label $W.l -text "Enter cryptogram here" -font {Times 14 bold}
    text $W.t -wrap word -height 13

    ::ttk::button $W.sample -text Sample -command GrabSample
    ::ttk::button $W.solve -text Solve -command DoneCipherText
    ::ttk::button $W.cryptocorner -text "Cryptogram\nCorner" \
        -command GetTodaysCryptogramCorner

    grid $W.l -columnspan 2 -sticky w
    grid $W.t -columnspan 2
    grid $W.sample $W.solve -pady .1i
    grid $W.cryptocorner

    ::ttk::label $W.lsample -textvariable ::C(sample,info)
    place $W.lsample -in $W.sample -relx 1 -y 0 -anchor nw

    update idletasks
    scan [wm geom .] "%dx%d+%d+%d" . . x y
    wm geom $W +[incr x 20]+[incr y 20]
    #RightWindow $W .
    wm deiconify $W

    grab $W
    $W.t insert end $::C(cipher)
    focus $W.t
}
##+##########################################################################
#
# DoneCipherText -- Exits GetCipherText dialog
#
proc DoneCipherText {} {
    global C

    set txt [string trim [.get.t get 1.0 "end - 1 char"]]
    if {$txt eq ""} return
    destroy .get

    set plain [set hint ""]
    if {[info exists C(sample,cipher)] && $txt eq $C(sample,cipher)} {
        set plain $C(sample,plain)
        set hint [GetHint $txt $plain]
    } else {
        set C(sample,info) ""
    }
    PrepCipherText $txt $plain $hint
    Decipher
    raise .
    focus .ctrl.key1
}
proc GetRandom {{idx ""}} {
    if {$idx eq ""} {
        set idx [expr {int(rand() * [llength $::samples])}]
    }
    set plain [lindex $::samples $idx]
    set cipher [Encrypt $plain]
    set hint [GetHint $cipher $plain]

    set ::C(sample,idx) $idx
    set ::C(sample,cipher) $cipher
    set ::C(sample,plain) $plain
    set ::C(sample,info) "#$idx of [llength $::samples]"

    PrepCipherText $cipher $plain $hint
    Decipher
    raise .
    focus .ctrl.key1
}
##+##########################################################################
#
# GrabSample -- Gets a sample from our built in list
#
proc GrabSample {} {
    set idx [expr {int(rand() * [llength $::samples])}]
    set plain [lindex $::samples $idx]
    set cipher [Encrypt $plain]

    .get.t delete 1.0 end
    .get.t insert end $cipher

    set ::C(sample,idx) $idx
    set ::C(sample,cipher) $cipher
    set ::C(sample,plain) $plain
    set ::C(sample,info) "#$idx of [llength $::samples]"
}
##+##########################################################################
#
# Encrypt -- Encrypts plain text with a random substitution key
#
proc Encrypt {plain} {
    while {1} {
        set key [Shuffle $::AB]
        set ok 1
        set mapping {}
        foreach a $::AB b $key {
            lappend mapping $a $b
            if {$a == $b} {                     ;# Letter can't map to itself
                set ok 0
                break
            }
        }
        if {$ok} break
    }
    set cipher [string map $mapping $plain]
    return $cipher
}
##+##########################################################################
#
# GetHint -- Grabs a random hint from plain/cipher text
#
proc GetHint {cipher plain} {
    regsub -all {[^A-Z]} $cipher "" cipher
    regsub -all {[^A-Z]} $plain "" plain
    set idx [expr {int(rand() * [string length $cipher])}]
    set hint "[string index $cipher $idx]=[string index $plain $idx]"
    return $hint
}
##+##########################################################################
#
# GetTodaysCryptogramCorner -- Scraps todays cryptogram from
# Cryptogram Corner web site.
#
proc GetTodaysCryptogramCorner {} {
    destroy .get

    set url http://www.geocities.com/cryptogramcorner/
    set html [DownloadPage $url]
    set month [ScrapCryptogramCorner $html]

    set thisDay [clock format [clock seconds] -format %d]
    set thisDay [expr {$thisDay > 0 ? $thisDay-1 : $thisDay}]
    lassign [lindex $month $thisDay] cipher plain hint
    PrepCipherText $cipher $plain $hint
    set ::C(sample,info) ""
    set ::C(sample,index) ""
}
proc GetYearOfCryptogramCorner {year} {
    if {$year < 2000} { error "year must be 2000 or greater" }

    set samples {}
    foreach month {jan feb mar apr may jun jul aug sep oct nov dec} {
        set date "$month[string range $year end-1 end]"
        puts "fetching $date"
        set url "http://www.geocities.com/cryptogramcorner/${date}.htm"
        if {[catch {set html [DownloadPage $url]}]} {
            puts "  error: skipping $date"
            continue
        }
        set all [ScrapCryptogramCorner $html]
        set samples [concat $samples $all]
    }
    set plainSamples ""
    set cnt 0
    foreach sample $samples {
        set plain [lindex $sample 1]
        if {$plain ne ""} {
            append plainSamples "    {$plain}\n"
            incr cnt;
        }
    }

    puts "total: $cnt"
    return $plainSamples
}
##+##########################################################################
#
# ScrapCryptogramCorner -- Scraps all cryptograms puzzle from the
# html for Cryptogram Corner.
#
proc ScrapCryptogramCorner {html} {
    global SAMPLES

    set re "if\\s*?\\(\\s*?thisday\\s*?==\\s*?\\d+?.*?\}"

    foreach match [regexp -all -inline $re $html] {
        set n [regexp {thisday\s*==\s*(\d+)} $match . thisDay]
        if {! $n} { error "can't extract thisDay" }

        set all [regexp -all -inline {VAR[123]="(.*?)"} $match]
        if {$all ne ""} {
            lassign $all . var1 . var2 . var3
            set SAMPLES(cipher,$thisDay) "$var1 $var2 $var3"
            set n [regexp {msg\s*?=\s*?"(.=.)"} $match . SAMPLES(hint,$thisDay)]
            if {! $n} { error "can't extract hint for $thisDay" }
        } else {
            regsub -all {"<.*?>"} $match "" match
            regsub -all {"Keyword:.*?"} $match "" match
            set txt [join [regexp -inline -all {".*?"} $match]]
            set txt [string map {\" ""} $txt]
            set SAMPLES(plain,[expr {$thisDay-1}]) $txt
        }
    }
    set all {}
    foreach arr [lsort -dictionary [array names SAMPLES cipher,*]] {
        set thisDay [lindex [split $arr ","] 1]
        set plain [expr {[info exists SAMPLES(plain,$thisDay)] \
                             ? $SAMPLES(plain,$thisDay) : ""}]
        set hint [expr {[info exists SAMPLES(hint,$thisDay)] \
                            ? $SAMPLES(hint,$thisDay) : ""}]
        lappend all [list $SAMPLES($arr) $plain $hint]
    }
    return $all
}
proc ValidateSample {thisDay cipher plain hint} {
    if {$plain eq ""} {
        if {$thisDay != 31} {
            puts "  no plain text: $thisDay"
        }
        return 0
    }
    regsub -all {[^A-Z ]} $cipher "" cipher
    regsub -all {[A-Z]} $cipher "@" cipher
    regsub -all {\s+} $cipher " " cipher
    regsub -all {[^A-Z ]} $plain "" plain
    regsub -all {[A-Z]} $plain "@" plain
    regsub -all {\s+} $plain " " plain
    if {$cipher ne $plain} {
        puts "  bad text: $thisDay"
        return 0
    }
    if {$hint eq ""} {
        puts "  no hint: $thisDay"
        return 0
    }
    return 1
}
##+##########################################################################
#
# DownloadPage -- fetches a web page
#
proc DownloadPage {url} {
    set token [::http::geturl $url]
    ::http::wait $token
    if {[::http::ncode $token] != 200} {
        error "cannot download $url: [::http::ncode $token]"
    }
    set html [::http::data $token]
    ::http::cleanup $token
    return $html
}
##+##########################################################################
#
# IsSolved -- Determines if we've solved the cryptogram
#
proc IsSolved {} {
    global C

    if {$C(solved)} return
    if {$C(plain) eq ""} return

    set plain [string trim "$C(0,plain) $C(1,plain) $C(2,plain) $C(3,plain)"]
    if {$plain ne $C(plain)} return
    set C(solved) 1
    Highlight 1
    catch {
        set fname [file join [pwd] [file dirname $::argv0] solved.txt]
        set fout [open $fname a]
        puts $fout "$C(sample,idx) [clock format [clock seconds]]"
        close $fout
    }
}
##+##########################################################################
#
# Highlight -- Highlights display for victory
#
proc Highlight {onOff} {
    set clr [expr {$onOff ? "yellow" : "white"}]
    foreach w [winfo child .txt] {
        $w config -background $clr
    }
}
##+##########################################################################
#
# HighlightCipherLetter -- Highlights a letter in the cryptogram
#
proc HighlightCipherLetter {ltr} {
    global C

    for {set row 0} {$row < $C(CipherLines)} {incr row} {
        set w .txt.f${row}cipher
        ${w} config -state normal
        $w tag remove highlightLetter 1.0 end
        if {$ltr ne ""} {
            foreach idxs [regexp -all -inline -indices $ltr $C($row,cipher)] {
                set idx [lindex $idxs 0]
                $w tag add highlightLetter 1.$idx 1.[expr {$idx+1}]
            }
        }
        ${w} config -state disabled
    }
}
##+##########################################################################
#
# RightWindow -- Positions window on right edge of the main window
#
proc RightWindow {w {W .}} {
    update idletasks

    set W [winfo toplevel $W]
    set y [expr {3 + [winfo y $W]}]              ;# Top of main window
    set x [expr {15 + [winfo x $W] + [winfo width $W]}] ;# Right side

    set right [expr {$x + [winfo reqwidth $w]}]
    if {$right > [winfo screenwidth $W] + 20} {
        wm geom $w -0+$y
    } else {
        wm geom $w +$x+$y
    }
}