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 button .b-anagram -text "Anagram" -underline 0 \
 180     -command { run-search "-anagram" $word }
 181 button .b-subgram -text "Subgram" -underline 0 \
 182     -command { run-search "-subgram" $word }
 183 button .b-glob -text "Crossword" -underline 5 \
 184     -command { run-search "-wildcard" $word }
 185 button .b-track -text "Trackword" -underline 0 \
 186     -command { run-search "-trackword" $word }
 187 button .b-regexp -text "Regexp" -underline 0 \
 188     -command { run-search "-regexp" $word }
 189
 190 button .b-custom -text "Custom" -underline 0 \
 191     -command { run-search-v [wordlist $word] }
 192
 193 listbox .list \
 194   -xscrollcommand { .f-list.xscroll set } \
 195   -yscrollcommand { .f-list.yscroll set }
 196 scrollbar .f-list.xscroll -orient horizontal -command { .list xview }
 197 scrollbar .f-list.yscroll -orient vertical -command { .list yview }
 198
 199 entry .e-word -textvariable word
 200
 201 grid .list -in .f-list -row 0 -column 0 -sticky nsew
 202 grid .f-list.xscroll -row 1 -column 0 -sticky ew
 203 grid .f-list.yscroll -row 0 -column 1 -sticky ns
 204 grid rowconfigure .f-list 0 -weight 1
 205 grid columnconfigure .f-list 0 -weight 1
 206
 207 pack .b-custom .b-track .b-regexp .b-glob .b-subgram .b-anagram \
 208     -in .f-buttons -fill x -padx 2 -pady 2
 209
 210 pack .e-word -in .f-entry -expand yes -fill x -padx 2 -pady 2
 211
 212 pack .f-entry -fill x
 213 pack .f-list -side left -expand yes -fill both
 214 pack .f-buttons -side left -anchor s
 215
 216 menu .menu
 217 .menu add cascade -label "File" -underline 0 -menu .menu.file
 218 menu .menu.file
 219 .menu.file add command -label "Options..." -underline 0 -command { options }
 220 .menu.file add command -label "Quit" -underline 0 -command { destroy . }
 221 . configure -menu .menu
 222
 223 focus .e-word
 224 bind .e-word <Return> { tkButtonInvoke .b-anagram }
 225
 226 bind . <Alt-a> { tkButtonInvoke .b-anagram }
 227 bind . <Alt-t> { tkButtonInvoke .b-track }
 228 bind . <Alt-s> { tkButtonInvoke .b-subgram }
 229 bind . <Alt-w> { tkButtonInvoke .b-glob }
 230 bind . <Alt-r> { tkButtonInvoke .b-regexp }
 231 bind . <Alt-c> { tkButtonInvoke .b-custom }