"Fossies" - the Fresh Open Source Software Archive

Member "Pansophica-src-1.3/BAF_modules/tcl/src/a_wins.tcl" (4 Feb 2008, 3534 Bytes) of package /linux/www/old/Pansophica-src-1.3-1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "a_wins.tcl" see the Fossies "Dox" file reference documentation.

    1 # Pansophica, An intelligent, virtual-reality, web search agent
    2 # Copyright (C) MMVIII, NeuralVR Technologies Ltd.
    3 # 
    4 # This program is free software: you can redistribute it and/or modify
    5 # it under the terms of the GNU General Public License as published by
    6 # the Free Software Foundation, either version 3 of the License, or
    7 # (at your option) any later version.
    8 # 
    9 # This program is distributed in the hope that it will be useful,
   10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
   11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   12 # GNU General Public License for more details.
   13 # 
   14 # You should have received a copy of the GNU General Public License
   15 # along with this program.  If not, see http://www.gnu.org/licenses/.
   16 
   17 # MODULE: a_wins.tcl
   18 # $Id: a_wins.tcl,v 1.4 2008/02/04 04:21:22 dean Exp $
   19 
   20 # SYNOPSIS
   21 # Routines handy in management of windows and dialogs
   22 
   23 # HISTORY
   24 # $Log: a_wins.tcl,v $
   25 # Revision 1.4  2008/02/04 04:21:22  dean
   26 # updated to GPL
   27 #
   28 # Revision 1.3  2003/10/22 03:55:18  dean
   29 # updated copyrighting licensing
   30 #
   31 # Revision 1.2  2003/05/07 20:35:24  dean
   32 # purged visible NeuralVR references
   33 #
   34 # Revision 1.1  1999/08/26 18:59:28  dean
   35 # initial import of v1 interface beginnings
   36 #
   37 # Revision 1.1.1.1  1999/01/21 20:42:29  dean
   38 # initial import of the new BAF_modules
   39 #
   40 # Revision 1.2  1998/12/04 18:31:34  dean
   41 # Added NPL notification, some code convention and macro updates
   42 #
   43 
   44 # Created May 24, 98 by dab
   45 
   46 #
   47 # creates a window of given class
   48 #
   49 proc a_winsNew { path class \
   50     {title Untitled} {width 0} {height 0} \
   51     {icon @icons/window.xbm} {mask @icons/window_mask.xbm} } {
   52 
   53     # if the window exists, then raise it
   54     if { [winfo exists $path] } then {
   55     raise $path
   56     return
   57     }
   58 
   59     switch -exact -- $class {
   60     Plate {
   61         a_winsNewPlate $path $class \
   62         $title $width $height \
   63         $icon $mask
   64     }
   65     Normal {
   66         a_winsNewNormal $path $class \
   67         $title $width $height \
   68         $icon $mask
   69     }
   70     default {
   71             return -code error "un-implemented window class"
   72     }
   73     }
   74 
   75     # caller shows
   76     return $path
   77 }
   78 
   79 
   80 #
   81 # shows a window
   82 #
   83 proc a_winsShow { path } {
   84 
   85     wm deiconify $path
   86     update
   87 
   88 }
   89 
   90 #
   91 # centers window on the screen
   92 #
   93 proc a_winsCenter { path } {
   94 
   95     if { ![winfo exists $path] } { return code -error "window doesn't exist" }
   96 
   97     # needed to flush everything to get things calced for the center
   98     update
   99 
  100     set winWidth [winfo reqwidth $path]
  101     set winHeight [winfo reqwidth $path]
  102 
  103     set width [winfo screenwidth .]
  104     set height [winfo screenheight .]
  105 
  106     set x [expr ($width/2) - ($winWidth/2)]
  107     set y [expr ($height/2) - ($winHeight/2)]
  108 
  109     wm geometry $path +$x+$y
  110 }
  111 
  112 #
  113 # a new plate-type window
  114 #
  115 proc a_winsNewPlate { path class title width height icon mask } {
  116 
  117     # parse out the args, others come from rc
  118     toplevel $path -class Plate
  119     wm withdraw $path
  120     if { $width != 0 && $height != 0 } then {
  121     wm geometry $path ${width}x${height}
  122     }
  123     wm transient $path .
  124     wm override $path 1
  125     wm resizable $path 0 0 
  126     wm iconbitmap $path $icon
  127     wm iconmask $path $mask  
  128 
  129     # set the variable user-configurables
  130     wm title $path $title
  131 }
  132 
  133 #
  134 # a normal window
  135 #
  136 proc a_winsNewNormal { path class title width height icon mask } {
  137 
  138     # parse out the args, others come from rc
  139     toplevel $path -class Normal
  140     wm withdraw $path
  141     wm geometry $path ${width}x${height}
  142     wm iconbitmap $path $icon
  143     wm iconmask $path $mask  
  144 
  145     # set the variable user-configurables
  146     wm title $path $title
  147 }
  148 
  149 
  150