set prefix [ file dirname [ file dirname [ info script ] ] ]
 source $prefix/utils/init.tcl
 option add *font -adobe-helvetica-bold-r-normal-*-14-*-*-*-*-*-*

 set winlist {}

 proc do-exit {} {
   if { [tk_dialog .confirm "Please Confirm" "Exit - are you sure?"  {} 1 Yes No ]
       == 0 } {
     exit
   }
 }

 proc refresh { } {
   global winlist
   if { $winlist == {} } return
   foreach win $winlist {
     focus $win
     raise $win
     update
     raise $win-shield
     update
   }
   place forget $win-shield
   raise $win
   raise $win-tab
 }

 proc windata { win } {
   upvar x x y y w w h h

   set w [ winfo width $win ]
   set h [ winfo height $win ]
   set x [ winfo x $win ]
   set y [ winfo y $win ]
   if { $x == 0 && $y == 0 } { set x [x]; set y [y] }
 }

 proc x {} {
   set x [ winfo pointerx . ]
   return [ expr $x - [ winfo x . ]]
 }

 proc y {} {
   set y [ winfo pointery . ]
   return [ expr $y - [ winfo y . ]]
 }

 proc ctrptr { win } {
   set x [ expr [winfo x $win-tab] + ([ winfo width $win-tab ] / 2 ) ]
   set y [ expr [winfo y $win-tab] + ([ winfo height $win-tab ] / 2 ) ]
   event generate . <Motion> -warp 1 -x $x -y $y
 }

 set tabheight 0
 proc winMove { win { stage "" } } {
   global tabheight
   upvar #0 $win-data windata

   if [ string equal $windata(state) "maxed"] return
   switch -exact $stage {
     start {
       place forget .help
       windata $win
       event generate . <Motion> -warp 1 -x $x -y $y
       set tabheight [ winfo height $win-tab ]
     } done {
       set x [x] ; set y [y]
       place $win -x $x -y $y
       place $win-tab -x $x -y $y -anchor sw
       ctrptr $win
       show-winops $win
       refresh
     } default {
       set x [x]
       set y [y]
       if { $x < 0 } { set x 0 }
       if { $y < $tabheight } { set y $tabheight }
       set ww [ expr { [ winfo width . ] - 25 } ]
       if { $x > $ww } { set x $ww}
       set wh [ winfo height . ]
       if { $y > $wh } { set y $wh}
       place $win -x $x -y $y
       place $win-tab -x $x -y $y -anchor sw
     }
   }
 }

 set rbx ""
 set rby ""
 frame .rubberband -bd 3 -relief ridge
 proc winResize { win { stage "" } } {
   global rbx rby
   upvar #0 $win-data windata

   if [ string equal $windata(state) "maxed"] return
   switch -exact $stage {
     start {
       set w [ winfo width $win ]
       set h [ winfo height $win ]
       set rbx [ winfo x $win ]
       set rby [ winfo y $win ]
       set r [ expr $rbx + $w ]
       set b [ expr $rby + $h ]
       event generate . <Motion> -warp 1 -x $r -y $b
       .rubberband configure -width $w -height $h
       place .rubberband -x $rbx -y $rby
       raise .rubberband
     } done {
       place forget .rubberband
       set basex [ winfo x . ]
       set basey [ winfo y . ]
       set w [ expr [ winfo pointerx $win ] - $basex - $rbx ]
       set h [ expr [ winfo pointery $win ] - $basey - $rby ]
       place $win -width $w -height $h
       ctrptr $win
       refresh
     } default {
       set basex [ winfo x . ]
       set basey [ winfo y . ]
       set w [ expr [ winfo pointerx $win ] - $basex - $rbx ]
       set h [ expr [ winfo pointery $win ] - $basey - $rby ]
       .rubberband configure -width $w -height $h
     }
   }
 }

 proc iconize { w } {
   puts "iconize"
 }

 proc winShrinkGrow { win } {
   upvar #0 $win-data windata
   if [ string equal "normal" $win-data(state) ] {
     set x 0
     set y 0
     set w [ winfo width . ]
     set h [ winfo height . ]
     place $win -x $x -y $y -width $w -height $h
     set windata(state) maxed
   } else {
     windata $win
     place $win -x $x -y $y -width $w -height $h
     set windata(state) normal
   }
 }

 proc winClose { win } {
   global prevwin winlist
   upvar $win-data windata
   if [ string equal $prevwin $win ] {
     set prevwin ""
   }
   set which [ lsearch $winlist $win ]
   set winlist [ lreplace $winlist $which $which ]
   destroy $win
   destroy $win-tab
   destroy $win-ops
   destroy $win-shield
   unset windata
   place forget .help
 }

 proc winLower { win } {
   global winlist

   set which [ lsearch $winlist $win ]
   set winlist [ lreplace $winlist $which $which ]
   set winlist [ linsert $winlist 0 $win ]
   winSelect [ lindex $winlist end ]
 }

 label .help -bd 1 -fg black -bg lightyellow -font fixed -text "default help"

 set btn3 0
 proc popballoon {} {
   global btn3
   if { !$btn3 } { place forget .help }
 }

 proc help {w help} {
   bind $w <Any-Enter> "after 1000 balloon %W $help; after 3000 popballoon"
   bind $w <Any-Leave> "popballoon"
   bind $w <ButtonPress-3> "set btn3 1; balloon %W $help"
   bind $w <ButtonRelease-3> "set btn3 0; popballoon"
 }

 proc balloon { w args } {
   .help configure -text $args
   regexp {^\.[A-Za-z0-9]*} $w parent
   if { [ catch { set x [ expr [ winfo x $w ] + [ winfo x $parent ] + 10 ] } ] == 0 } {
     set y [ expr [ winfo y $w ] + [ winfo y $parent ] - 10 ]
     place .help -x $x -y $y
     raise .help
   }
 }

 proc show-winops { win } {
   upvar #0 $win-data windata
   if [string equal $windata(btnstate) "showing" ] {
     windata $win
     set y [expr $y-[winfo height $win-tab]]
     place $win-ops -x $x -y $y -anchor ne
     raise $win-ops
   }
 }

 proc showhideBtns { win } {
   upvar #0 $win-data windata
   if [string equal $windata(btnstate) "hidden" ] {
     set windata(btnstate) showing
     show-winops $win
     $win-tab.winops configure -text ">"
   } else {
     # hide the buttons
     place forget $win-ops
     set windata(btnstate) hidden
     $win-tab.winops configure -text "<"
   }
 }

 proc btn { name text cmd helptext } {
   set btn [button $name -text $text -padx 1 -pady 0 -bd 1 \
             -command $cmd -cursor top_left_arrow ]
   help $btn $helptext
   return $btn
 }

 proc doWM { shellwin cmd win args } {
   upvar #0 $win-data windata
   switch -exact $cmd {
     geometry { windata $shellwin ; return ${w}x${h}+${x}+${y} }
     deiconify { }
     protocol {
       set wmop [ lindex $args 0 ]
       switch -exact $wmop {
         WM_DELETE_WINDOW { $shellwin-ops.done config -command "place forget $shellwin" }
         withdraw { place forget $shellwin }
         maxsize { }
       }
     }
     title {
       eval $shellwin-tab.title configure -text $args
       update
     }
   }
 }

 proc initialize { win title } {
   upvar #0 $win-data windata
   windata $win
   update

   set windata(state) normal
   set windata(btnstate) hidden
   set windata(TLcount) 0
   set windata(dlgwins) {}
   frame $win-tab -relief raised -cursor fleur
   pack [ btn $win-tab.winops "<" "showhideBtns $win" "Window Ops" ] -side left
   pack [label $win-tab.title -text $title ] -side left
   help $win-tab "Click/Drag to Move"
   help $win-tab.title "Click/Drag to Move"

   frame $win-ops -bd 1 -relief raised -cursor top_left_arrow
   pack [btn $win-ops.lower \u2193 "winLower $win" "Lower Window"]
   # pack [btn $win-ops.iconize . "iconize $win" "Window->Icon"]
   # pack [btn $win-ops.grow \u2195 "winShrinkGrow $win" "Grow/Shrink Window"]
   pack [btn $win-ops.resize \u2518 "" "Click/Drag to Resize"]
   pack [btn $win-ops.done x "winClose $win" "Close & Exit"]
   bind $win-ops.resize <ButtonPress-1> "winResize $win start"
   bind $win-ops.resize <ButtonRelease-1> "winResize $win done"
   bind $win-ops.resize <B1-Motion> "winResize $win"

   bind $win-tab.title <ButtonPress-1> "winMove $win start"
   bind $win-tab.title <B1-Motion> "winMove $win"
   bind $win-tab.title <ButtonRelease-1> "winMove $win done"
   bind $win <ButtonPress-1> "winSelect $win"
 }

 proc doTL { win slavewin args } {
   upvar #0 $win-data windata

   set newtl $windata(TLcount)
   incr windata(TLcount)
   # create frame as container for win
   frame $win-TL$newtl -container 1
   set winid [ winfo id $win-TL$newtl ]
   $windata(interp) eval [ subst {
     _toplevel $slavewin -use $winid
   } ]
   place configure $win-TL$newtl -x [x] -y [y]
   initialize $win-TL$newtl $win
   lappend windata(dlgwins) $win-TL$newtl
   return $win-TL$newtl
 }

 proc doWI { win args } {
   upvar #0 $win-data windata
   set cmd [ lindex $args 0 ]
   set args [ lreplace $args 0 0 ]
puts "doWI: $cmd, $args"
   switch $cmd {
     screenheight { return [ winfo height . ] }
     screenwidth  { return [ winfo width . ] }
     toplevel     { return [ $windata(interp) eval [list _winfo toplevel  $args ] ] }
     reqwidth     { return [ $windata(interp) eval [list _winfo reqwidth  $args ] ] }
     reqheight    { return [ $windata(interp) eval [list _winfo reqheight $args ] ] }
     pixels       { return [ $windata(interp) eval [list _winfo pixels    $args ] ] }
     default      { puts "winfo $cmd not implemented, args=($args)" }
   }
 }

 set wincount 0
 proc winNew {args} {
   global prefix wincount winlist

   init -using $args x "" y "" title "" width "" height "" app ""
   set win .win$wincount
   incr wincount

   upvar #0 $win-data windata

   frame $win -relief raised -container yes -height $height -width $width
   initialize $win $title

   set interp [ interp create ]
   set windata(interp) $interp
   $interp alias exit winClose $win
   # set pkglist [ glob $prefix/lib/*/pkgIndex.tcl ]
   set initscript "
      package require Tk
      set argv \"-use [winfo id $win]\"
      rename toplevel _toplevel
      rename wm _wm
      wm protocol . WM_DELETE_WINDOW exit
   "
   $interp eval $initscript
   frame $win-shield -bg {}
   bind $win-shield <ButtonPress-1> "winSelect $win"
   $interp alias to2plevel doTL $win
   $interp alias wm doWM $win
   # $interp alias winfo doWI $win
   uplevel "$interp eval source $prefix/apps/$app"
   lappend winlist $win
   place $win -x $x -y $y
   update

   # set up pool here
   return $win
 }

 proc start { app } {
   set win [ winNew -x [x] -y [y] -title $app -width 200 -height 50 -app $app ]
   winSelect $win
   return $win
 }

 proc deselect { win } {
   if [ string equal $win "" ] return
   windata $win
   place $win-shield -x $x -y $y
   raise $win-shield
   $win-shield configure -width $w
   $win-shield configure -height $h
   place forget $win-tab
   place forget $win-ops
   upvar #0 $win-data windata
   foreach dlg $windata(dlgwins) {
     place forget $dlg
     place forget $dlg-tab
     place forget $dlg-ops
   }
 }

 set prevwin ""
 proc winSelect { win } {
   global prevwin winlist

   deselect $prevwin
   place forget $win-shield
   focus $win
   raise $win
   set which [ lsearch $winlist $win ]
   set winlist [ lreplace $winlist $which $which ]
   lappend winlist $win
   set prevwin $win

   upvar #0 $win-data windata
   windata $win
   # place $win -x $x -y $y
   place $win-tab -x $x -y $y -anchor sw
   show-winops $win
   foreach dlg $windata(dlgwins) {
     windata $dlg
     place $dlg -x $x -y $y
     place $dlg-tab -x $x -y $y -anchor sw
     show-winops $dlg
   }
 }

 pack propagate . 0
 wm focusmodel . active
 set width 1000
 set height 600
 . config -width $width -height $height -bg blue
 focus -force .
 init -using $argv fullscreen 0
 if $fullscreen {
   set width [ winfo screenwidth . ]
   set height [ winfo screenheight . ]
   . config -width $width -height $height -bg blue
   wm overrideredirect . 1
   grab -global .
 }
 menu .apps
 .apps add command -label "Refresh Desktop" -command refresh
 .apps add separator
 foreach app [lsort -dictionary [glob $prefix/apps/*]] {
   set app [ file tail $app ]
   if { [ string last "." $app ] == -1 } {
     .apps add command -label $app -command [ list start $app ]
   }
 }
 .apps add separator
 .apps add command -label Exit -command [ list do-exit ]
 bind . <ButtonPress-3> [ list tk_popup .apps %X %Y ]

 if $fullscreen { after 10000 exit }

----
[Category Application] |
[Category GUI] | [Category Desktop]