"Fossies" - the Fresh Open Source Software Archive

Member "Pansophica-src-1.3/BAF_modules/NetReality/install/.tcl/widgets/a_wins.tcl" (10 Apr 2007, 3461 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 # The contents of this file are subject to the NeuralVR Public License
    2 # Version 1.0 (the "NPL"); you may not use this file except in
    3 # compliance with the NPL.  You may obtain a copy of the NPL at
    4 # http://www.neuralvr.com/NPL/
    5 # 
    6 # Software distributed under the NPL is distributed on an "AS IS" basis,
    7 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the NPL
    8 # for the specific language governing rights and limitations under the
    9 # NPL.
   10 # 
   11 # The Initial Developer of this code under the NPL is NeuralVR
   12 # Technologies Ltd.  Portions created by NeuralVR are Copyright 
   13 # (c) MMIII, NeuralVR Technologies Ltd. All Rights Reserved.
   14 
   15 # MODULE: a_wins.tcl
   16 # $Id: a_wins.tcl,v 1.3 2003/10/22 03:55:04 dean Exp $
   17 
   18 # SYNOPSIS
   19 # Routines handy in management of windows and dialogs
   20 
   21 # HISTORY
   22 # $Log: a_wins.tcl,v $
   23 # Revision 1.3  2003/10/22 03:55:04  dean
   24 # updated copyrighting licensing
   25 #
   26 # Revision 1.2  2003/05/07 20:35:23  dean
   27 # purged visible NeuralVR references
   28 #
   29 # Revision 1.1  1999/10/22 18:23:49  dean
   30 # object files borrowed from NetReality
   31 #
   32 # Revision 1.1  1999/08/26 18:59:28  dean
   33 # initial import of v1 interface beginnings
   34 #
   35 # Revision 1.1.1.1  1999/01/21 20:42:29  dean
   36 # initial import of the new BAF_modules
   37 #
   38 # Revision 1.2  1998/12/04 18:31:34  dean
   39 # Added NPL notification, some code convention and macro updates
   40 #
   41 
   42 # Created May 24, 98 by dab
   43 
   44 #
   45 # creates a window of given class
   46 #
   47 proc a_winsNew { path class \
   48     {title Untitled} {width 0} {height 0} \
   49     {icon @.tcl/icons/window.xbm} {mask @.tcl/icons/window_mask.xbm} } {
   50 
   51     # if the window exists, then raise it
   52     if { [winfo exists $path] } then {
   53     raise $path
   54     return
   55     }
   56 
   57     switch -exact -- $class {
   58     Plate {
   59         a_winsNewPlate $path $class \
   60         $title $width $height \
   61         $icon $mask
   62     }
   63     Normal {
   64         a_winsNewNormal $path $class \
   65         $title $width $height \
   66         $icon $mask
   67     }
   68     default {
   69             return -code error "un-implemented window class"
   70     }
   71     }
   72 
   73     # caller shows
   74     return $path
   75 }
   76 
   77 
   78 #
   79 # shows a window
   80 #
   81 proc a_winsShow { path } {
   82 
   83     wm deiconify $path
   84     update
   85 
   86 }
   87 
   88 #
   89 # centers window on the screen
   90 #
   91 proc a_winsCenter { path } {
   92 
   93     if { ![winfo exists $path] } { return code -error "window doesn't exist" }
   94 
   95     # needed to flush everything to get things calced for the center
   96     update
   97 
   98     set winWidth [winfo reqwidth $path]
   99     set winHeight [winfo reqwidth $path]
  100 
  101     set width [winfo screenwidth .]
  102     set height [winfo screenheight .]
  103 
  104     set x [expr ($width/2) - ($winWidth/2)]
  105     set y [expr ($height/2) - ($winHeight/2)]
  106 
  107     wm geometry $path +$x+$y
  108 }
  109 
  110 #
  111 # a new plate-type window
  112 #
  113 proc a_winsNewPlate { path class title width height icon mask } {
  114 
  115     # parse out the args, others come from rc
  116     toplevel $path -class Plate
  117     wm withdraw $path
  118     if { $width != 0 && $height != 0 } then {
  119     wm geometry $path ${width}x${height}
  120     }
  121     wm transient $path .
  122     wm override $path 1
  123     wm resizable $path 0 0 
  124     wm iconbitmap $path $icon
  125     wm iconmask $path $mask  
  126 
  127     # set the variable user-configurables
  128     wm title $path $title
  129 }
  130 
  131 #
  132 # a normal window
  133 #
  134 proc a_winsNewNormal { path class title width height icon mask } {
  135 
  136     # parse out the args, others come from rc
  137     toplevel $path -class Normal
  138     wm withdraw $path
  139     wm geometry $path ${width}x${height}
  140     wm iconbitmap $path $icon
  141     wm iconmask $path $mask  
  142 
  143     # set the variable user-configurables
  144     wm title $path $title
  145 }
  146 
  147 
  148