mdw@git.distorted.org.uk Git - anag/blob - anag-gui.in

   1 #! @WISH@
   2 ### -*-tcl-*-
   3 ###
   4 ### Graphical frontend for `anag'
   5 ###
   6 ### (c) 2002 Mark Wooding
   7 ###
   8
   9 ###----- Licensing notice ---------------------------------------------------
  10 ###
  11 ### This file is part of Anag: a simple wordgame helper.
  12 ###
  13 ### Anag is free software; you can redistribute it and/or modify
  14 ### it under the terms of the GNU General Public License as published by
  15 ### the Free Software Foundation; either version 2 of the License, or
  16 ### (at your option) any later version.
  17 ###
  18 ### Anag is distributed in the hope that it will be useful,
  19 ### but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ### GNU General Public License for more details.
  22 ###
  23 ### You should have received a copy of the GNU General Public License
  24 ### along with Anag; if not, write to the Free Software Foundation,
  25 ### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  26
  27 ###--------------------------------------------------------------------------
  28 ### Configuration.
  29
  30 if {[info exists env(HOME)]} {
  31   set home $env(HOME)
  32 } else {
  33   set bin [info nameofexecutable]
  34   if {[string compare $bin ""] == 0} {
  35     set home "."
  36   } else {
  37     set home [file dirname $bin]
  38   }
  39 }
  40 set conffile [list "/etc/anagrc" \
  41                   [file join $home "anagrc"]]
  42 if {[string compare "unix" $tcl_platform(platform)] == 0} {
  43   lappend conffile [file join $home ".anagrc"]
  44 }
  45 set C_tags {anag wordlist}
  46 set C(anag) "@ANAG@"
  47 set C(wordlist) "@DICTIONARY@"
  48
  49 foreach i $C_tags {
  50   if {![info exists C($i)]} {
  51     error "internal error: unset configuration option `$i'"
  52   }
  53 }
  54
  55 foreach f $conffile {
  56   if {[catch { set fh [open $f] } err]} { continue }
  57   while {[gets $fh line] >= 0} {
  58     if {[regexp {^[[:space:]]*(\#|$)} $line]} continue
  59     regexp {^\s*([[:alnum:]]\w*)\s*=?\s*(|.*\S)\s*$} $line - n v
  60     set C($n) $v
  61   }
  62   close $fh
  63   break
  64 }
  65
  66 ###--------------------------------------------------------------------------
  67 ### Other setting up.
  68
  69 if {[string compare "windows" $tcl_platform(platform)] == 0} {
  70   set exetypes {
  71     {Executables   {.exe} {}}
  72     {All files     {*}    {}}
  73   }
  74 } else {
  75   set exetypes {}
  76 }
  77
  78 ###--------------------------------------------------------------------------
  79 ### Handy subroutines.
  80
  81 proc wordlist {args} {
  82   set l {}
  83   foreach s $args {
  84     while {![regexp {^\s*$} $s]} {
  85       regexp {^\s*(\S+)(.*)$} $s - w s
  86       lappend l $w
  87     }
  88   }
  89   return $l
  90 }
  91
  92 proc report {msg} {
  93   tk_messageBox -type ok -icon error \
  94       -title "Error from [wm title .]" -message $msg
  95 }
  96
  97 ###--------------------------------------------------------------------------
  98 ### Options.
  99
 100 proc conf-copyout {} {
 101   global C C_tags
 102   foreach i $C_tags {
 103     upvar \#0 C:$i c
 104     set c $C($i)
 105   }
 106 }
 107
 108 proc conf-copyin {} {
 109   global C C_tags
 110   foreach i $C_tags {
 111     upvar \#0 C:$i c
 112     set C($i) $c
 113   }
 114 }
 115
 116 proc options {} {
 117   global C C_tags tcl_platform home conffile
 118
 119   if {[winfo exists .opt]} {
 120     raise .opt
 121     return
 122   }
 123
 124   toplevel .opt
 125   wm title .opt "[wm title .] options"
 126   conf-copyout
 127
 128   frame .opt.anag
 129   label .opt.anag.l -text "Anagram solver binary: "
 130   entry .opt.anag.e -textvariable C:anag
 131   button .opt.anag.b -text "..." -command {
 132     set C:anag [tk_getOpenFile -parent .opt \
 133         -title "Anagram solver binary" -filetypes $exetypes \
 134         -initialdir [file dirname ${C:anag}]]
 135   }
 136   pack .opt.anag.l -side left -padx 2 -pady 2
 137   pack .opt.anag.e -side left -expand yes -fill x -padx 2 -pady 2
 138   pack .opt.anag.b -side left -padx 2 -pady 2
 139
 140   frame .opt.wordlist
 141   label .opt.wordlist.l -text "Wordlist file: "
 142   entry .opt.wordlist.e -textvariable C:wordlist
 143   button .opt.wordlist.b -text "..." -command {
 144     set C:wordlist [tk_getOpenFile -parent .opt \
 145         -title "Wordlist file" \
 146         -initialdir [file dirname ${C:wordlist}]]
 147   }
 148   pack .opt.wordlist.l -side left -padx 2 -pady 2
 149   pack .opt.wordlist.e -side left -expand yes -fill x -padx 2 -pady 2
 150   pack .opt.wordlist.b -side left -padx 2 -pady 2
 151
 152   frame .opt.b
 153   button .opt.b.cancel -text "Cancel" -command { destroy .opt }
 154   button .opt.b.ok -text "OK" -command { conf-copyin; destroy .opt }
 155   button .opt.b.save -default active -text "Save" -command {
 156     set tf [lindex $conffile end]
 157     if {[catch {
 158       set date [clock format [clock seconds] -format "%Y-%m-%s %H:%M:%S"]
 159       set fh [open "$tf.new" w]
 160       puts $fh "# Anagram settings, written $date"
 161       puts $fh ""
 162       foreach n $C_tags {
 163         upvar \#0 C:$n c
 164         puts $fh "$n = $c"
 165       }
 166       close $fh
 167       file copy -force -- $tf "$tf.old"
 168       file rename -force -- "$tf.new" $tf
 169     } msg]} {
 170       catch { close $fh; file delete -- "$tf.new" }
 171       report $msg
 172       break
 173     }
 174     conf-copyin
 175     destroy .opt
 176   }
 177   pack .opt.b.cancel .opt.b.ok .opt.b.save -side left -padx 2 -pady 2
 178
 179   bind .opt <Return> { tkButtonInvoke .opt.b.save }
 180   bind .opt <Escape> { tkButtonInvoke .opt.b.cancel }
 181
 182   pack .opt.anag .opt.wordlist -expand yes -fill x
 183   pack .opt.b -anchor e
 184 }
 185
 186 ###--------------------------------------------------------------------------
 187 ### Run the command.
 188
 189 proc run-search {args} { run-search-v $args }
 190 proc run-search-v {v} {
 191   global C
 192   set v [linsert $v 0 | $C(anag) "--file" $C(wordlist)]
 193   if {[catch {set fh [open $v]} err]} { report $err; return }
 194   set l {}
 195   while {[gets $fh line] >= 0} { lappend l $line }
 196   if {[catch {close $fh} err]} { report $err; return }
 197   .list delete 0 end
 198   foreach i $l { .list insert end $i }
 199 }
 200
 201 ###--------------------------------------------------------------------------
 202 ### Construct the main window.
 203
 204 wm title . "Anagram solver"
 205 frame .f-entry
 206 frame .f-list
 207 frame .f-buttons
 208
 209 foreach {opt text mnem} {
 210   anagram Anagram a
 211   subgram Subgram s
 212   wildcard Crossword w
 213   trackword Trackword t
 214   mono Monoalphabetic m
 215   regexp "Regular expression" r
 216   pcre "Perl regexp" p
 217 } {
 218   button .b-$opt -text $text \
 219       -underline [string first $mnem [string tolower $text]] \
 220       -command [concat [list run-search -$opt] \$word]
 221   bind . <Alt-$mnem> [list tkButtonInvoke .b-$opt]
 222   pack .b-$opt -in .f-buttons -fill x -padx 2 -pady 2
 223 }
 224
 225 button .b-custom -text "Custom" -underline 0 \
 226     -command { run-search-v [wordlist $word] }
 227 bind . <Alt-c> { tkButtonInvoke .b-custom }
 228 pack .b-custom -in .f-buttons -fill x -padx 2 -pady 2
 229
 230 listbox .list \
 231   -xscrollcommand { .f-list.xscroll set } \
 232   -yscrollcommand { .f-list.yscroll set }
 233 scrollbar .f-list.xscroll -orient horizontal -command { .list xview }
 234 scrollbar .f-list.yscroll -orient vertical -command { .list yview }
 235
 236 entry .e-word -textvariable word
 237
 238 grid .list -in .f-list -row 0 -column 0 -sticky nsew
 239 grid .f-list.xscroll -row 1 -column 0 -sticky ew
 240 grid .f-list.yscroll -row 0 -column 1 -sticky ns
 241 grid rowconfigure .f-list 0 -weight 1
 242 grid columnconfigure .f-list 0 -weight 1
 243
 244 pack .e-word -in .f-entry -expand yes -fill x -padx 2 -pady 2
 245
 246 pack .f-entry -fill x
 247 pack .f-list -side left -expand yes -fill both
 248 pack .f-buttons -side left -anchor s
 249
 250 menu .menu
 251 .menu add cascade -label "File" -underline 0 -menu .menu.file
 252 menu .menu.file
 253 .menu.file add command -label "Options..." -underline 0 -command { options }
 254 .menu.file add command -label "Quit" -underline 0 -command { destroy . }
 255 . configure -menu .menu
 256
 257 focus .e-word
 258 bind .e-word <Return> { tkButtonInvoke .b-anagram }
 259
 260 ###----- That's all, folks --------------------------------------------------