home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / table_subs.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  7.6 KB  |  268 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # utility routines for extracting table structures
  8.  
  9. ###  This has been replaced by the "blt_table location" extension
  10. # procedure to generate a binary search
  11. #   name: The name of the procedure to generate
  12. #   list: A list of numbers that indicate the size of each bucket
  13. #         (must have at least 1 element)
  14. #   start: The index of the first bucket
  15. #   level: Used internally for indenting the code
  16. #   result: A string to be "eval'd" to generate the procedure
  17.  
  18. proc gen_bsearch {name list {start 0} {level 0}} {
  19.  
  20.     if {!$level} {
  21.         append result "# procedure automatically generated by gen_bsearch\n"
  22.         append result "# Calling sequence: $name <integer>\n"
  23.         append result "# returns bucket number given by:\n"
  24.         append result "#  $list\n\n"
  25.         append result "proc $name  x \{\n"
  26.     }    
  27.  
  28.     set len [llength $list]
  29.     set pivot [expr [llength $list] / 2]
  30.     set indent [format "%*s" [expr ($level + 1) * 2] ""]
  31.  
  32.     append result $indent "if \{\$x < [lindex $list $pivot] \} \{\n"
  33.  
  34.     if {$pivot == 0} {
  35.         # append result "puts stderr \"$name \$x -> $start\"\n"
  36.         append result "$indent  return $start\n"
  37.     } else {
  38.         append result [gen_bsearch $name \
  39.                 [lrange $list 0 [expr $pivot - 1]] \
  40.                 $start \
  41.                 [expr $level + 1]]
  42.     }
  43.     append result "$indent\} else \{\n"
  44.     incr pivot
  45.     if {$len == $pivot } {
  46.         # append result "puts stderr \"$name \$x -> [expr $start + $pivot]\"\n"
  47.         append result "$indent  return [expr $start + $pivot]\n"
  48.     } else {
  49.         append result [gen_bsearch $name \
  50.                 [lrange $list $pivot end] \
  51.                 [expr $start  + $pivot] \
  52.                 [expr $level + 1]]
  53.     }
  54.     append result "$indent\}\n"
  55.  
  56.     if {!$level} {
  57.         append result \}\n
  58.     }    
  59.     return $result
  60. }
  61.  
  62. # insert a row or column into the table
  63. #  Table: The parent table to do the inserting in
  64. #  What is "row" or "column"
  65. #  index must be even!
  66. #  count must be even
  67.  
  68. proc table_insert {table what index {count 2}} {
  69.     global P _Message
  70.     dputs $table $what $index
  71.     undo_log create_grid $table $what $index
  72.     foreach item [blt_table slaves $table -exclude *@*] {
  73.         blt_get $item info
  74.         set start $info(-$what)
  75.         set end [expr $start + $info(-${what}span) -1]
  76.         if {$end < $index} {
  77.             continue            ;# before insertion - skip
  78.         } 
  79.         if {$start >= $index} {                ;# move entire widget
  80.             incr info(-$what) $count
  81.         } else {                            ;# shift span
  82.             incr info(-${what}span) $count
  83.         }
  84.         eval [blt_set $table $item info]
  85.     }
  86.     resize_insert $table $what $index
  87.     return 1
  88. }    
  89.  
  90. # delete a row or column - only delete empty rows or columns
  91. #  table: parent of the table to operate on
  92. #  what:  "row" or "col"
  93. #  index: table index - MUST be even
  94. #  count: How many to delete - MUST be even
  95. #  return value: TRUE if successful, false if widget would be deleted
  96.  
  97. proc table_delete {table what index {count 2}} {
  98.     global _Message
  99.  
  100.     # check for widget that would be deleted, gather info for the rest
  101.  
  102.     dputs $table $what $index
  103.     foreach item [blt_table slaves $table -exclude *@*] {
  104.         blt_get $item info
  105.         set start $info(-$what)
  106.         set end [expr $start + $info(-${what}span) -1]
  107.         if {$start == $index && $end == $index} {        ;# has widget!
  108.             dputs "No place for $item, aborting"
  109.             return 0
  110.         } 
  111.         if {$end < $index} {
  112.             continue
  113.         }
  114.         if {$start > $index} {        ;# move entire widget
  115.             incr info(-$what) -$count
  116.         } else {                    ;# shift span
  117.             incr info(-${what}span) -$count
  118.         }
  119.         set eval($item) [blt_set $table $item info]
  120.     }
  121.  
  122.     # OK, now shift everything
  123.  
  124.     foreach item [array names eval] {
  125.         eval $eval($item)
  126.     }
  127.     update_table $table "deleting $what $index"
  128.     resize_delete $table $what $index
  129.     return 1
  130. }    
  131.  
  132. # manage structures for efficient item highlighting
  133. #   handle = hightlight_setup <table> [<overlap>]
  134. #   highlight_adjust <handle> <add|del> <widget> (later)
  135. #   highlight_delete <handle>
  136. #   highlight <handle> <row> <col> <how> [<frame>]
  137.  
  138. # table_setup
  139. #  table:        name of table to do highlighting for
  140. #  overlap:        number of pixels to overlap grid
  141. # result:
  142. #  The name of an array is returned containing:
  143. #    array(<window>) x y width height
  144. #       For each window in the table, return coords relative to parent
  145. #       in a form suitable for use with the placer
  146. #    array(owner:<row>,<col>) <window>
  147. #       for every slot occupied by a window, return the window name
  148. #    array(all:<row>,<col>)  x y wide high
  149. #       for every slot occupied by a window, return coords spanning
  150. #       all slots it occupies, in a form suitable for use with placer
  151. #    array(slot:<row>,<col>  x y wide high
  152. #       for every slot, return coords suitable for use with placer
  153.  
  154. proc table_setup {table {overlap 0}} {
  155.     set handle geom:$table        ;# Everyone depends upon this naming convention
  156.     global $handle
  157.     upvar #0 $handle data
  158.  
  159.     # temporary
  160.  
  161.     set old_rows 0; set old_columns 0
  162.     catch {set old_rows $data(rows)}
  163.     catch {set old_columns $data(columns)}
  164.  
  165.     # reset array, except indeces marked "saved..."
  166.  
  167.     # set save [array get data save*]
  168.     catch {unset data}
  169.     # array set data $save
  170.  
  171.     set data(HighLightHandle) 1                    ;# for error checking
  172.     set data(table) $table                        ;# identify it
  173.  
  174.     # extract the table row and column info
  175.  
  176.     blt_table arrange $table
  177.     array set cnvt {row y column x}
  178.     foreach dim {row column} {
  179.         set stuff [blt_table $dim $table sizes all]
  180.  
  181.         # The table doesn't always start at the edge of the frame!
  182.         # calculate the offset based on the first grid lines.
  183.         # sum contains the offsets of each column from the edge of the master
  184.  
  185.         set sum [expr [winfo $cnvt($dim) $table.$dim@1] - [$table cget -bd]]
  186.         set cnt 0
  187.         set data(${dim}s) [llength $stuff]
  188.         if {$data(${dim}s) == 0} {error "Empty table $table in table_setup"}
  189.         foreach i $stuff {
  190.  
  191.             # this is optional experimental grid gravity
  192.             # if {!$cnt&1} {incr i -3} {incr i 3}
  193.  
  194.             lappend  ${dim}_coords $sum
  195.             set data(${dim}_$cnt) $sum
  196.             incr sum $i; incr cnt
  197.         }
  198.         lappend  ${dim}_coords $sum
  199.         set data(${dim}_coords) [set ${dim}_coords]
  200.         set data(${dim}_$cnt) $sum
  201.         dputs $table ${dim}s: $data(${dim}_coords)
  202.     }
  203.  
  204.     # extract info for each widget in the table
  205.  
  206.     set match {([0-9]+),([0-9]+)}                ;# match row,col info
  207.     foreach slave [blt_table slaves $table] {
  208.         set info [blt_table info $slave]
  209.         regexp $match $info coords row col        ;# extract coords
  210.         if {(($row | $col) & 1) == 1} {
  211.              continue        ;# skip grid points (row or column is odd)
  212.         }
  213.         set col_span [lindex $info 13]
  214.         set row_span [lindex $info 11]
  215.  
  216.         # create coords for all slots containing the widget
  217.         # This should be addae to blt_table
  218.  
  219.         set x1 $data(column_$col)
  220.         set y1 $data(row_$row)
  221.         set last_row [expr $row + $row_span]
  222.         set last_col [expr $col + $col_span]
  223.         set x2 $data(column_$last_col)
  224.         set y2 $data(row_$last_row)
  225.  
  226.         set data($slave)  " \
  227.             -x [expr $x1 + $overlap] \
  228.             -y [expr $y1 + $overlap] \
  229.             -width [expr $x2 - $x1 - 2 * $overlap] \
  230.             -height [expr $y2 - $y1 - 2 * $overlap] \
  231.             "
  232.  
  233.         # create row,col to widget name mapping for all slots
  234.         # containing the widget (gone)
  235.     }
  236.  
  237.     # experiment to avoid tbl bug
  238.  
  239.     while {$old_columns >= $data(columns)} {
  240.         blt_table column $table configure $old_columns -width 0 -resize none
  241.         # puts "zapping old column $old_columns"
  242.         incr old_columns -1
  243.     }
  244.     while {$old_rows >= $data(rows)} {
  245.         blt_table row $table configure $old_rows -height 0 -resize none
  246.         # puts "zapping old row $old_rows"
  247.         incr old_rows -1
  248.     }
  249.     return $handle
  250. }
  251.  
  252. #   delete a handle
  253.  
  254. proc highlight_delete {handle} {
  255.     upvar $handle data
  256.     if {![info exists data(HighLightHandle)]} {
  257.         error "$handle is not a highlight handle"
  258.     }
  259.     # rename $data(row_proc) ""
  260.     # rename $data(com_proc) ""
  261.     uplevel "unset $handle"
  262. }
  263.  
  264. # extract the row and column minimum size information
  265.  
  266. proc blt_size {master what} {
  267. }
  268.