interfaces/xmaxima/Tkmaxima/Wmenu.tcl

   1 ###### wmenu.tcl ###########################################
   2 #
   3 # Copyright (C) 1998 William F. Schelter
   4 # For distribution under GNU public License.  See COPYING.tcl
   5 #
   6 #     Time-stamp: "2024-03-20 15:14:53 villate"
   7 #
   8 ############################################################
   9
  10 # implement a menu bar without toplevel windows.
  11 # wet
  12
  13 proc wmenubar { name  } {
  14     if { "[string index $name 0]" == "." } {
  15         frame $name
  16         # puts "rename $name $name-orig"
  17         rename $name $name-orig
  18         set top [winfo toplevel $name]
  19         oset $top helpwin ""
  20         proc $name { option args } "wmenubarInternal $name \$option \$args"
  21         set parent [winfo parent $name]
  22         # maybe change this to do traversal toward side leaving on..
  23         oset $name items ""
  24     } else {
  25         error [mc "needs a window name arg"]
  26     }
  27 }
  28
  29
  30 proc eswitch { key lis } {
  31     foreach {k act} $lis { lappend allowd $k}
  32     lappend lis default [concat [mc "error"] "$key" [mc "must be one of:"] "$allowd"]
  33     uplevel 1 switch -- $key  [list  $lis]
  34 }
  35
  36 proc ogetr { win var dflt } {
  37     set w $win
  38     while { 1 } {
  39         if { 0 == [catch { set val [oget $w $var] }] } {
  40             return $val
  41         }
  42         global [oarray $w]
  43         # puts w=$w,[array get [oarray $w]]
  44         set w [winfo parent $w]
  45         if { "$w" == "" } {return $dflt}
  46     }
  47 }
  48
  49 proc deleteHelp { win } {
  50     #mike FIXME: This is being called even if show_balloons = 0
  51     linkLocal $win helpPending
  52     if { [info exists  helpPending] } {
  53         after cancel $helpPending
  54         unset helpPending
  55     }
  56     set top [winfo toplevel $win]
  57     set helpwin [oget $top helpwin]
  58     if {$helpwin != "" && [winfo exists $helpwin]} {
  59         place forget $helpwin
  60     }
  61 }
  62
  63 proc setHelp {win  help args } {
  64     # set c [ogetr $win c "cant"]
  65     if { "$help" == "" } {set help [concat [mc "This is a menu window"] "$win"]}
  66     set enter ""
  67     set exit ""
  68     if  { [catch { set current [$win cget -relief] } ] || "$current" \
  69             != "flat" } {
  70         set enter ""
  71         set exit ""
  72     } else {
  73         set enter "$win configure -relief raised" ;
  74         set exit "$win configure -relief $current"
  75     }
  76     # puts "current=$current"
  77
  78     bind $win <Enter> "$enter; showHelp $win  {$help} $args"
  79     bind $win <Leave> "$exit; deleteHelp $win"
  80 }
  81
  82
  83 #
  84 #-----------------------------------------------------------------
  85 #
  86 # showHelp --  for WINDOW show a HELP message using ANCHOR positions.
  87 #  WINDOW may be a window or a rectangle specifier: x,y,wid,height
  88 #  ANCHOR positions may be either n,w,e,s,nw,ne,se,sw,center or
  89 #  one of these followed by two floating point numbers indicating
  90 #  the fraction of the width and height of the window one is away from
  91 #  the upper left x,y of the window.
  92 #  Results: none
  93 #
  94 #  Side Effects: display a window.
  95 #
  96 #----------------------------------------------------------------
  97 #
  98 proc showHelp { win help args } {
  99     global show_balloons helpwin
 100     if { $show_balloons == 0 } {
 101         #mike FIXME: $win is a list not a window
 102         set top [winfo toplevel [lindex $win 0]]
 103         set helpwin [oget $top helpwin]
 104         if {$helpwin != "" && [winfo exists $helpwin]} {
 105             place forget $helpwin
 106         }
 107         return
 108     }
 109     linkLocal [lindex $win 0] helpPending
 110     #mike FIXME: $win is a list not a window - needs an eval
 111     set helpPending [after 1000 [list showHelp1 $win $help $args]]
 112 }
 113
 114 proc showHelp1 { win help args } {
 115     global  tk_version
 116     set top [winfo toplevel [lindex $win 0]]
 117     #    set anchors $args
 118     #    append anchors "  w  e s ne n sw nw"
 119     #    set anchors " nw"
 120     #    set anchors "w e n {nw .2 1.2} {ne .8 1.2} s se"
 121     #     set anchors "w e n {nw .2 1.2} {ne .8 1.2} s se"
 122     set anchors "sw w e n {nw .2 1.2} {ne .8 1.2} s se"
 123     makeLocal $top helpwin
 124     if { "$helpwin" == "" } {
 125         set tt $top
 126         if { "$tt" == "." } {set tt ""}
 127         set helpwin $tt.balloonhelpwin
 128         if { ![winfo exists $helpwin] } {
 129
 130             label $helpwin -width 0 -height 0  -borderwidth 1 \
 131                     -background beige -padx 4 -pady 4 -justify left
 132         }
 133         $helpwin config -relief solid
 134
 135         oset $top helpwin $helpwin
 136     }
 137     if { [string first _eval $help ] == 0 } {
 138         catch { set help [eval [concat list [lindex $help 1]]]}
 139     }
 140
 141     $helpwin configure -text $help \
 142         -wraplength [expr {round(.34 * [winfo width $top])}]
 143     global anchorPositions
 144     if { [llength $win] == 5 } {
 145         desetq "win wx wy wxdim wydim" $win
 146     }  else {
 147         set wx [expr {[winfo rootx $win ] - [winfo rootx $top]}]
 148         set wy [expr {[winfo rooty $win ] - [winfo rooty $top]}]
 149         set wxdim [winfo width $win]
 150         set wydim [winfo height $win]
 151     }
 152     set nxdim [winfo reqwidth $helpwin]
 153     set nydim [winfo reqheight $helpwin]
 154     set topxdim  [winfo width $top]
 155     set topydim  [winfo height $top]
 156     global anchorPositions
 157     foreach an $anchors {
 158         if {[llength $an] == 3} {
 159             desetq "an rx ry" $an
 160         } else {
 161             desetq "rx ry" [lsublis { {0 1.1 } {1 -.1}} $anchorPositions($an)]
 162         }
 163         # puts "rx=$rx,ry=$ry"
 164         set yoff [expr { $ry > 1 ? 8 : $ry < 0 ? -8 : 0 } ]
 165         desetq "x y" [getPlaceCoords 0 $yoff $rx $ry $an $wx $wy $wxdim $wydim $nxdim $nydim]
 166         # puts "for $win $an rx=$rx,ry=$ry x=$x,y=$y :[expr {$x >5}],[expr {$y > 5}],[expr {$x+$nxdim < $topxdim}],[expr {$y +$nydim < $topydim}]"
 167         if { $x > 5 && $y > 5 && $x+$nxdim < $topxdim && \
 168                 $y +$nydim < $topydim } {
 169             place forget $helpwin
 170
 171             place $helpwin -x $x -y $y -anchor nw
 172             after idle raise $helpwin
 173             return
 174         }
 175     }
 176 }
 177
 178 proc wmenubarInternal { win  option  lis } {
 179     # puts "{wmenubarInternal $win $option $lis}"
 180     set key [lindex $lis 0]
 181     set lis [lrange $lis 1 end]
 182     eswitch $option {
 183         add {
 184             set parent [winfo parent $win]
 185             if { "$parent" == "."} {set parent ""}
 186             set men [assoc -menu $lis $parent.item[llength [oget $win items]]]
 187             bindAltForUnderline $key "wmenuPost $key"
 188             frame $men -relief raised -borderwidth 2p
 189             setHelp $key [assoc -help $lis] n nw ne
 190             rename $men $men-orig
 191             set body "wmenuInternal $key \$option \$args"
 192             proc $men {option args } $body
 193             pack $key -in $win -side left -expand 0 -fill both
 194             global [oarray $win]
 195             lappend [oloc $win items] $key
 196             oset $key menu $men
 197             oset $men items ""
 198             oset $key parent $win
 199             bind $key <Button-1>  {wmenuPost %W}
 200             return $men
 201         }
 202         configure {
 203             return [eval $win-orig configure $key $lis]
 204
 205         }
 206         invoke {
 207             set w [lindex [oget $win items] $key]
 208             wmenuPost $w
 209         }
 210         cget {
 211             return [eval $win cget $key $lis]
 212         }
 213     }
 214 }
 215
 216 proc getSomeOpts { opts lis } {
 217     set answer ""
 218     foreach {ke val } $lis {
 219         if { [lsearch $opts $ke] >= 0  } {
 220             lappend answer $ke $val
 221         }
 222     }
 223     return $answer
 224 }
 225
 226 proc excludeSomeOpts { opts lis } {
 227     set answer ""
 228     foreach {ke val } $lis {
 229         if { [lsearch $opts $ke] < 0  } {
 230             lappend answer $ke $val
 231         }
 232     }
 233     return $answer
 234 }
 235
 236 proc lsublis { subs lis } {
 237     foreach v $subs {
 238         set key [lindex $v 0]
 239         while { [set i [lsearch $lis $key]] >= 0 } {
 240             if { [llength $v] > 1 } {
 241                 set lis [lreplace $lis $i $i [lindex $v 1]]
 242             } else {
 243                 set lis [lreplace $lis $i $i]
 244             }
 245         }
 246     }
 247     return $lis
 248 }
 249
 250 proc wmenuInternal {win option  olist } {
 251     set key [lindex $olist 0]
 252     set lis [lrange $olist 1 end]
 253     makeLocal $win menu parent
 254     makeLocal $menu items
 255     eswitch $option {
 256         add {
 257             if { [catch {set counter [oget $menu counter] }] }   {
 258                 set counter 0
 259             }
 260             oset $menu counter [incr counter]
 261             # set new to be the new menu item window
 262             # set com to be the command for 'invoke' to invoke.
 263             set opts [excludeSomeOpts "-textvariable -image -label -underline -help" $lis]
 264             set labopts [lsublis {{-label -text}} \
 265                     [getSomeOpts "-image -label -textvariable -underline" $lis]]
 266             append labopts " -justify left -anchor w -padx 2"
 267             eswitch $key {
 268                 radio {
 269                     set new $menu.fr$counter
 270                     frame $new -borderwidth 1
 271                     # puts "new=$new"
 272                     label $new.label {*}$labopts
 273                     pack $new.label -side left -fill x
 274                     set opts [lsublis {{-radiovariable -textvariable}} $opts]
 275                     radiobutton $new.radio {*}$opts
 276                     pack $new.radio -side right -anchor e
 277                     set com "$new.radio invoke"
 278                 }
 279                 check {
 280                     set new $menu.fr$counter
 281                     frame $new -borderwidth 1
 282                     # puts "new=$new"
 283                     label $new.label {*}$labopts
 284                     pack $new.label -side left
 285                     set opts [lsublis {{-checkvariable -textvariable}} $opts]
 286                     checkbutton $new.check {*}$opts
 287                     pack $new.check -side right
 288                     # puts "$var --> $val"
 289                     set com "$new.check invoke"
 290                 }
 291                 command {
 292                     set com [assoc -command $lis]
 293                     set new $menu.fr$counter
 294                     frame $new -borderwidth 1
 295                     label $new.label {*}$labopts
 296                     pack $new.label -in $new -side left
 297                     # puts "bind $new.label <Button-1> $com"
 298                     bind $new.label <Button-1> $com
 299                     bind $new <Button-1> $com
 300                 }
 301                 window {
 302                     set new [assoc -window $lis]
 303                     set com [assoc -command $lis list]
 304                 }
 305                 entry {
 306                     set new $menu.fr$counter
 307                     frame $new -borderwidth 1
 308                     label $new.label {*}$labopts
 309                     set opts [lsublis {{-entryvariable -textvariable}} $opts]
 310                     entry $new.entry {*}$opts
 311                     pack $new.label -side top -in $new -anchor w
 312                     pack $new.entry  -side top -in $new
 313                     set com "focus $new.entry"
 314                 }
 315                 separator {
 316                     set new $menu.sep$counter
 317                     frame $new -height 4
 318                     propagate $new 0
 319                     set com ""
 320                 }
 321
 322             }
 323             bindAltForUnderline $new.label "$menu invoke $new"
 324             pack $new -in $menu -side top -fill both -expand 0
 325             oset $menu items [lappend items $new]
 326             oset $menu command$new $com
 327             setHelp $new [assoc -help $lis] w e
 328             return $new
 329         }
 330         configure {
 331             return [eval $win configure $key $lis]
 332         }
 333         invoke {
 334             makeLocal $menu items
 335             if { ![winfo exists $key] }  {
 336                 # it is an index
 337                 set key [lindex $items $key]
 338             }
 339             eval [oget $menu command$key]
 340             return
 341         }
 342         post {
 343
 344             place $menu -anchor nw -relx 0 -rely 0 -bordermode outside -in $win
 345             bind $menu <Leave> "place forget $menu"
 346             focus $menu
 347             #bind $menu <FocusIn> "puts focus in"
 348             #bind $menu <FocusOut> "puts {leave for focus  menu}"
 349             raise $menu
 350         }
 351     }
 352 }
 353
 354 proc wmenuPost { win } {
 355     makeLocal $win parent menu
 356     bind $menu <Leave> "place forget $menu"
 357     place $menu -anchor nw -relx 0 -rely 1.0 -bordermode outside -in $win
 358     raise $menu
 359 }
 360
 361 proc bindAltForUnderline { item command } {
 362     set ind -1
 363     catch { set ind [$item cget -underline] }
 364     if { $ind >= 0 } {
 365         set letter [string index [$item cget -text] $ind]
 366         set to [winfo toplevel $item]
 367         bind $to <Alt-Key-$letter> $command
 368     }
 369 }
 370
 371 proc showSomeEvents { win } {
 372     foreach v { Enter FocusIn FocusOut Visibility Leave} {
 373         bind $win <$v> "puts {$win $v %x %y}"
 374     }
 375 }
 376
 377 global anchorPositions
 378 array set anchorPositions {
 379     n {.5 0} nw { 0 0 } se {1 1} e {1 .5} center {.5 .5}
 380     s { .5 1} sw { 0 1} w { 0 .5} ne { 0 1}
 381 }
 382
 383 proc getPlaceCoords { x y relx rely anchor xIn yIn xdimIn ydimIn xdim ydim } {
 384     global anchorPositions
 385
 386     # puts "xIn=$xIn,yIn=$yIn,xdimIn=$xdimIn,ydimIn=$ydimIn,xdim=$xdim,ydim=$ydim"
 387     set x1 [expr {$x + $xIn+$relx * $xdimIn}]
 388     set y1 [expr {$y + $yIn+$rely * $ydimIn}]
 389     desetq "fx1 fy1" $anchorPositions($anchor)
 390     set atx [expr {$x1 - $fx1*$xdim}]
 391     set aty [expr {$y1 - $fy1*$ydim}]
 392
 393     return [list $atx $aty]
 394 }
 395
 396 ## endsource wmenu.tcl