Index: tolbase/lib/mkWidgets1.3/Document.tcl =================================================================== --- tolbase/lib/mkWidgets1.3/Document.tcl (revision 32535cc978d5243ae7e719ad626c93a8447e0c45) +++ tolbase/lib/mkWidgets1.3/Document.tcl (revision 32535cc978d5243ae7e719ad626c93a8447e0c45) @@ -0,0 +1,723 @@ +package require Metawidget + +# name: Document +# args: args: option-value pairs +# defines icons for the window title bar. defines a default menu and creates +# all standard window elements (MS Windows look&feel). declares option values. +metawidget create Document { + # if first object is being created, define some icons etc. + if { ! [ourinfo exists lAllDocs] } { + our lAllDocs {} ;# list of all document windows + our wFocus {} ;# topmost window (drawn active) + + # set platform dependend colors and cursor shapes + if { $::tcl_platform(platform) == "windows" } { + ourarray set aColors {gray50 SystemDisabledText white SystemWindow darkblue SystemHighlight gray SystemButtonFace} + ourarray set aCursors {{} {} nw size_nw_se ne size_ne_sw sw size_ne_sw se size_nw_se n size_ns s size_ns w size_we e size_we} + } else { + ourarray set aColors {gray50 gray50 white white darkblue darkblue gray gray} + ourarray set aCursors {{} {} nw top_left_corner ne top_right_corner sw bottom_left_corner se bottom_right_corner n sb_v_double_arrow s sb_v_double_arrow w sb_h_double_arrow e sb_h_double_arrow} + } + + # x/y-offset from top left corner + our iOffset 0 + + our pIconMin [image create bitmap -data { + #define _width 8 + #define _height 8 + static char _bits[] = { 0x00,0x00,0x00,0x00,0x00,0x3e,0x3e,0x00 }; + }] + our pIconMax [image create bitmap -data { + #define _width 8 + #define _height 8 + static char _bits[] = { 0x7f,0x7f,0x41,0x41,0x41,0x41,0x7f,0x00 }; + }] + our pIconRestore [image create bitmap -data { + #define _width 8 + #define _height 8 + static char _bits[] = { 0x7c,0x7c,0x44,0x5f,0x5f,0x71,0x11,0x1f }; + }] + our pIconClose [image create bitmap -data { + #define _width 8 + #define _height 8 + static char _bits[] = { 0x00,0x63,0x36,0x1c,0x1c,0x36,0x63,0x00 }; + }] + } + + # define popup menu + menu $this.menu -tearoff 0 +# $this.menu add command -label Restore -command "$this _restore" +# $this.menu add command -label Minimize -command "$this _minimize" +# $this.menu add command -label Maximize -command "$this _maximize" +# $this.menu add command -label Restore -command "::${this}::_restore" + $this.menu add command -label Minimize -command "::${this}::_minimize" + $this.menu add command -label Maximize -command "::${this}::_maximize" + $this.menu add separator + $this.menu add command -label Close -command "destroy $this" + + # create title bar elements + pack [frame $this.head -border 0] -padx 2 -pady 2 -fill x + pack [label $this.head.icon -border 0] -side left -padx 1 + pack [label $this.head.clob -border 2 -relief raised -image [our pIconClose]] -side right -pady 2 -padx 2 + pack [label $this.head.maxb -border 2 -relief raised -image [our pIconMax]] -side right -pady 2 + pack [label $this.head.minb -border 2 -relief raised -image [our pIconMin]] -side right -pady 2 + pack [label $this.head.text -border 0 -anchor w] -side left -fill x -expand 1 + + # work area where all inner widgets will be go + pack [frame $this.work -border 0] -fill both -expand 1 -padx 2 -pady 2 + + # make sure mouse cursor resets when not over the boarder + bind $this.work "$this config -cursor {}" + bind $this.head "$this config -cursor {}" + + # option values, self explaining + my -title $this + my -foreground [our aColors(white)] + my -background [our aColors(darkblue)] + my -font [$this.head.text cget -font] + my -minsize {100 30} + my -icontext {} + my -state normal + my -image {} + + # position and size of the window. note that later on, -x and -y contain + # either the icon or the window position, depending on the window's state. + my iNormX [our iOffset] + my iNormY [our iOffset] + my -width 250 + my -height 150 + + # bind menu to icon and close button + bind $this.head.icon <1> "$this _showMenu" + bind $this.head.icon "$this.menu invoke Close" + bind $this.head.clob <1> "$this.menu invoke Close" + + # increase offset for next window + our iOffset [expr [our iOffset]+16] + if { [expr [our iOffset]+64] > [winfo height [winfo parent $this]] } { + our iOffset 0 + } + + # show in normal mode and put it on top + _restore + raise_ + + # add it to the list of all documents + _register +} { + if { [our wFocus] == $this } { + our wFocus {} + } + + # remove it from all documents + _unregister +} -border 2 -relief raised + +# name: _register +# args: o Document object to register +# adds the current object to a list. required for geometry management. +metawidget proc Document _register {} { + our lAllDocs [linsert [our lAllDocs] end $this] +} + +# name: _unregister +# args: o Document object to unregister +# removes the object from this list. +metawidget proc Document _unregister {} { + our lAllDocs [mkw.lshrink [our lAllDocs] $this] +} + +# name: _showMenu +# args: - +# displays the popup menu right under the document's icon +metawidget proc Document _showMenu {} { + $this.menu post [winfo rootx $this.head.icon] \ + [expr [winfo height $this.head.icon] + [winfo rooty $this.head.icon]] + + bind $this.menu "$this.menu unpost" +} + +# name: _getEdge +# args: iXp, iYp: mouse position +# called only when the mouse is over the document's border. returns an area +# indicator of the mouse position, e.g. sw for south-west = bottom left. +# used to set the mouse cursor and to determine the resize mode. +metawidget proc Document _getEdge { iXp iYp } { + incr iXp -[winfo rootx $this] + incr iYp -[winfo rooty $this] + + # allow max. 16 pixel for edge detection + set iXEdge [expr ([my -width ] < 32)?[my -width ]>>1:16] + set iYEdge [expr ([my -height] < 32)?[my -height]>>1:16] + + # detect if mouse is on one of the edges (x coordinate) + if { $iXp < $iXEdge } { + set sPosH w + } elseif { $iXp > [expr [my -width]-$iXEdge] } { + set sPosH e + } else { + set sPosH {} + } + + # detect if mouse is on one of the edges (y coordinate) + if { $iYp < $iYEdge } { + set sPosV n + } elseif { $iYp > [expr [my -height]-$iYEdge] } { + set sPosV s + } else { + set sPosV {} + } + + return $sPosV$sPosH +} + +# name: _motion +# args: iXp, iYp: mouse position (from the %X and %Y fields of an event) +# called by a binding over the document frame. Sets the mouse cursor +# to show arrows depending on the region of the mouse. _getEdge returns an +# area (e.g. ne for north-east = upper right corner), the aCursor array +# maps this to a valid cursor name (depending on platform). +metawidget proc Document _motion { iXp iYp } { + $this config -cursor [our aCursors([_getEdge $iXp $iYp])] +} + +# name: _move1 +# args: iXp, iYp: mouse position (from the %X and %Y fields of an event) +# called on a event on the title bar. stores the current mouse +# pointer position. raises the document. +metawidget proc Document _move1 { iXp iYp } { + raise_ + + set wParent [winfo parent $this] + my iXr1 [winfo rootx $wParent] + my iYr1 [winfo rooty $wParent] + my iXr2 [expr [my iXr1]+[winfo width $wParent]] + my iYr2 [expr [my iYr1]+[winfo height $wParent]] + + my iXp0 $iXp + my iYp0 $iYp +} + +# name: _move2 +# args: iXp, iYp: mouse position (from the %X and %Y fields of an event) +# called on a event on the title bar. calculates the new +# window position and places it there. +metawidget proc Document _move2 { iXp iYp } { + if { $iXp < [my iXr1] } { set iXp [my iXr1] } + if { $iYp < [my iYr1] } { set iYp [my iYr1] } + if { $iXp > [my iXr2] } { set iXp [my iXr2] } + if { $iYp > [my iYr2] } { set iYp [my iYr2] } + + place $this -x [expr [my -x]-[my iXp0]+$iXp] -y [expr [my -y]-[my iYp0]+$iYp] +} + +# name: _move3 +# args: - +# called on a event on the title bar. stores the actual +# window position in some private variables. +metawidget proc Document _move3 {} { + my -x [winfo x $this] + my -y [winfo y $this] +} + +# name: _resize1 +# args: iXp, iYp: mouse position (from the %X and %Y fields of an event) +# called on a <1> event on one of the borders. stores the current mouse +# position. depending on the mouse position (at an edge or not), the +# resize mode is determined. +metawidget proc Document _resize1 { iXp iYp } { + raise_ + + my iWMin [lindex [my -minsize] 0] + my iHMin [lindex [my -minsize] 1] + + my iXMax [expr [my -x]+[my -width] -[my iWMin]] + my iYMax [expr [my -y]+[my -height]-[my iHMin]] + + my iXp0 $iXp + my iYp0 $iYp + + set sPos [_getEdge $iXp $iYp] + set sXPos {}; regexp {[we]} $sPos sXPos; my sXPos $sXPos + set sYPos {}; regexp {[ns]} $sPos sYPos; my sYPos $sYPos +} + +# name: _resize2 +# args: iXp, iYp: mouse position (from the %X and %Y fields of an event) +# called on a event on the borders. calculates the new +# Document sizes and position and places it depending on the resize mode. +metawidget proc Document _resize2 { iXp iYp } { + # sometimes the <1> event and _resize1 didn't precede this one... + if { ! [myinfo exists sXPos] } { + return + } + + if { [my sXPos] == "w" } { + set iX [expr [my -x]-[my iXp0]+$iXp] + if { $iX > [my iXMax] } { set iX [my iXMax] } + + set iW [expr [my -width]+[my iXp0]-$iXp] + if { $iW < [my iWMin] } { set iW [my iWMin] } + + place $this -x $iX -width $iW + } elseif { [my sXPos] == "e" } { + set iW [expr [my -width]-[my iXp0]+$iXp] + if { $iW < [my iWMin] } { set iW [my iWMin] } + + place $this -width $iW + } + + if { [my sYPos] == "n" } { + set iY [expr [my -y]-[my iYp0]+$iYp] + if { $iY > [my iYMax] } { set iY [my iYMax] } + + set iH [expr [my -height]+[my iYp0]-$iYp] + if { $iH < [my iHMin] } { set iH [my iHMin] } + + place $this -y $iY -height $iH + } elseif { [my sYPos] == "s" } { + set iH [expr [my -height]-[my iYp0]+$iYp] + if { $iH < [my iHMin] } { set iH [my iHMin] } + + place $this -height $iH + } +} + +# name: _resize3 +# args: - +# called on a event on the borders. stores the actual +# window size and position in some private variables. +metawidget proc Document _resize3 {} { + my -x [winfo x $this] + my -y [winfo y $this] + my -width [winfo width $this] + my -height [winfo height $this] +} + +# name: _withdraw +# args: - +# simply lets the Document disappear. +metawidget proc Document _withdraw {} { + place forget $this + my -state withdrawn +} + +# name: _maximize +# args: - +# maximizes the document. exchanges the icon for the maximize button. +# deletes bindings for resize and move. +metawidget proc Document _maximize {} { + # if it was minimized or withdrawn: set to default + # if we come from normal state, store the window position + if { [my -state] == "normal" } { + my iNormX [my -x] + my iNormY [my -y] + } else { + _restore + } + + # place it to fill entirely its master + place $this -x 0 -y 0 -width 0 -height 0 -relwidth 1 -relheight 1 + $this.head.maxb configure -image [our pIconRestore] + $this.menu entryconf Maximize -state disabled + $this configure -border 0 + + # delete bindings for resizing + bind $this <1> {} + bind $this {} + bind $this {} + + # modify/delete bindings for moving + bind $this.head.text <1> "$this raise" + bind $this.head.text {} + bind $this.head.text {} + + # delete binding for mouse cursor changes over borders + bind $this {} + + # change bindings for maximize button and title bar + bind $this.head.text "$this _restore" + bind $this.head.maxb <1> "$this _restore" + + my -state maximized +} + +# name: _minimize +# args: - +# minimizes the document. exchanges the icon for the minimize button. +# deletes bindings for resize. +metawidget proc Document _minimize {} { + # if it was maximized or withdrawn: set to default + # if we come from normal state, store the window position + if { [my -state] == "normal" } { + my iNormX [my -x] + my iNormY [my -y] + } else { + _restore + } + + # morph -x and -y to contain the icon position + if { [myinfo exists iIconX] } { + my -x [my iIconX] + my -y [my iIconY] + } else { + my -x [my iNormX] + my -y [my iNormY] + } + + # withdraw the document's working area + pack forget $this.work + $this.head.minb configure -image [our pIconRestore] + $this.menu entryconf Minimize -state disabled + + # eventually change title text + if { [my -icontext] != {} } { + $this.head.text configure -text [my -icontext] + } + + place $this -x [my -x] -y [my -y] -width 128 -height [expr [winfo reqheight $this.head] + 8] -relwidth 0 -relheight 0 + + # delete bindings for resizing + bind $this <1> {} + bind $this {} + bind $this {} + + # delete binding for mouse cursor changes over borders + bind $this {} + + # change bindings for minimize button and title bar + bind $this.head.text "$this _restore" + bind $this.head.minb <1> "$this _restore" + + my -state minimized +} + +# name: _restore +# args: - +# restores a Document from any of the other states. assigns the regular +# bindings to all widgets. +metawidget proc Document _restore {} { + # if we come from iconized state, store the icon position + if { [my -state] == "minimized" } { + my iIconX [my -x] + my iIconY [my -y] + } + + # morph -x and -y to contain the window position + my -x [my iNormX] + my -y [my iNormY] + + # show the working area and place Document on last known position + pack $this.work -fill both -expand 1 -padx 2 -pady 2 + place $this -x [my -x] -y [my -y] -width [my -width] -height [my -height] -relwidth 0 -relheight 0 + + # restore icons and menu entries for all title bar elements + $this.head.minb configure -image [our pIconMin] + $this.head.maxb configure -image [our pIconMax] + $this.head.text configure -text [my -title] + $this.menu entryconf Minimize -state normal + $this.menu entryconf Maximize -state normal + ::${this}::$this config -border 2 + + # restore resize bindings + bind $this <1> "$this _resize1 %X %Y" + bind $this "$this _resize2 %X %Y" + bind $this "$this _resize3" + + # restore move bindings + bind $this.head.text <1> "$this _move1 %X %Y" + bind $this.head.text "$this _move2 %X %Y" + bind $this.head.text "$this _move3" + + # restore maximize and minimize bindings + bind $this.head.maxb <1> "$this _maximize" + bind $this.head.minb <1> "$this _minimize" + bind $this.head.text "$this _maximize" + + # restore binding for mouse cursor changes over borders + bind $this "$this _motion %X %Y" + + my -state normal +} + +# name: -x et al. +# args: iX, iY, iWidth iHeight: geometry values +# sets a new size or position of the Document window. -x and -y apply +# regardless if the window is iconified or not, but -width and -height +# only affect the window in normal state. +metawidget proc Document -x { iX } { + my -x $iX + place $this -x [my -x] +} +metawidget proc Document -y { iY } { + my -y $iY + place $this -y [my -y] +} +metawidget proc Document -width { iWidth } { + my -width $iWidth + + if { [my -state] == "normal" } { + place $this -width [my -width] + } +} +metawidget proc Document -height { iHeight } { + my -height $iHeight + + if { [my -state] == "normal" } { + place $this -height [my -height] + } +} + +# name: -font +# args: sFont: font to set +# option handler. sets the title font. +metawidget proc Document -font { sFont } { + my -font $sFont + $this.head.text configure -font $sFont +} + +# name: -image +# args: sImage: image to set +# option handler. sets the image in the title bar. +metawidget proc Document -image { sImage } { + my -image $sImage + $this.head.icon configure -image $sImage +} + +# name: -title +# args: sTitle: title to set +# option handler. sets title text. +metawidget proc Document -title { sTitle } { + my -title $sTitle + $this.head.text configure -text $sTitle +} + +# name: -state +# args: sState: new Document state +# option handler. sets the state for the document. the variable -state +# is set in the respective (private) member functions. +metawidget proc Document -state { sState } { + switch -- [mkw.complete $sState {normal minimized maximized withdrawn}] { + normal { _restore } + minimized { _minimize } + maximized { _maximize } + withdrawn { _withdraw } + } +} + +# name: menu +# args: args: arguments for the regular menu command. +# simply passes all arguments to the popup menu. +metawidget proc Document menu_ { args } { + eval $this.menu $args +} + +# name: lower +# args: - +# draws the title bar in grey. +metawidget proc Document lower_ {} { + $this.head configure -bg [our aColors(gray50)] + $this.head.icon configure -bg [our aColors(gray50)] + $this.head.text configure -bg [our aColors(gray50)] -fg [our aColors(gray)] +} + +# name: raise +# args: - +# puts the Document on top and draws the title bar in different colors. +metawidget proc Document raise_ {} { + catch { [our wFocus] lower } + our wFocus $this + + $this.head configure -bg [my -background] + $this.head.icon configure -bg [my -background] + $this.head.text configure -bg [my -background] -fg [my -foreground] + + raise $this +} + +# name: pack +# args: sWindow: widget to be packed +# args: option-value pairs +# redirects packing to the work area widget. the binding is required +# to reset the mouse cursor when it enters the work area. this is +# only required if the packed widget is a logical child. +metawidget proc Document pack_ { sWindow args } { + eval pack $sWindow -in $this.work $args + + if { [winfo parent $sWindow] == $this } { + bind $sWindow "+$this config -cursor {}" + } +} + +# name: grid +# args: sWindow: widget to be gridded +# args: option-value pairs +# redirects gridding to the work area widget. +metawidget proc Document grid_ { sWindow args } { + eval grid $sWindow -in $this.work $args + + if { [winfo parent $sWindow] == $this } { + bind $sWindow "+$this config -cursor {}" + } +} + +# name: place +# args: sWindow: widget to be placed +# args: option-value pairs +# redirects placing to the work area widget. +metawidget proc Document place_ { sWindow args } { + eval place $sWindow -in $this.work $args + + if { [winfo parent $sWindow] == $this } { + bind $sWindow "+$this config -cursor {}" + } +} + +# name: Arrange +# args: sHow: arrange mode +# sParent: a valid parent widget of document windows(s). +# static member function. resizes and repositions all Document objects +# in one of several ways. it always arrange iconfied windows before +# it repositions the non-iconfied windows. +metawidget proc Document Arrange { sHow } { + variable lAllDocs + + set sHow [mkw.complete $sHow {horizontally vertically cascade tile icons maximize minimize}] + + # first check if at least one document window exists + if { ! [info exists lAllDocs] || ! [llength $lAllDocs] } return + + # get a list of all iconified windows and a list of all others + set lDocs {} + set lIcon {} + foreach sDoc $lAllDocs { + if { [$sDoc cget -state] == "minimized" } { + lappend lIcon $sDoc + } else { + lappend lDocs $sDoc + } + } + + # get parent window's dimensions for later calculation + set sParent [winfo parent [lindex $lAllDocs 0]] + set iW [winfo width $sParent] + set iH [winfo height $sParent] + + # if there are iconfied windows, arrange them first and reduce iH + set iXd 0 + foreach sDoc $lIcon { + set iWd [winfo width $sDoc] + if { [expr $iXd+$iWd] > $iW } { + set iXd 0 + } + if { $iXd == 0 } { + incr iH -[winfo height $sDoc] + } + $sDoc configure -x $iXd -y $iH + incr iXd $iWd + } + + # how many non-iconified windows? just exit when none + set iDocs [llength $lDocs] + if { $iDocs == 0 } return + + switch $sHow { + horizontally { + set iStep [expr $iH/$iDocs] + for { set i 0 } { $i < $iDocs } { incr i } { + set sDoc [lindex $lDocs $i] + $sDoc configure -x 0 -y [expr $i*$iStep] -width $iW -height $iStep + } + } + + vertically { + set iStep [expr $iW/$iDocs] + for { set i 0 } { $i < $iDocs } { incr i } { + set sDoc [lindex $lDocs $i] + $sDoc configure -x [expr $i*$iStep] -y 0 -width $iStep -height $iH + } + } + + cascade { + set iStep 24 + for { set i 0 } { $i < $iDocs } { incr i } { + set sDoc [lindex $lDocs $i] + $sDoc configure -x [expr $i*$iStep] -y [expr $i*$iStep] -width [expr $iW*2/3] -height [expr $iH*2/3] + $sDoc raise + } + } + + tile { + for { set i 0 } { $i <= 100 } { incr i } { + set iHor [expr ($i+3)/2] + set iVer [expr ($i+2)/2] + if { [expr $iHor*$iVer] >= $iDocs } break + } + + set iXStep [expr $iW/$iHor] + set iYStep [expr $iH/$iVer] + for { set i 0 } { $i < $iDocs } { incr i } { + set sDoc [lindex $lDocs $i] + $sDoc configure -x [expr ($i%$iHor)*$iXStep] -y [expr ($i/$iHor)*$iYStep] -width $iXStep -height $iYStep + } + } + + maximize { + foreach sDoc $lDocs { + $sDoc _maximize + } + } + + minimize { + foreach sDoc $lDocs { + $sDoc _minimize + } + } + } +} + +metawidget command Document _showMenu _showMenu +metawidget command Document _move1 _move1 +metawidget command Document _move2 _move2 +metawidget command Document _move3 _move3 +metawidget command Document _resize1 _resize1 +metawidget command Document _resize2 _resize2 +metawidget command Document _resize3 _resize3 +metawidget command Document _withdraw _withdraw +metawidget command Document _maximize _maximize +metawidget command Document _minimize _minimize +metawidget command Document _restore _restore +metawidget command Document _motion _motion + +metawidget command Document menu menu_ +metawidget command Document lower lower_ +metawidget command Document raise raise_ +metawidget command Document pack pack_ +metawidget command Document grid grid_ +metawidget command Document place place_ +metawidget command Document Arrange Arrange + +metawidget option Document -x -x +metawidget option Document -y -y +metawidget option Document -width -width +metawidget option Document -height -height +metawidget option Document -font -font +metawidget option Document -image -image +metawidget option Document -title -title +metawidget option Document -state -state +metawidget option Document -foreground +metawidget option Document -background +metawidget option Document -minsize +metawidget option Document -icontext + +proc test {} { + pack [frame .w -back darkgray] -fill both -expand 1 + document .w.d1 + document .w.d2 + document .w.d3 + + .w.d3 pack [label .w.d3.f -border 2 -relief sunken -text "1"] -fill both -expand 1 + pack [label .w.d3.f.f -border 2 -relief raised -text "2"] -fill both -expand 1 +} + +#test