| 1 | #! /usr/bin/wish |
| 2 | |
| 3 | # --- Configuration --- |
| 4 | |
| 5 | if {[info exists env(HOME)]} { |
| 6 | set home $env(HOME) |
| 7 | } else { |
| 8 | set bin [info nameofexecutable] |
| 9 | if {[string compare $bin ""] == 0} { |
| 10 | set home "." |
| 11 | } else { |
| 12 | set home [file dirname $bin] |
| 13 | } |
| 14 | } |
| 15 | set conffile [list "/etc/anagrc" \ |
| 16 | [file join $home "anagrc"]] |
| 17 | if {[string compare "unix" $tcl_platform(platform)] == 0} { |
| 18 | lappend conffile [file join $home ".anagrc"] |
| 19 | } |
| 20 | set C_tags {anag wordlist} |
| 21 | set C(anag) "@ANAG@" |
| 22 | set C(wordlist) "@DICTIONARY@" |
| 23 | |
| 24 | foreach i $C_tags { |
| 25 | if {![info exists C($i)]} { |
| 26 | error "internal error: unset configuration option `$i'" |
| 27 | } |
| 28 | } |
| 29 | |
| 30 | foreach f $conffile { |
| 31 | if {[catch { set fh [open $f] } err]} { continue } |
| 32 | while {[gets $fh line] >= 0} { |
| 33 | if {[regexp {^[[:space:]]*(\#|$)} $line]} continue |
| 34 | regexp {^\s*([[:alnum:]]\w*)\s*=?\s*(|.*\S)\s*$} $line - n v |
| 35 | set C($n) $v |
| 36 | } |
| 37 | close $fh |
| 38 | break |
| 39 | } |
| 40 | |
| 41 | # --- Other setting up --- |
| 42 | |
| 43 | if {[string compare "windows" $tcl_platform(platform)] == 0} { |
| 44 | set exetypes { |
| 45 | {Executables {.exe} {}} |
| 46 | {All files {*} {}} |
| 47 | } |
| 48 | } else { |
| 49 | set exetypes {} |
| 50 | } |
| 51 | |
| 52 | # --- Handy subroutines --- |
| 53 | |
| 54 | proc wordlist {args} { |
| 55 | set l {} |
| 56 | foreach s $args { |
| 57 | while {![regexp {^\s*$} $s]} { |
| 58 | regexp {^\s*(\S+)(.*)$} $s - w s |
| 59 | lappend l $w |
| 60 | } |
| 61 | } |
| 62 | return $l |
| 63 | } |
| 64 | |
| 65 | proc report {msg} { |
| 66 | tk_messageBox -type ok -icon error \ |
| 67 | -title "Error from [wm title .]" -message $msg |
| 68 | } |
| 69 | |
| 70 | # --- Options --- |
| 71 | |
| 72 | proc conf-copyout {} { |
| 73 | global C C_tags |
| 74 | foreach i $C_tags { |
| 75 | upvar \#0 C:$i c |
| 76 | set c $C($i) |
| 77 | } |
| 78 | } |
| 79 | |
| 80 | proc conf-copyin {} { |
| 81 | global C C_tags |
| 82 | foreach i $C_tags { |
| 83 | upvar \#0 C:$i c |
| 84 | set C($i) $c |
| 85 | } |
| 86 | } |
| 87 | |
| 88 | proc options {} { |
| 89 | global C C_tags tcl_platform home conffile |
| 90 | |
| 91 | if {[winfo exists .opt]} { |
| 92 | raise .opt |
| 93 | return |
| 94 | } |
| 95 | |
| 96 | toplevel .opt |
| 97 | wm title .opt "[wm title .] options" |
| 98 | conf-copyout |
| 99 | |
| 100 | frame .opt.anag |
| 101 | label .opt.anag.l -text "Anagram solver binary: " |
| 102 | entry .opt.anag.e -textvariable C:anag |
| 103 | button .opt.anag.b -text "..." -command { |
| 104 | set C:anag [tk_getOpenFile -parent .opt \ |
| 105 | -title "Anagram solver binary" -filetypes $exetypes \ |
| 106 | -initialdir [file dirname ${C:anag}]] |
| 107 | } |
| 108 | pack .opt.anag.l -side left -padx 2 -pady 2 |
| 109 | pack .opt.anag.e -side left -expand yes -fill x -padx 2 -pady 2 |
| 110 | pack .opt.anag.b -side left -padx 2 -pady 2 |
| 111 | |
| 112 | frame .opt.wordlist |
| 113 | label .opt.wordlist.l -text "Wordlist file: " |
| 114 | entry .opt.wordlist.e -textvariable C:wordlist |
| 115 | button .opt.wordlist.b -text "..." -command { |
| 116 | set C:wordlist [tk_getOpenFile -parent .opt \ |
| 117 | -title "Wordlist file" \ |
| 118 | -initialdir [file dirname ${C:wordlist}]] |
| 119 | } |
| 120 | pack .opt.wordlist.l -side left -padx 2 -pady 2 |
| 121 | pack .opt.wordlist.e -side left -expand yes -fill x -padx 2 -pady 2 |
| 122 | pack .opt.wordlist.b -side left -padx 2 -pady 2 |
| 123 | |
| 124 | frame .opt.b |
| 125 | button .opt.b.cancel -text "Cancel" -command { destroy .opt } |
| 126 | button .opt.b.ok -text "OK" -command { conf-copyin; destroy .opt } |
| 127 | button .opt.b.save -default active -text "Save" -command { |
| 128 | set tf [lindex $conffile end] |
| 129 | if {[catch { |
| 130 | set date [clock format [clock seconds] -format "%Y-%m-%s %H:%M:%S"] |
| 131 | set fh [open "$tf.new" w] |
| 132 | puts $fh "# Anagram settings, written $date" |
| 133 | puts $fh "" |
| 134 | foreach n $C_tags { |
| 135 | upvar \#0 C:$n c |
| 136 | puts $fh "$n = $c" |
| 137 | } |
| 138 | close $fh |
| 139 | file copy -force -- $tf "$tf.old" |
| 140 | file rename -force -- "$tf.new" $tf |
| 141 | } msg]} { |
| 142 | catch { close $fh; file delete -- "$tf.new" } |
| 143 | report $msg |
| 144 | break |
| 145 | } |
| 146 | conf-copyin |
| 147 | destroy .opt |
| 148 | } |
| 149 | pack .opt.b.cancel .opt.b.ok .opt.b.save -side left -padx 2 -pady 2 |
| 150 | |
| 151 | bind .opt <Return> { tkButtonInvoke .opt.b.save } |
| 152 | bind .opt <Escape> { tkButtonInvoke .opt.b.cancel } |
| 153 | |
| 154 | pack .opt.anag .opt.wordlist -expand yes -fill x |
| 155 | pack .opt.b -anchor e |
| 156 | } |
| 157 | |
| 158 | # --- Run the command --- |
| 159 | |
| 160 | proc run-search {args} { run-search-v $args } |
| 161 | proc run-search-v {v} { |
| 162 | global C |
| 163 | set v [linsert $v 0 | $C(anag) "--file" $C(wordlist)] |
| 164 | if {[catch {set fh [open $v]} err]} { report $err; return } |
| 165 | set l {} |
| 166 | while {[gets $fh line] >= 0} { lappend l $line } |
| 167 | if {[catch {close $fh} err]} { report $err; return } |
| 168 | .list delete 0 end |
| 169 | foreach i $l { .list insert end $i } |
| 170 | } |
| 171 | |
| 172 | # --- Construct the main window --- |
| 173 | |
| 174 | wm title . "Anagram solver" |
| 175 | frame .f-entry |
| 176 | frame .f-list |
| 177 | frame .f-buttons |
| 178 | |
| 179 | foreach {opt text mnem} { |
| 180 | anagram Anagram a |
| 181 | subgram Subgram s |
| 182 | wildcard Crossword w |
| 183 | trackword Trackword t |
| 184 | mono Monoalphabetic m |
| 185 | regexp "Regular expression" r |
| 186 | pcre "Perl regexp" p |
| 187 | } { |
| 188 | button .b-$opt -text $text \ |
| 189 | -underline [string first $mnem [string tolower $text]] \ |
| 190 | -command [concat [list run-search -$opt] \$word] |
| 191 | bind . <Alt-$mnem> [list tkButtonInvoke .b-$opt] |
| 192 | pack .b-$opt -in .f-buttons -fill x -padx 2 -pady 2 |
| 193 | } |
| 194 | |
| 195 | button .b-custom -text "Custom" -underline 0 \ |
| 196 | -command { run-search-v [wordlist $word] } |
| 197 | bind . <Alt-c> { tkButtonInvoke .b-custom } |
| 198 | pack .b-custom -in .f-buttons -fill x -padx 2 -pady 2 |
| 199 | |
| 200 | listbox .list \ |
| 201 | -xscrollcommand { .f-list.xscroll set } \ |
| 202 | -yscrollcommand { .f-list.yscroll set } |
| 203 | scrollbar .f-list.xscroll -orient horizontal -command { .list xview } |
| 204 | scrollbar .f-list.yscroll -orient vertical -command { .list yview } |
| 205 | |
| 206 | entry .e-word -textvariable word |
| 207 | |
| 208 | grid .list -in .f-list -row 0 -column 0 -sticky nsew |
| 209 | grid .f-list.xscroll -row 1 -column 0 -sticky ew |
| 210 | grid .f-list.yscroll -row 0 -column 1 -sticky ns |
| 211 | grid rowconfigure .f-list 0 -weight 1 |
| 212 | grid columnconfigure .f-list 0 -weight 1 |
| 213 | |
| 214 | pack .e-word -in .f-entry -expand yes -fill x -padx 2 -pady 2 |
| 215 | |
| 216 | pack .f-entry -fill x |
| 217 | pack .f-list -side left -expand yes -fill both |
| 218 | pack .f-buttons -side left -anchor s |
| 219 | |
| 220 | menu .menu |
| 221 | .menu add cascade -label "File" -underline 0 -menu .menu.file |
| 222 | menu .menu.file |
| 223 | .menu.file add command -label "Options..." -underline 0 -command { options } |
| 224 | .menu.file add command -label "Quit" -underline 0 -command { destroy . } |
| 225 | . configure -menu .menu |
| 226 | |
| 227 | focus .e-word |
| 228 | bind .e-word <Return> { tkButtonInvoke .b-anagram } |
| 229 | |