chiark - git - mdw - anag/blob - anag-gui.in

   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