1# matrix.tcl -- 2# 3# Implementation of a matrix data structure for Tcl. 4# 5# Copyright (c) 2001 by Andreas Kupries <andreas_kupries@users.sourceforge.net> 6# 7# Heapsort code Copyright (c) 2003 by Edwin A. Suominen <ed@eepatents.com>, 8# based on concepts in "Introduction to Algorithms" by Thomas H. Cormen et al. 9# 10# See the file "license.terms" for information on usage and redistribution 11# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12# 13# RCS: @(#) $Id: matrix1.tcl,v 1.3 2005/09/28 04:51:24 andreas_kupries Exp $ 14 15package require Tcl 8.2 16 17namespace eval ::struct {} 18 19namespace eval ::struct::matrix { 20 # Data storage in the matrix module 21 # ------------------------------- 22 # 23 # One namespace per object, containing 24 # 25 # - Two scalar variables containing the current number of rows and columns. 26 # - Four array variables containing the array data, the caches for 27 # rowheights and columnwidths and the information about linked arrays. 28 # 29 # The variables are 30 # - columns #columns in data 31 # - rows #rows in data 32 # - data cell contents 33 # - colw cache of columnwidths 34 # - rowh cache of rowheights 35 # - link information about linked arrays 36 # - lock boolean flag to disable MatTraceIn while in MatTraceOut [#532783] 37 # - unset string used to convey information about 'unset' traces from MatTraceIn to MatTraceOut. 38 39 # counter is used to give a unique name for unnamed matrices 40 variable counter 0 41 42 # Only export one command, the one used to instantiate a new matrix 43 namespace export matrix 44} 45 46# ::struct::matrix::matrix -- 47# 48# Create a new matrix with a given name; if no name is given, use 49# matrixX, where X is a number. 50# 51# Arguments: 52# name Optional name of the matrix; if null or not given, generate one. 53# 54# Results: 55# name Name of the matrix created 56 57proc ::struct::matrix::matrix {{name ""}} { 58 variable counter 59 60 if { [llength [info level 0]] == 1 } { 61 incr counter 62 set name "matrix${counter}" 63 } 64 65 # FIRST, qualify the name. 66 if {![string match "::*" $name]} { 67 # Get caller's namespace; append :: if not global namespace. 68 set ns [uplevel 1 namespace current] 69 if {"::" != $ns} { 70 append ns "::" 71 } 72 set name "$ns$name" 73 } 74 75 if { [llength [info commands $name]] } { 76 return -code error "command \"$name\" already exists, unable to create matrix" 77 } 78 79 # Set up the namespace 80 namespace eval $name { 81 variable columns 0 82 variable rows 0 83 84 variable data 85 variable colw 86 variable rowh 87 variable link 88 variable lock 89 variable unset 90 91 array set data {} 92 array set colw {} 93 array set rowh {} 94 array set link {} 95 set lock 0 96 set unset {} 97 } 98 99 # Create the command to manipulate the matrix 100 interp alias {} $name {} ::struct::matrix::MatrixProc $name 101 102 return $name 103} 104 105########################## 106# Private functions follow 107 108# ::struct::matrix::MatrixProc -- 109# 110# Command that processes all matrix object commands. 111# 112# Arguments: 113# name Name of the matrix object to manipulate. 114# cmd Subcommand to invoke. 115# args Arguments for subcommand. 116# 117# Results: 118# Varies based on command to perform 119 120proc ::struct::matrix::MatrixProc {name {cmd ""} args} { 121 # Do minimal args checks here 122 if { [llength [info level 0]] == 2 } { 123 return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" 124 } 125 126 # Split the args into command and args components 127 set sub _$cmd 128 if {[llength [info commands ::struct::matrix::$sub]] == 0} { 129 set optlist [lsort [info commands ::struct::matrix::_*]] 130 set xlist {} 131 foreach p $optlist { 132 set p [namespace tail $p] 133 if {[string match __* $p]} {continue} 134 lappend xlist [string range $p 1 end] 135 } 136 set optlist [linsert [join $xlist ", "] "end-1" "or"] 137 return -code error \ 138 "bad option \"$cmd\": must be $optlist" 139 } 140 uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] 141} 142 143# ::struct::matrix::_add -- 144# 145# Command that processes all 'add' subcommands. 146# 147# Arguments: 148# name Name of the matrix object to manipulate. 149# cmd Subcommand of 'add' to invoke. 150# args Arguments for subcommand of 'add'. 151# 152# Results: 153# Varies based on command to perform 154 155proc ::struct::matrix::_add {name {cmd ""} args} { 156 # Do minimal args checks here 157 if { [llength [info level 0]] == 2 } { 158 return -code error "wrong # args: should be \"$name add option ?arg arg ...?\"" 159 } 160 161 # Split the args into command and args components 162 set sub __add_$cmd 163 if { [llength [info commands ::struct::matrix::$sub]] == 0 } { 164 set optlist [lsort [info commands ::struct::matrix::__add_*]] 165 set xlist {} 166 foreach p $optlist { 167 set p [namespace tail $p] 168 lappend xlist [string range $p 6 end] 169 } 170 set optlist [linsert [join $xlist ", "] "end-1" "or"] 171 return -code error \ 172 "bad option \"$cmd\": must be $optlist" 173 } 174 uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] 175} 176 177# ::struct::matrix::_delete -- 178# 179# Command that processes all 'delete' subcommands. 180# 181# Arguments: 182# name Name of the matrix object to manipulate. 183# cmd Subcommand of 'delete' to invoke. 184# args Arguments for subcommand of 'delete'. 185# 186# Results: 187# Varies based on command to perform 188 189proc ::struct::matrix::_delete {name {cmd ""} args} { 190 # Do minimal args checks here 191 if { [llength [info level 0]] == 2 } { 192 return -code error "wrong # args: should be \"$name delete option ?arg arg ...?\"" 193 } 194 195 # Split the args into command and args components 196 set sub __delete_$cmd 197 if { [llength [info commands ::struct::matrix::$sub]] == 0 } { 198 set optlist [lsort [info commands ::struct::matrix::__delete_*]] 199 set xlist {} 200 foreach p $optlist { 201 set p [namespace tail $p] 202 lappend xlist [string range $p 9 end] 203 } 204 set optlist [linsert [join $xlist ", "] "end-1" "or"] 205 return -code error \ 206 "bad option \"$cmd\": must be $optlist" 207 } 208 uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] 209} 210 211# ::struct::matrix::_format -- 212# 213# Command that processes all 'format' subcommands. 214# 215# Arguments: 216# name Name of the matrix object to manipulate. 217# cmd Subcommand of 'format' to invoke. 218# args Arguments for subcommand of 'format'. 219# 220# Results: 221# Varies based on command to perform 222 223proc ::struct::matrix::_format {name {cmd ""} args} { 224 # Do minimal args checks here 225 if { [llength [info level 0]] == 2 } { 226 return -code error "wrong # args: should be \"$name format option ?arg arg ...?\"" 227 } 228 229 # Split the args into command and args components 230 set sub __format_$cmd 231 if { [llength [info commands ::struct::matrix::$sub]] == 0 } { 232 set optlist [lsort [info commands ::struct::matrix::__format_*]] 233 set xlist {} 234 foreach p $optlist { 235 set p [namespace tail $p] 236 lappend xlist [string range $p 9 end] 237 } 238 set optlist [linsert [join $xlist ", "] "end-1" "or"] 239 return -code error \ 240 "bad option \"$cmd\": must be $optlist" 241 } 242 uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] 243} 244 245# ::struct::matrix::_get -- 246# 247# Command that processes all 'get' subcommands. 248# 249# Arguments: 250# name Name of the matrix object to manipulate. 251# cmd Subcommand of 'get' to invoke. 252# args Arguments for subcommand of 'get'. 253# 254# Results: 255# Varies based on command to perform 256 257proc ::struct::matrix::_get {name {cmd ""} args} { 258 # Do minimal args checks here 259 if { [llength [info level 0]] == 2 } { 260 return -code error "wrong # args: should be \"$name get option ?arg arg ...?\"" 261 } 262 263 # Split the args into command and args components 264 set sub __get_$cmd 265 if { [llength [info commands ::struct::matrix::$sub]] == 0 } { 266 set optlist [lsort [info commands ::struct::matrix::__get_*]] 267 set xlist {} 268 foreach p $optlist { 269 set p [namespace tail $p] 270 lappend xlist [string range $p 6 end] 271 } 272 set optlist [linsert [join $xlist ", "] "end-1" "or"] 273 return -code error \ 274 "bad option \"$cmd\": must be $optlist" 275 } 276 uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] 277} 278 279# ::struct::matrix::_insert -- 280# 281# Command that processes all 'insert' subcommands. 282# 283# Arguments: 284# name Name of the matrix object to manipulate. 285# cmd Subcommand of 'insert' to invoke. 286# args Arguments for subcommand of 'insert'. 287# 288# Results: 289# Varies based on command to perform 290 291proc ::struct::matrix::_insert {name {cmd ""} args} { 292 # Do minimal args checks here 293 if { [llength [info level 0]] == 2 } { 294 return -code error "wrong # args: should be \"$name insert option ?arg arg ...?\"" 295 } 296 297 # Split the args into command and args components 298 set sub __insert_$cmd 299 if { [llength [info commands ::struct::matrix::$sub]] == 0 } { 300 set optlist [lsort [info commands ::struct::matrix::__insert_*]] 301 set xlist {} 302 foreach p $optlist { 303 set p [namespace tail $p] 304 lappend xlist [string range $p 9 end] 305 } 306 set optlist [linsert [join $xlist ", "] "end-1" "or"] 307 return -code error \ 308 "bad option \"$cmd\": must be $optlist" 309 } 310 uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] 311} 312 313# ::struct::matrix::_search -- 314# 315# Command that processes all 'search' subcommands. 316# 317# Arguments: 318# name Name of the matrix object to manipulate. 319# args Arguments for search. 320# 321# Results: 322# Varies based on command to perform 323 324proc ::struct::matrix::_search {name args} { 325 set mode exact 326 set nocase 0 327 328 while {1} { 329 switch -glob -- [lindex $args 0] { 330 -exact - -glob - -regexp { 331 set mode [string range [lindex $args 0] 1 end] 332 set args [lrange $args 1 end] 333 } 334 -nocase { 335 set nocase 1 336 } 337 -* { 338 return -code error \ 339 "invalid option \"[lindex $args 0]\":\ 340 should be -nocase, -exact, -glob, or -regexp" 341 } 342 default { 343 break 344 } 345 } 346 } 347 348 # Possible argument signatures after option processing 349 # 350 # \ | args 351 # --+-------------------------------------------------------- 352 # 2 | all pattern 353 # 3 | row row pattern, column col pattern 354 # 6 | rect ctl rtl cbr rbr pattern 355 # 356 # All range specifications are internally converted into a 357 # rectangle. 358 359 switch -exact -- [llength $args] { 360 2 - 3 - 6 {} 361 default { 362 return -code error \ 363 "wrong # args: should be\ 364 \"$name search ?option...? (all|row row|column col|rect c r c r) pattern\"" 365 } 366 } 367 368 set range [lindex $args 0] 369 set pattern [lindex $args end] 370 set args [lrange $args 1 end-1] 371 372 variable ${name}::data 373 variable ${name}::columns 374 variable ${name}::rows 375 376 switch -exact -- $range { 377 all { 378 set ctl 0 ; set cbr $columns ; incr cbr -1 379 set rtl 0 ; set rbr $rows ; incr rbr -1 380 } 381 column { 382 set ctl [ChkColumnIndex $name [lindex $args 0]] 383 set cbr $ctl 384 set rtl 0 ; set rbr $rows ; incr rbr -1 385 } 386 row { 387 set rtl [ChkRowIndex $name [lindex $args 0]] 388 set ctl 0 ; set cbr $columns ; incr cbr -1 389 set rbr $rtl 390 } 391 rect { 392 foreach {ctl rtl cbr rbr} $args break 393 set ctl [ChkColumnIndex $name $ctl] 394 set rtl [ChkRowIndex $name $rtl] 395 set cbr [ChkColumnIndex $name $cbr] 396 set rbr [ChkRowIndex $name $rbr] 397 if {($ctl > $cbr) || ($rtl > $rbr)} { 398 return -code error "Invalid cell indices, wrong ordering" 399 } 400 } 401 default { 402 return -code error "invalid range spec \"$range\": should be all, column, row, or rect" 403 } 404 } 405 406 if {$nocase} { 407 set pattern [string tolower $pattern] 408 } 409 410 set matches [list] 411 for {set r $rtl} {$r <= $rbr} {incr r} { 412 for {set c $ctl} {$c <= $cbr} {incr c} { 413 set v $data($c,$r) 414 if {$nocase} { 415 set v [string tolower $v] 416 } 417 switch -exact -- $mode { 418 exact {set matched [string equal $pattern $v]} 419 glob {set matched [string match $pattern $v]} 420 regexp {set matched [regexp -- $pattern $v]} 421 } 422 if {$matched} { 423 lappend matches [list $c $r] 424 } 425 } 426 } 427 return $matches 428} 429 430# ::struct::matrix::_set -- 431# 432# Command that processes all 'set' subcommands. 433# 434# Arguments: 435# name Name of the matrix object to manipulate. 436# cmd Subcommand of 'set' to invoke. 437# args Arguments for subcommand of 'set'. 438# 439# Results: 440# Varies based on command to perform 441 442proc ::struct::matrix::_set {name {cmd ""} args} { 443 # Do minimal args checks here 444 if { [llength [info level 0]] == 2 } { 445 return -code error "wrong # args: should be \"$name set option ?arg arg ...?\"" 446 } 447 448 # Split the args into command and args components 449 set sub __set_$cmd 450 if { [llength [info commands ::struct::matrix::$sub]] == 0 } { 451 set optlist [lsort [info commands ::struct::matrix::__set_*]] 452 set xlist {} 453 foreach p $optlist { 454 set p [namespace tail $p] 455 lappend xlist [string range $p 6 end] 456 } 457 set optlist [linsert [join $xlist ", "] "end-1" "or"] 458 return -code error \ 459 "bad option \"$cmd\": must be $optlist" 460 } 461 uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] 462} 463 464# ::struct::matrix::_sort -- 465# 466# Command that processes all 'sort' subcommands. 467# 468# Arguments: 469# name Name of the matrix object to manipulate. 470# cmd Subcommand of 'sort' to invoke. 471# args Arguments for subcommand of 'sort'. 472# 473# Results: 474# Varies based on command to perform 475 476proc ::struct::matrix::_sort {name cmd args} { 477 # Do minimal args checks here 478 if { [llength [info level 0]] == 2 } { 479 return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" 480 } 481 if {[string equal $cmd "rows"]} { 482 set code r 483 set byrows 1 484 } elseif {[string equal $cmd "columns"]} { 485 set code c 486 set byrows 0 487 } else { 488 return -code error \ 489 "bad option \"$cmd\": must be columns, or rows" 490 } 491 492 set revers 0 ;# Default: -increasing 493 while {1} { 494 switch -glob -- [lindex $args 0] { 495 -increasing {set revers 0} 496 -decreasing {set revers 1} 497 default { 498 if {[llength $args] > 1} { 499 return -code error \ 500 "invalid option \"[lindex $args 0]\":\ 501 should be -increasing, or -decreasing" 502 } 503 break 504 } 505 } 506 set args [lrange $args 1 end] 507 } 508 # ASSERT: [llength $args] == 1 509 510 if {[llength $args] != 1} { 511 return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" 512 } 513 514 set key [lindex $args 0] 515 516 if {$byrows} { 517 set key [ChkColumnIndex $name $key] 518 variable ${name}::rows 519 520 # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 521 set heapSize $rows 522 } else { 523 set key [ChkRowIndex $name $key] 524 variable ${name}::columns 525 526 # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 527 set heapSize $columns 528 } 529 530 for {set i [expr {int($heapSize/2)-1}]} {$i>=0} {incr i -1} { 531 SortMaxHeapify $name $i $key $code $heapSize $revers 532 } 533 534 # Adapted by EAS from remainder of HEAPSORT(A) of CRLS 6.4 535 for {set i [expr {$heapSize-1}]} {$i>=1} {incr i -1} { 536 if {$byrows} { 537 SwapRows $name 0 $i 538 } else { 539 SwapColumns $name 0 $i 540 } 541 incr heapSize -1 542 SortMaxHeapify $name 0 $key $code $heapSize $revers 543 } 544 return 545} 546 547# ::struct::matrix::_swap -- 548# 549# Command that processes all 'swap' subcommands. 550# 551# Arguments: 552# name Name of the matrix object to manipulate. 553# cmd Subcommand of 'swap' to invoke. 554# args Arguments for subcommand of 'swap'. 555# 556# Results: 557# Varies based on command to perform 558 559proc ::struct::matrix::_swap {name {cmd ""} args} { 560 # Do minimal args checks here 561 if { [llength [info level 0]] == 2 } { 562 return -code error "wrong # args: should be \"$name swap option ?arg arg ...?\"" 563 } 564 565 # Split the args into command and args components 566 set sub __swap_$cmd 567 if { [llength [info commands ::struct::matrix::$sub]] == 0 } { 568 set optlist [lsort [info commands ::struct::matrix::__swap_*]] 569 set xlist {} 570 foreach p $optlist { 571 set p [namespace tail $p] 572 lappend xlist [string range $p 7 end] 573 } 574 set optlist [linsert [join $xlist ", "] "end-1" "or"] 575 return -code error \ 576 "bad option \"$cmd\": must be $optlist" 577 } 578 uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] 579} 580 581# ::struct::matrix::__add_column -- 582# 583# Extends the matrix by one column and then acts like 584# "setcolumn" (see below) on this new column if there were 585# "values" supplied. Without "values" the new cells will be set 586# to the empty string. The new column is appended immediately 587# behind the last existing column. 588# 589# Arguments: 590# name Name of the matrix object. 591# values Optional values to set into the new row. 592# 593# Results: 594# None. 595 596proc ::struct::matrix::__add_column {name {values {}}} { 597 variable ${name}::data 598 variable ${name}::columns 599 variable ${name}::rows 600 variable ${name}::rowh 601 602 if {[set l [llength $values]] < $rows} { 603 # Missing values. Fill up with empty strings 604 605 for {} {$l < $rows} {incr l} { 606 lappend values {} 607 } 608 } elseif {[llength $values] > $rows} { 609 # To many values. Remove the superfluous items 610 set values [lrange $values 0 [expr {$rows - 1}]] 611 } 612 613 # "values" now contains the information to set into the array. 614 # Regarding the width and height caches: 615 616 # - The new column is not added to the width cache, the other 617 # columns are not touched, the cache therefore unchanged. 618 # - The rows are either removed from the height cache or left 619 # unchanged, depending on the contents set into the cell. 620 621 set r 0 622 foreach v $values { 623 if {$v != {}} { 624 # Data changed unpredictably, invalidate cache 625 catch {unset rowh($r)} 626 } ; # {else leave the row unchanged} 627 set data($columns,$r) $v 628 incr r 629 } 630 incr columns 631 return 632} 633 634# ::struct::matrix::__add_row -- 635# 636# Extends the matrix by one row and then acts like "setrow" (see 637# below) on this new row if there were "values" 638# supplied. Without "values" the new cells will be set to the 639# empty string. The new row is appended immediately behind the 640# last existing row. 641# 642# Arguments: 643# name Name of the matrix object. 644# values Optional values to set into the new row. 645# 646# Results: 647# None. 648 649proc ::struct::matrix::__add_row {name {values {}}} { 650 variable ${name}::data 651 variable ${name}::columns 652 variable ${name}::rows 653 variable ${name}::colw 654 655 if {[set l [llength $values]] < $columns} { 656 # Missing values. Fill up with empty strings 657 658 for {} {$l < $columns} {incr l} { 659 lappend values {} 660 } 661 } elseif {[llength $values] > $columns} { 662 # To many values. Remove the superfluous items 663 set values [lrange $values 0 [expr {$columns - 1}]] 664 } 665 666 # "values" now contains the information to set into the array. 667 # Regarding the width and height caches: 668 669 # - The new row is not added to the height cache, the other 670 # rows are not touched, the cache therefore unchanged. 671 # - The columns are either removed from the width cache or left 672 # unchanged, depending on the contents set into the cell. 673 674 set c 0 675 foreach v $values { 676 if {$v != {}} { 677 # Data changed unpredictably, invalidate cache 678 catch {unset colw($c)} 679 } ; # {else leave the row unchanged} 680 set data($c,$rows) $v 681 incr c 682 } 683 incr rows 684 return 685} 686 687# ::struct::matrix::__add_columns -- 688# 689# Extends the matrix by "n" columns. The new cells will be set 690# to the empty string. The new columns are appended immediately 691# behind the last existing column. A value of "n" equal to or 692# smaller than 0 is not allowed. 693# 694# Arguments: 695# name Name of the matrix object. 696# n The number of new columns to create. 697# 698# Results: 699# None. 700 701proc ::struct::matrix::__add_columns {name n} { 702 if {$n <= 0} { 703 return -code error "A value of n <= 0 is not allowed" 704 } 705 706 variable ${name}::data 707 variable ${name}::columns 708 variable ${name}::rows 709 710 # The new values set into the cell is always the empty 711 # string. These have a length and height of 0, i.e. the don't 712 # influence cached widths and heights as they are at least that 713 # big. IOW there is no need to touch and change the width and 714 # height caches. 715 716 while {$n > 0} { 717 for {set r 0} {$r < $rows} {incr r} { 718 set data($columns,$r) "" 719 } 720 incr columns 721 incr n -1 722 } 723 724 return 725} 726 727# ::struct::matrix::__add_rows -- 728# 729# Extends the matrix by "n" rows. The new cells will be set to 730# the empty string. The new rows are appended immediately behind 731# the last existing row. A value of "n" equal to or smaller than 732# 0 is not allowed. 733# 734# Arguments: 735# name Name of the matrix object. 736# n The number of new rows to create. 737# 738# Results: 739# None. 740 741proc ::struct::matrix::__add_rows {name n} { 742 if {$n <= 0} { 743 return -code error "A value of n <= 0 is not allowed" 744 } 745 746 variable ${name}::data 747 variable ${name}::columns 748 variable ${name}::rows 749 750 # The new values set into the cell is always the empty 751 # string. These have a length and height of 0, i.e. the don't 752 # influence cached widths and heights as they are at least that 753 # big. IOW there is no need to touch and change the width and 754 # height caches. 755 756 while {$n > 0} { 757 for {set c 0} {$c < $columns} {incr c} { 758 set data($c,$rows) "" 759 } 760 incr rows 761 incr n -1 762 } 763 return 764} 765 766# ::struct::matrix::_cells -- 767# 768# Returns the number of cells currently managed by the 769# matrix. This is the product of "rows" and "columns". 770# 771# Arguments: 772# name Name of the matrix object. 773# 774# Results: 775# The number of cells in the matrix. 776 777proc ::struct::matrix::_cells {name} { 778 variable ${name}::rows 779 variable ${name}::columns 780 return [expr {$rows * $columns}] 781} 782 783# ::struct::matrix::_cellsize -- 784# 785# Returns the length of the string representation of the value 786# currently contained in the addressed cell. 787# 788# Arguments: 789# name Name of the matrix object. 790# column Column index of the cell to query 791# row Row index of the cell to query 792# 793# Results: 794# The number of cells in the matrix. 795 796proc ::struct::matrix::_cellsize {name column row} { 797 set column [ChkColumnIndex $name $column] 798 set row [ChkRowIndex $name $row] 799 800 variable ${name}::data 801 return [string length $data($column,$row)] 802} 803 804# ::struct::matrix::_columns -- 805# 806# Returns the number of columns currently managed by the 807# matrix. 808# 809# Arguments: 810# name Name of the matrix object. 811# 812# Results: 813# The number of columns in the matrix. 814 815proc ::struct::matrix::_columns {name} { 816 variable ${name}::columns 817 return $columns 818} 819 820# ::struct::matrix::_columnwidth -- 821# 822# Returns the length of the longest string representation of all 823# the values currently contained in the cells of the addressed 824# column if these are all spanning only one line. For cell 825# values spanning multiple lines the length of their longest 826# line goes into the computation. 827# 828# Arguments: 829# name Name of the matrix object. 830# column The index of the column whose width is asked for. 831# 832# Results: 833# See description. 834 835proc ::struct::matrix::_columnwidth {name column} { 836 set column [ChkColumnIndex $name $column] 837 838 variable ${name}::colw 839 840 if {![info exists colw($column)]} { 841 variable ${name}::rows 842 variable ${name}::data 843 844 set width 0 845 for {set r 0} {$r < $rows} {incr r} { 846 foreach line [split $data($column,$r) \n] { 847 set len [string length $line] 848 if {$len > $width} { 849 set width $len 850 } 851 } 852 } 853 854 set colw($column) $width 855 } 856 857 return $colw($column) 858} 859 860# ::struct::matrix::__delete_column -- 861# 862# Deletes the specified column from the matrix and shifts all 863# columns with higher indices one index down. 864# 865# Arguments: 866# name Name of the matrix. 867# column The index of the column to delete. 868# 869# Results: 870# None. 871 872proc ::struct::matrix::__delete_column {name column} { 873 set column [ChkColumnIndex $name $column] 874 875 variable ${name}::data 876 variable ${name}::rows 877 variable ${name}::columns 878 variable ${name}::colw 879 variable ${name}::rowh 880 881 # Move all data from the higher columns down and then delete the 882 # superfluous data in the old last column. Move the data in the 883 # width cache too, take partial fill into account there too. 884 # Invalidate the height cache for all rows. 885 886 for {set r 0} {$r < $rows} {incr r} { 887 for {set c $column; set cn [expr {$c + 1}]} {$cn < $columns} {incr c ; incr cn} { 888 set data($c,$r) $data($cn,$r) 889 if {[info exists colw($cn)]} { 890 set colw($c) $colw($cn) 891 unset colw($cn) 892 } 893 } 894 unset data($c,$r) 895 catch {unset rowh($r)} 896 } 897 incr columns -1 898 return 899} 900 901# ::struct::matrix::__delete_row -- 902# 903# Deletes the specified row from the matrix and shifts all 904# row with higher indices one index down. 905# 906# Arguments: 907# name Name of the matrix. 908# row The index of the row to delete. 909# 910# Results: 911# None. 912 913proc ::struct::matrix::__delete_row {name row} { 914 set row [ChkRowIndex $name $row] 915 916 variable ${name}::data 917 variable ${name}::rows 918 variable ${name}::columns 919 variable ${name}::colw 920 variable ${name}::rowh 921 922 # Move all data from the higher rows down and then delete the 923 # superfluous data in the old last row. Move the data in the 924 # height cache too, take partial fill into account there too. 925 # Invalidate the width cache for all columns. 926 927 for {set c 0} {$c < $columns} {incr c} { 928 for {set r $row; set rn [expr {$r + 1}]} {$rn < $rows} {incr r ; incr rn} { 929 set data($c,$r) $data($c,$rn) 930 if {[info exists rowh($rn)]} { 931 set rowh($r) $rowh($rn) 932 unset rowh($rn) 933 } 934 } 935 unset data($c,$r) 936 catch {unset colw($c)} 937 } 938 incr rows -1 939 return 940} 941 942# ::struct::matrix::_destroy -- 943# 944# Destroy a matrix, including its associated command and data storage. 945# 946# Arguments: 947# name Name of the matrix to destroy. 948# 949# Results: 950# None. 951 952proc ::struct::matrix::_destroy {name} { 953 variable ${name}::link 954 955 # Unlink all existing arrays before destroying the object so that 956 # we don't leave dangling references / traces. 957 958 foreach avar [array names link] { 959 _unlink $name $avar 960 } 961 962 namespace delete $name 963 interp alias {} $name {} 964} 965 966# ::struct::matrix::__format_2string -- 967# 968# Formats the matrix using the specified report object and 969# returns the string containing the result of this 970# operation. The report has to support the "printmatrix" method. 971# 972# Arguments: 973# name Name of the matrix. 974# report Name of the report object specifying the formatting. 975# 976# Results: 977# A string containing the formatting result. 978 979proc ::struct::matrix::__format_2string {name {report {}}} { 980 if {$report == {}} { 981 # Use an internal hardwired simple report to format the matrix. 982 # 1. Go through all columns and compute the column widths. 983 # 2. Then iterate through all rows and dump then into a 984 # string, formatted to the number of characters per columns 985 986 array set cw {} 987 set cols [_columns $name] 988 for {set c 0} {$c < $cols} {incr c} { 989 set cw($c) [_columnwidth $name $c] 990 } 991 992 set result [list] 993 set n [_rows $name] 994 for {set r 0} {$r < $n} {incr r} { 995 set rh [_rowheight $name $r] 996 if {$rh < 2} { 997 # Simple row. 998 set line [list] 999 for {set c 0} {$c < $cols} {incr c} { 1000 set val [__get_cell $name $c $r] 1001 lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]" 1002 } 1003 lappend result [join $line " "] 1004 } else { 1005 # Complex row, multiple passes 1006 for {set h 0} {$h < $rh} {incr h} { 1007 set line [list] 1008 for {set c 0} {$c < $cols} {incr c} { 1009 set val [lindex [split [__get_cell $name $c $r] \n] $h] 1010 lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]" 1011 } 1012 lappend result [join $line " "] 1013 } 1014 } 1015 } 1016 return [join $result \n] 1017 } else { 1018 return [$report printmatrix $name] 1019 } 1020} 1021 1022# ::struct::matrix::__format_2chan -- 1023# 1024# Formats the matrix using the specified report object and 1025# writes the string containing the result of this operation into 1026# the channel. The report has to support the 1027# "printmatrix2channel" method. 1028# 1029# Arguments: 1030# name Name of the matrix. 1031# report Name of the report object specifying the formatting. 1032# chan Handle of the channel to write to. 1033# 1034# Results: 1035# None. 1036 1037proc ::struct::matrix::__format_2chan {name {report {}} {chan stdout}} { 1038 if {$report == {}} { 1039 # Use an internal hardwired simple report to format the matrix. 1040 # We delegate this to the string formatter and print its result. 1041 puts -nonewline [__format_2string $name] 1042 } else { 1043 $report printmatrix2channel $name $chan 1044 } 1045 return 1046} 1047 1048# ::struct::matrix::__get_cell -- 1049# 1050# Returns the value currently contained in the cell identified 1051# by row and column index. 1052# 1053# Arguments: 1054# name Name of the matrix. 1055# column Column index of the addressed cell. 1056# row Row index of the addressed cell. 1057# 1058# Results: 1059# value Value currently stored in the addressed cell. 1060 1061proc ::struct::matrix::__get_cell {name column row} { 1062 set column [ChkColumnIndex $name $column] 1063 set row [ChkRowIndex $name $row] 1064 1065 variable ${name}::data 1066 return $data($column,$row) 1067} 1068 1069# ::struct::matrix::__get_column -- 1070# 1071# Returns a list containing the values from all cells in the 1072# column identified by the index. The contents of the cell in 1073# row 0 are stored as the first element of this list. 1074# 1075# Arguments: 1076# name Name of the matrix. 1077# column Column index of the addressed cell. 1078# 1079# Results: 1080# List of values stored in the addressed row. 1081 1082proc ::struct::matrix::__get_column {name column} { 1083 set column [ChkColumnIndex $name $column] 1084 return [GetColumn $name $column] 1085} 1086 1087proc ::struct::matrix::GetColumn {name column} { 1088 variable ${name}::data 1089 variable ${name}::rows 1090 1091 set result [list] 1092 for {set r 0} {$r < $rows} {incr r} { 1093 lappend result $data($column,$r) 1094 } 1095 return $result 1096} 1097 1098# ::struct::matrix::__get_rect -- 1099# 1100# Returns a list of lists of cell values. The values stored in 1101# the result come from the submatrix whose top-left and 1102# bottom-right cells are specified by "column_tl", "row_tl" and 1103# "column_br", "row_br" resp. Note that the following equations 1104# have to be true: column_tl <= column_br and row_tl <= row_br. 1105# The result is organized as follows: The outer list is the list 1106# of rows, its elements are lists representing a single row. The 1107# row with the smallest index is the first element of the outer 1108# list. The elements of the row lists represent the selected 1109# cell values. The cell with the smallest index is the first 1110# element in each row list. 1111# 1112# Arguments: 1113# name Name of the matrix. 1114# column_tl Column index of the top-left cell of the area. 1115# row_tl Row index of the top-left cell of the the area 1116# column_br Column index of the bottom-right cell of the area. 1117# row_br Row index of the bottom-right cell of the the area 1118# 1119# Results: 1120# List of a list of values stored in the addressed area. 1121 1122proc ::struct::matrix::__get_rect {name column_tl row_tl column_br row_br} { 1123 set column_tl [ChkColumnIndex $name $column_tl] 1124 set row_tl [ChkRowIndex $name $row_tl] 1125 set column_br [ChkColumnIndex $name $column_br] 1126 set row_br [ChkRowIndex $name $row_br] 1127 1128 if { 1129 ($column_tl > $column_br) || 1130 ($row_tl > $row_br) 1131 } { 1132 return -code error "Invalid cell indices, wrong ordering" 1133 } 1134 1135 variable ${name}::data 1136 set result [list] 1137 1138 for {set r $row_tl} {$r <= $row_br} {incr r} { 1139 set row [list] 1140 for {set c $column_tl} {$c <= $column_br} {incr c} { 1141 lappend row $data($c,$r) 1142 } 1143 lappend result $row 1144 } 1145 1146 return $result 1147} 1148 1149# ::struct::matrix::__get_row -- 1150# 1151# Returns a list containing the values from all cells in the 1152# row identified by the index. The contents of the cell in 1153# column 0 are stored as the first element of this list. 1154# 1155# Arguments: 1156# name Name of the matrix. 1157# row Row index of the addressed cell. 1158# 1159# Results: 1160# List of values stored in the addressed row. 1161 1162proc ::struct::matrix::__get_row {name row} { 1163 set row [ChkRowIndex $name $row] 1164 return [GetRow $name $row] 1165} 1166 1167proc ::struct::matrix::GetRow {name row} { 1168 variable ${name}::data 1169 variable ${name}::columns 1170 1171 set result [list] 1172 for {set c 0} {$c < $columns} {incr c} { 1173 lappend result $data($c,$row) 1174 } 1175 return $result 1176} 1177 1178# ::struct::matrix::__insert_column -- 1179# 1180# Extends the matrix by one column and then acts like 1181# "setcolumn" (see below) on this new column if there were 1182# "values" supplied. Without "values" the new cells will be set 1183# to the empty string. The new column is inserted just before 1184# the column specified by the given index. This means, if 1185# "column" is less than or equal to zero, then the new column is 1186# inserted at the beginning of the matrix, before the first 1187# column. If "column" has the value "Bend", or if it is greater 1188# than or equal to the number of columns in the matrix, then the 1189# new column is appended to the matrix, behind the last 1190# column. The old column at the chosen index and all columns 1191# with higher indices are shifted one index upward. 1192# 1193# Arguments: 1194# name Name of the matrix. 1195# column Index of the column where to insert. 1196# values Optional values to set the cells to. 1197# 1198# Results: 1199# None. 1200 1201proc ::struct::matrix::__insert_column {name column {values {}}} { 1202 # Allow both negative and too big indices. 1203 set column [ChkColumnIndexAll $name $column] 1204 1205 variable ${name}::columns 1206 1207 if {$column > $columns} { 1208 # Same as 'addcolumn' 1209 __add_column $name $values 1210 return 1211 } 1212 1213 variable ${name}::data 1214 variable ${name}::rows 1215 variable ${name}::rowh 1216 variable ${name}::colw 1217 1218 set firstcol $column 1219 if {$firstcol < 0} { 1220 set firstcol 0 1221 } 1222 1223 if {[set l [llength $values]] < $rows} { 1224 # Missing values. Fill up with empty strings 1225 1226 for {} {$l < $rows} {incr l} { 1227 lappend values {} 1228 } 1229 } elseif {[llength $values] > $rows} { 1230 # To many values. Remove the superfluous items 1231 set values [lrange $values 0 [expr {$rows - 1}]] 1232 } 1233 1234 # "values" now contains the information to set into the array. 1235 # Regarding the width and height caches: 1236 # Invalidate all rows, move all columns 1237 1238 # Move all data from the higher columns one up and then insert the 1239 # new data into the freed space. Move the data in the 1240 # width cache too, take partial fill into account there too. 1241 # Invalidate the height cache for all rows. 1242 1243 for {set r 0} {$r < $rows} {incr r} { 1244 for {set cn $columns ; set c [expr {$cn - 1}]} {$c >= $firstcol} {incr c -1 ; incr cn -1} { 1245 set data($cn,$r) $data($c,$r) 1246 if {[info exists colw($c)]} { 1247 set colw($cn) $colw($c) 1248 unset colw($c) 1249 } 1250 } 1251 set data($firstcol,$r) [lindex $values $r] 1252 catch {unset rowh($r)} 1253 } 1254 incr columns 1255 return 1256} 1257 1258# ::struct::matrix::__insert_row -- 1259# 1260# Extends the matrix by one row and then acts like "setrow" (see 1261# below) on this new row if there were "values" 1262# supplied. Without "values" the new cells will be set to the 1263# empty string. The new row is inserted just before the row 1264# specified by the given index. This means, if "row" is less 1265# than or equal to zero, then the new row is inserted at the 1266# beginning of the matrix, before the first row. If "row" has 1267# the value "end", or if it is greater than or equal to the 1268# number of rows in the matrix, then the new row is appended to 1269# the matrix, behind the last row. The old row at that index and 1270# all rows with higher indices are shifted one index upward. 1271# 1272# Arguments: 1273# name Name of the matrix. 1274# row Index of the row where to insert. 1275# values Optional values to set the cells to. 1276# 1277# Results: 1278# None. 1279 1280proc ::struct::matrix::__insert_row {name row {values {}}} { 1281 # Allow both negative and too big indices. 1282 set row [ChkRowIndexAll $name $row] 1283 1284 variable ${name}::rows 1285 1286 if {$row > $rows} { 1287 # Same as 'addrow' 1288 __add_row $name $values 1289 return 1290 } 1291 1292 variable ${name}::data 1293 variable ${name}::columns 1294 variable ${name}::rowh 1295 variable ${name}::colw 1296 1297 set firstrow $row 1298 if {$firstrow < 0} { 1299 set firstrow 0 1300 } 1301 1302 if {[set l [llength $values]] < $columns} { 1303 # Missing values. Fill up with empty strings 1304 1305 for {} {$l < $columns} {incr l} { 1306 lappend values {} 1307 } 1308 } elseif {[llength $values] > $columns} { 1309 # To many values. Remove the superfluous items 1310 set values [lrange $values 0 [expr {$columns - 1}]] 1311 } 1312 1313 # "values" now contains the information to set into the array. 1314 # Regarding the width and height caches: 1315 # Invalidate all columns, move all rows 1316 1317 # Move all data from the higher rows one up and then insert the 1318 # new data into the freed space. Move the data in the 1319 # height cache too, take partial fill into account there too. 1320 # Invalidate the width cache for all columns. 1321 1322 for {set c 0} {$c < $columns} {incr c} { 1323 for {set rn $rows ; set r [expr {$rn - 1}]} {$r >= $firstrow} {incr r -1 ; incr rn -1} { 1324 set data($c,$rn) $data($c,$r) 1325 if {[info exists rowh($r)]} { 1326 set rowh($rn) $rowh($r) 1327 unset rowh($r) 1328 } 1329 } 1330 set data($c,$firstrow) [lindex $values $c] 1331 catch {unset colw($c)} 1332 } 1333 incr rows 1334 return 1335} 1336 1337# ::struct::matrix::_link -- 1338# 1339# Links the matrix to the specified array variable. This means 1340# that the contents of all cells in the matrix is stored in the 1341# array too, with all changes to the matrix propagated there 1342# too. The contents of the cell "(column,row)" is stored in the 1343# array using the key "column,row". If the option "-transpose" 1344# is specified the key "row,column" will be used instead. It is 1345# possible to link the matrix to more than one array. Note that 1346# the link is bidirectional, i.e. changes to the array are 1347# mirrored in the matrix too. 1348# 1349# Arguments: 1350# name Name of the matrix object. 1351# option Either empty of '-transpose'. 1352# avar Name of the variable to link to 1353# 1354# Results: 1355# None 1356 1357proc ::struct::matrix::_link {name args} { 1358 switch -exact -- [llength $args] { 1359 0 { 1360 return -code error "$name: wrong # args: link ?-transpose? arrayvariable" 1361 } 1362 1 { 1363 set transpose 0 1364 set variable [lindex $args 0] 1365 } 1366 2 { 1367 foreach {t variable} $args break 1368 if {[string compare $t -transpose]} { 1369 return -code error "$name: illegal syntax: link ?-transpose? arrayvariable" 1370 } 1371 set transpose 1 1372 } 1373 default { 1374 return -code error "$name: wrong # args: link ?-transpose? arrayvariable" 1375 } 1376 } 1377 1378 variable ${name}::link 1379 1380 if {[info exists link($variable)]} { 1381 return -code error "$name link: Variable \"$variable\" already linked to matrix" 1382 } 1383 1384 # Ok, a new variable we are linked to. Record this information, 1385 # dump our current contents into the array, at last generate the 1386 # traces actually performing the link. 1387 1388 set link($variable) $transpose 1389 1390 upvar #0 $variable array 1391 variable ${name}::data 1392 1393 foreach key [array names data] { 1394 foreach {c r} [split $key ,] break 1395 if {$transpose} { 1396 set array($r,$c) $data($key) 1397 } else { 1398 set array($c,$r) $data($key) 1399 } 1400 } 1401 1402 trace variable array wu [list ::struct::matrix::MatTraceIn $variable $name] 1403 trace variable data w [list ::struct::matrix::MatTraceOut $variable $name] 1404 return 1405} 1406 1407# ::struct::matrix::_links -- 1408# 1409# Retrieves the names of all array variable the matrix is 1410# officialy linked to. 1411# 1412# Arguments: 1413# name Name of the matrix object. 1414# 1415# Results: 1416# List of variables the matrix is linked to. 1417 1418proc ::struct::matrix::_links {name} { 1419 variable ${name}::link 1420 return [array names link] 1421} 1422 1423# ::struct::matrix::_rowheight -- 1424# 1425# Returns the height of the specified row in lines. This is the 1426# highest number of lines spanned by a cell over all cells in 1427# the row. 1428# 1429# Arguments: 1430# name Name of the matrix 1431# row Index of the row queried for its height 1432# 1433# Results: 1434# The height of the specified row in lines. 1435 1436proc ::struct::matrix::_rowheight {name row} { 1437 set row [ChkRowIndex $name $row] 1438 1439 variable ${name}::rowh 1440 1441 if {![info exists rowh($row)]} { 1442 variable ${name}::columns 1443 variable ${name}::data 1444 1445 set height 1 1446 for {set c 0} {$c < $columns} {incr c} { 1447 set cheight [llength [split $data($c,$row) \n]] 1448 if {$cheight > $height} { 1449 set height $cheight 1450 } 1451 } 1452 1453 set rowh($row) $height 1454 } 1455 return $rowh($row) 1456} 1457 1458# ::struct::matrix::_rows -- 1459# 1460# Returns the number of rows currently managed by the matrix. 1461# 1462# Arguments: 1463# name Name of the matrix object. 1464# 1465# Results: 1466# The number of rows in the matrix. 1467 1468proc ::struct::matrix::_rows {name} { 1469 variable ${name}::rows 1470 return $rows 1471} 1472 1473# ::struct::matrix::__set_cell -- 1474# 1475# Sets the value in the cell identified by row and column index 1476# to the data in the third argument. 1477# 1478# Arguments: 1479# name Name of the matrix object. 1480# column Column index of the cell to set. 1481# row Row index of the cell to set. 1482# value THe new value of the cell. 1483# 1484# Results: 1485# None. 1486 1487proc ::struct::matrix::__set_cell {name column row value} { 1488 set column [ChkColumnIndex $name $column] 1489 set row [ChkRowIndex $name $row] 1490 1491 variable ${name}::data 1492 1493 if {![string compare $value $data($column,$row)]} { 1494 # No change, ignore call! 1495 return 1496 } 1497 1498 set data($column,$row) $value 1499 1500 if {$value != {}} { 1501 variable ${name}::colw 1502 variable ${name}::rowh 1503 catch {unset colw($column)} 1504 catch {unset rowh($row)} 1505 } 1506 return 1507} 1508 1509# ::struct::matrix::__set_column -- 1510# 1511# Sets the values in the cells identified by the column index to 1512# the elements of the list provided as the third argument. Each 1513# element of the list is assigned to one cell, with the first 1514# element going into the cell in row 0 and then upward. If there 1515# are less values in the list than there are rows the remaining 1516# rows are set to the empty string. If there are more values in 1517# the list than there are rows the superfluous elements are 1518# ignored. The matrix is not extended by this operation. 1519# 1520# Arguments: 1521# name Name of the matrix. 1522# column Index of the column to set. 1523# values Values to set into the column. 1524# 1525# Results: 1526# None. 1527 1528proc ::struct::matrix::__set_column {name column values} { 1529 set column [ChkColumnIndex $name $column] 1530 1531 variable ${name}::data 1532 variable ${name}::columns 1533 variable ${name}::rows 1534 variable ${name}::rowh 1535 variable ${name}::colw 1536 1537 if {[set l [llength $values]] < $rows} { 1538 # Missing values. Fill up with empty strings 1539 1540 for {} {$l < $rows} {incr l} { 1541 lappend values {} 1542 } 1543 } elseif {[llength $values] > $rows} { 1544 # To many values. Remove the superfluous items 1545 set values [lrange $values 0 [expr {$rows - 1}]] 1546 } 1547 1548 # "values" now contains the information to set into the array. 1549 # Regarding the width and height caches: 1550 1551 # - Invalidate the column in the width cache. 1552 # - The rows are either removed from the height cache or left 1553 # unchanged, depending on the contents set into the cell. 1554 1555 set r 0 1556 foreach v $values { 1557 if {$v != {}} { 1558 # Data changed unpredictably, invalidate cache 1559 catch {unset rowh($r)} 1560 } ; # {else leave the row unchanged} 1561 set data($column,$r) $v 1562 incr r 1563 } 1564 catch {unset colw($column)} 1565 return 1566} 1567 1568# ::struct::matrix::__set_rect -- 1569# 1570# Takes a list of lists of cell values and writes them into the 1571# submatrix whose top-left cell is specified by the two 1572# indices. If the sublists of the outerlist are not of equal 1573# length the shorter sublists will be filled with empty strings 1574# to the length of the longest sublist. If the submatrix 1575# specified by the top-left cell and the number of rows and 1576# columns in the "values" extends beyond the matrix we are 1577# modifying the over-extending parts of the values are ignored, 1578# i.e. essentially cut off. This subcommand expects its input in 1579# the format as returned by "getrect". 1580# 1581# Arguments: 1582# name Name of the matrix object. 1583# column Column index of the topleft cell to set. 1584# row Row index of the topleft cell to set. 1585# values Values to set. 1586# 1587# Results: 1588# None. 1589 1590proc ::struct::matrix::__set_rect {name column row values} { 1591 # Allow negative indices! 1592 set column [ChkColumnIndexNeg $name $column] 1593 set row [ChkRowIndexNeg $name $row] 1594 1595 variable ${name}::data 1596 variable ${name}::columns 1597 variable ${name}::rows 1598 variable ${name}::colw 1599 variable ${name}::rowh 1600 1601 if {$row < 0} { 1602 # Remove rows from the head of values to restrict it to the 1603 # overlapping area. 1604 1605 set values [lrange $values [expr {0 - $row}] end] 1606 set row 0 1607 } 1608 1609 # Restrict it at the end too. 1610 if {($row + [llength $values]) > $rows} { 1611 set values [lrange $values 0 [expr {$rows - $row - 1}]] 1612 } 1613 1614 # Same for columns, but store it in some vars as this is required 1615 # in a loop. 1616 set firstcol 0 1617 if {$column < 0} { 1618 set firstcol [expr {0 - $column}] 1619 set column 0 1620 } 1621 1622 # Now pan through values and area and copy the external data into 1623 # the matrix. 1624 1625 set r $row 1626 foreach line $values { 1627 set line [lrange $line $firstcol end] 1628 1629 set l [expr {$column + [llength $line]}] 1630 if {$l > $columns} { 1631 set line [lrange $line 0 [expr {$columns - $column - 1}]] 1632 } elseif {$l < [expr {$columns - $firstcol}]} { 1633 # We have to take the offset into the line into account 1634 # or we add fillers we don't need, overwriting part of the 1635 # data array we shouldn't. 1636 1637 for {} {$l < [expr {$columns - $firstcol}]} {incr l} { 1638 lappend line {} 1639 } 1640 } 1641 1642 set c $column 1643 foreach cell $line { 1644 if {$cell != {}} { 1645 catch {unset rowh($r)} 1646 catch {unset colw($c)} 1647 } 1648 set data($c,$r) $cell 1649 incr c 1650 } 1651 incr r 1652 } 1653 return 1654} 1655 1656# ::struct::matrix::__set_row -- 1657# 1658# Sets the values in the cells identified by the row index to 1659# the elements of the list provided as the third argument. Each 1660# element of the list is assigned to one cell, with the first 1661# element going into the cell in column 0 and then upward. If 1662# there are less values in the list than there are columns the 1663# remaining columns are set to the empty string. If there are 1664# more values in the list than there are columns the superfluous 1665# elements are ignored. The matrix is not extended by this 1666# operation. 1667# 1668# Arguments: 1669# name Name of the matrix. 1670# row Index of the row to set. 1671# values Values to set into the row. 1672# 1673# Results: 1674# None. 1675 1676proc ::struct::matrix::__set_row {name row values} { 1677 set row [ChkRowIndex $name $row] 1678 1679 variable ${name}::data 1680 variable ${name}::columns 1681 variable ${name}::rows 1682 variable ${name}::colw 1683 variable ${name}::rowh 1684 1685 if {[set l [llength $values]] < $columns} { 1686 # Missing values. Fill up with empty strings 1687 1688 for {} {$l < $columns} {incr l} { 1689 lappend values {} 1690 } 1691 } elseif {[llength $values] > $columns} { 1692 # To many values. Remove the superfluous items 1693 set values [lrange $values 0 [expr {$columns - 1}]] 1694 } 1695 1696 # "values" now contains the information to set into the array. 1697 # Regarding the width and height caches: 1698 1699 # - Invalidate the row in the height cache. 1700 # - The columns are either removed from the width cache or left 1701 # unchanged, depending on the contents set into the cell. 1702 1703 set c 0 1704 foreach v $values { 1705 if {$v != {}} { 1706 # Data changed unpredictably, invalidate cache 1707 catch {unset colw($c)} 1708 } ; # {else leave the row unchanged} 1709 set data($c,$row) $v 1710 incr c 1711 } 1712 catch {unset rowh($row)} 1713 return 1714} 1715 1716# ::struct::matrix::__swap_columns -- 1717# 1718# Swaps the contents of the two specified columns. 1719# 1720# Arguments: 1721# name Name of the matrix. 1722# column_a Index of the first column to swap 1723# column_b Index of the second column to swap 1724# 1725# Results: 1726# None. 1727 1728proc ::struct::matrix::__swap_columns {name column_a column_b} { 1729 set column_a [ChkColumnIndex $name $column_a] 1730 set column_b [ChkColumnIndex $name $column_b] 1731 return [SwapColumns $name $column_a $column_b] 1732} 1733 1734proc ::struct::matrix::SwapColumns {name column_a column_b} { 1735 variable ${name}::data 1736 variable ${name}::rows 1737 variable ${name}::colw 1738 1739 # Note: This operation does not influence the height cache for all 1740 # rows and the width cache only insofar as its contents has to be 1741 # swapped too for the two columns we are touching. Note that the 1742 # cache might be partially filled or not at all, so we don't have 1743 # to "swap" in some situations. 1744 1745 for {set r 0} {$r < $rows} {incr r} { 1746 set tmp $data($column_a,$r) 1747 set data($column_a,$r) $data($column_b,$r) 1748 set data($column_b,$r) $tmp 1749 } 1750 1751 set cwa [info exists colw($column_a)] 1752 set cwb [info exists colw($column_b)] 1753 1754 if {$cwa && $cwb} { 1755 set tmp $colw($column_a) 1756 set colw($column_a) $colw($column_b) 1757 set colw($column_b) $tmp 1758 } elseif {$cwa} { 1759 # Move contents, don't swap. 1760 set colw($column_b) $colw($column_a) 1761 unset colw($column_a) 1762 } elseif {$cwb} { 1763 # Move contents, don't swap. 1764 set colw($column_a) $colw($column_b) 1765 unset colw($column_b) 1766 } ; # else {nothing to do at all} 1767 return 1768} 1769 1770# ::struct::matrix::__swap_rows -- 1771# 1772# Swaps the contents of the two specified rows. 1773# 1774# Arguments: 1775# name Name of the matrix. 1776# row_a Index of the first row to swap 1777# row_b Index of the second row to swap 1778# 1779# Results: 1780# None. 1781 1782proc ::struct::matrix::__swap_rows {name row_a row_b} { 1783 set row_a [ChkRowIndex $name $row_a] 1784 set row_b [ChkRowIndex $name $row_b] 1785 return [SwapRows $name $row_a $row_b] 1786} 1787 1788proc ::struct::matrix::SwapRows {name row_a row_b} { 1789 variable ${name}::data 1790 variable ${name}::columns 1791 variable ${name}::rowh 1792 1793 # Note: This operation does not influence the width cache for all 1794 # columns and the height cache only insofar as its contents has to be 1795 # swapped too for the two rows we are touching. Note that the 1796 # cache might be partially filled or not at all, so we don't have 1797 # to "swap" in some situations. 1798 1799 for {set c 0} {$c < $columns} {incr c} { 1800 set tmp $data($c,$row_a) 1801 set data($c,$row_a) $data($c,$row_b) 1802 set data($c,$row_b) $tmp 1803 } 1804 1805 set rha [info exists rowh($row_a)] 1806 set rhb [info exists rowh($row_b)] 1807 1808 if {$rha && $rhb} { 1809 set tmp $rowh($row_a) 1810 set rowh($row_a) $rowh($row_b) 1811 set rowh($row_b) $tmp 1812 } elseif {$rha} { 1813 # Move contents, don't swap. 1814 set rowh($row_b) $rowh($row_a) 1815 unset rowh($row_a) 1816 } elseif {$rhb} { 1817 # Move contents, don't swap. 1818 set rowh($row_a) $rowh($row_b) 1819 unset rowh($row_b) 1820 } ; # else {nothing to do at all} 1821 return 1822} 1823 1824# ::struct::matrix::_unlink -- 1825# 1826# Removes the link between the matrix and the specified 1827# arrayvariable, if there is one. 1828# 1829# Arguments: 1830# name Name of the matrix. 1831# avar Name of the linked array. 1832# 1833# Results: 1834# None. 1835 1836proc ::struct::matrix::_unlink {name avar} { 1837 1838 variable ${name}::link 1839 1840 if {![info exists link($avar)]} { 1841 # Ignore unlinking of unkown variables. 1842 return 1843 } 1844 1845 # Delete the traces first, then remove the link management 1846 # information from the object. 1847 1848 upvar #0 $avar array 1849 variable ${name}::data 1850 1851 trace vdelete array wu [list ::struct::matrix::MatTraceIn $avar $name] 1852 trace vdelete date w [list ::struct::matrix::MatTraceOut $avar $name] 1853 1854 unset link($avar) 1855 return 1856} 1857 1858# ::struct::matrix::ChkColumnIndex -- 1859# 1860# Helper to check and transform column indices. Returns the 1861# absolute index number belonging to the specified 1862# index. Rejects indices out of the valid range of columns. 1863# 1864# Arguments: 1865# matrix Matrix to look at 1866# column The incoming index to check and transform 1867# 1868# Results: 1869# The absolute index to the column 1870 1871proc ::struct::matrix::ChkColumnIndex {name column} { 1872 variable ${name}::columns 1873 1874 switch -regex -- $column { 1875 {end-[0-9]+} { 1876 set column [string map {end- ""} $column] 1877 set cc [expr {$columns - 1 - $column}] 1878 if {($cc < 0) || ($cc >= $columns)} { 1879 return -code error "bad column index end-$column, column does not exist" 1880 } 1881 return $cc 1882 } 1883 end { 1884 if {$columns <= 0} { 1885 return -code error "bad column index $column, column does not exist" 1886 } 1887 return [expr {$columns - 1}] 1888 } 1889 {[0-9]+} { 1890 if {($column < 0) || ($column >= $columns)} { 1891 return -code error "bad column index $column, column does not exist" 1892 } 1893 return $column 1894 } 1895 default { 1896 return -code error "bad column index \"$column\", syntax error" 1897 } 1898 } 1899 # Will not come to this place 1900} 1901 1902# ::struct::matrix::ChkRowIndex -- 1903# 1904# Helper to check and transform row indices. Returns the 1905# absolute index number belonging to the specified 1906# index. Rejects indices out of the valid range of rows. 1907# 1908# Arguments: 1909# matrix Matrix to look at 1910# row The incoming index to check and transform 1911# 1912# Results: 1913# The absolute index to the row 1914 1915proc ::struct::matrix::ChkRowIndex {name row} { 1916 variable ${name}::rows 1917 1918 switch -regex -- $row { 1919 {end-[0-9]+} { 1920 set row [string map {end- ""} $row] 1921 set rr [expr {$rows - 1 - $row}] 1922 if {($rr < 0) || ($rr >= $rows)} { 1923 return -code error "bad row index end-$row, row does not exist" 1924 } 1925 return $rr 1926 } 1927 end { 1928 if {$rows <= 0} { 1929 return -code error "bad row index $row, row does not exist" 1930 } 1931 return [expr {$rows - 1}] 1932 } 1933 {[0-9]+} { 1934 if {($row < 0) || ($row >= $rows)} { 1935 return -code error "bad row index $row, row does not exist" 1936 } 1937 return $row 1938 } 1939 default { 1940 return -code error "bad row index \"$row\", syntax error" 1941 } 1942 } 1943 # Will not come to this place 1944} 1945 1946# ::struct::matrix::ChkColumnIndexNeg -- 1947# 1948# Helper to check and transform column indices. Returns the 1949# absolute index number belonging to the specified 1950# index. Rejects indices out of the valid range of columns 1951# (Accepts negative indices). 1952# 1953# Arguments: 1954# matrix Matrix to look at 1955# column The incoming index to check and transform 1956# 1957# Results: 1958# The absolute index to the column 1959 1960proc ::struct::matrix::ChkColumnIndexNeg {name column} { 1961 variable ${name}::columns 1962 1963 switch -regex -- $column { 1964 {end-[0-9]+} { 1965 set column [string map {end- ""} $column] 1966 set cc [expr {$columns - 1 - $column}] 1967 if {$cc >= $columns} { 1968 return -code error "bad column index end-$column, column does not exist" 1969 } 1970 return $cc 1971 } 1972 end { 1973 return [expr {$columns - 1}] 1974 } 1975 {[0-9]+} { 1976 if {$column >= $columns} { 1977 return -code error "bad column index $column, column does not exist" 1978 } 1979 return $column 1980 } 1981 default { 1982 return -code error "bad column index \"$column\", syntax error" 1983 } 1984 } 1985 # Will not come to this place 1986} 1987 1988# ::struct::matrix::ChkRowIndexNeg -- 1989# 1990# Helper to check and transform row indices. Returns the 1991# absolute index number belonging to the specified 1992# index. Rejects indices out of the valid range of rows 1993# (Accepts negative indices). 1994# 1995# Arguments: 1996# matrix Matrix to look at 1997# row The incoming index to check and transform 1998# 1999# Results: 2000# The absolute index to the row 2001 2002proc ::struct::matrix::ChkRowIndexNeg {name row} { 2003 variable ${name}::rows 2004 2005 switch -regex -- $row { 2006 {end-[0-9]+} { 2007 set row [string map {end- ""} $row] 2008 set rr [expr {$rows - 1 - $row}] 2009 if {$rr >= $rows} { 2010 return -code error "bad row index end-$row, row does not exist" 2011 } 2012 return $rr 2013 } 2014 end { 2015 return [expr {$rows - 1}] 2016 } 2017 {[0-9]+} { 2018 if {$row >= $rows} { 2019 return -code error "bad row index $row, row does not exist" 2020 } 2021 return $row 2022 } 2023 default { 2024 return -code error "bad row index \"$row\", syntax error" 2025 } 2026 } 2027 # Will not come to this place 2028} 2029 2030# ::struct::matrix::ChkColumnIndexAll -- 2031# 2032# Helper to transform column indices. Returns the 2033# absolute index number belonging to the specified 2034# index. 2035# 2036# Arguments: 2037# matrix Matrix to look at 2038# column The incoming index to check and transform 2039# 2040# Results: 2041# The absolute index to the column 2042 2043proc ::struct::matrix::ChkColumnIndexAll {name column} { 2044 variable ${name}::columns 2045 2046 switch -regex -- $column { 2047 {end-[0-9]+} { 2048 set column [string map {end- ""} $column] 2049 set cc [expr {$columns - 1 - $column}] 2050 return $cc 2051 } 2052 end { 2053 return $columns 2054 } 2055 {[0-9]+} { 2056 return $column 2057 } 2058 default { 2059 return -code error "bad column index \"$column\", syntax error" 2060 } 2061 } 2062 # Will not come to this place 2063} 2064 2065# ::struct::matrix::ChkRowIndexAll -- 2066# 2067# Helper to transform row indices. Returns the 2068# absolute index number belonging to the specified 2069# index. 2070# 2071# Arguments: 2072# matrix Matrix to look at 2073# row The incoming index to check and transform 2074# 2075# Results: 2076# The absolute index to the row 2077 2078proc ::struct::matrix::ChkRowIndexAll {name row} { 2079 variable ${name}::rows 2080 2081 switch -regex -- $row { 2082 {end-[0-9]+} { 2083 set row [string map {end- ""} $row] 2084 set rr [expr {$rows - 1 - $row}] 2085 return $rr 2086 } 2087 end { 2088 return $rows 2089 } 2090 {[0-9]+} { 2091 return $row 2092 } 2093 default { 2094 return -code error "bad row index \"$row\", syntax error" 2095 } 2096 } 2097 # Will not come to this place 2098} 2099 2100# ::struct::matrix::MatTraceIn -- 2101# 2102# Helper propagating changes made to an array 2103# into the matrix the array is linked to. 2104# 2105# Arguments: 2106# avar Name of the array which was changed. 2107# name Matrix to write the changes to. 2108# var,idx,op Standard trace arguments 2109# 2110# Results: 2111# None. 2112 2113proc ::struct::matrix::MatTraceIn {avar name var idx op} { 2114 # Propagate changes in the linked array back into the matrix. 2115 2116 variable ${name}::lock 2117 if {$lock} {return} 2118 2119 # We have to cover two possibilities when encountering an "unset" operation ... 2120 # 1. The external array was destroyed: perform automatic unlink. 2121 # 2. An individual element was unset: Set the corresponding cell to the empty string. 2122 # See SF Tcllib Bug #532791. 2123 2124 if {(![string compare $op u]) && ($idx == {})} { 2125 # Possibility 1: Array was destroyed 2126 $name unlink $avar 2127 return 2128 } 2129 2130 upvar #0 $avar array 2131 variable ${name}::data 2132 variable ${name}::link 2133 2134 set transpose $link($avar) 2135 if {$transpose} { 2136 foreach {r c} [split $idx ,] break 2137 } else { 2138 foreach {c r} [split $idx ,] break 2139 } 2140 2141 # Use standard method to propagate the change. 2142 # => Get automatically index checks, cache updates, ... 2143 2144 if {![string compare $op u]} { 2145 # Unset possibility 2: Element was unset. 2146 # Note: Setting the cell to the empty string will 2147 # invoke MatTraceOut for this array and thus try 2148 # to recreate the destroyed element of the array. 2149 # We don't want this. But we do want to propagate 2150 # the change to other arrays, as "unset". To do 2151 # all of this we use another state variable to 2152 # signal this situation. 2153 2154 variable ${name}::unset 2155 set unset $avar 2156 2157 $name set cell $c $r "" 2158 2159 set unset {} 2160 return 2161 } 2162 2163 $name set cell $c $r $array($idx) 2164 return 2165} 2166 2167# ::struct::matrix::MatTraceOut -- 2168# 2169# Helper propagating changes made to the matrix into the linked arrays. 2170# 2171# Arguments: 2172# avar Name of the array to write the changes to. 2173# name Matrix which was changed. 2174# var,idx,op Standard trace arguments 2175# 2176# Results: 2177# None. 2178 2179proc ::struct::matrix::MatTraceOut {avar name var idx op} { 2180 # Propagate changes in the matrix data array into the linked array. 2181 2182 variable ${name}::unset 2183 2184 if {![string compare $avar $unset]} { 2185 # Do not change the variable currently unsetting 2186 # one of its elements. 2187 return 2188 } 2189 2190 variable ${name}::lock 2191 set lock 1 ; # Disable MatTraceIn [#532783] 2192 2193 upvar #0 $avar array 2194 variable ${name}::data 2195 variable ${name}::link 2196 2197 set transpose $link($avar) 2198 2199 if {$transpose} { 2200 foreach {r c} [split $idx ,] break 2201 } else { 2202 foreach {c r} [split $idx ,] break 2203 } 2204 2205 if {$unset != {}} { 2206 # We are currently propagating the unset of an 2207 # element in a different linked array to this 2208 # array. We make sure that this is an unset too. 2209 2210 unset array($c,$r) 2211 } else { 2212 set array($c,$r) $data($idx) 2213 } 2214 set lock 0 2215 return 2216} 2217 2218# ::struct::matrix::SortMaxHeapify -- 2219# 2220# Helper for the 'sort' method. Performs the central algorithm 2221# which converts the matrix into a heap, easily sortable. 2222# 2223# Arguments: 2224# name Matrix object which is sorted. 2225# i Index of the row/column currently being sorted. 2226# key Index of the column/row to sort the rows/columns by. 2227# rowCol Indicator if we are sorting rows ('r'), or columns ('c'). 2228# heapSize Number of rows/columns to sort. 2229# rev Boolean flag, set if sorting is done revers (-decreasing). 2230# 2231# Sideeffects: 2232# Transforms the matrix into a heap of rows/columns, 2233# swapping them around. 2234# 2235# Results: 2236# None. 2237 2238proc ::struct::matrix::SortMaxHeapify {name i key rowCol heapSize {rev 0}} { 2239 # MAX-HEAPIFY, adapted by EAS from CLRS 6.2 2240 switch $rowCol { 2241 r { set A [GetColumn $name $key] } 2242 c { set A [GetRow $name $key] } 2243 } 2244 # Weird expressions below for clarity, as CLRS uses A[1...n] 2245 # format and TCL uses A[0...n-1] 2246 set left [expr {int(2*($i+1) -1)}] 2247 set right [expr {int(2*($i+1)+1 -1)}] 2248 2249 # left, right are tested as < rather than <= because they are 2250 # in A[0...n-1] 2251 if { 2252 $left < $heapSize && 2253 ( !$rev && [lindex $A $left] > [lindex $A $i] || 2254 $rev && [lindex $A $left] < [lindex $A $i] ) 2255 } { 2256 set largest $left 2257 } else { 2258 set largest $i 2259 } 2260 2261 if { 2262 $right < $heapSize && 2263 ( !$rev && [lindex $A $right] > [lindex $A $largest] || 2264 $rev && [lindex $A $right] < [lindex $A $largest] ) 2265 } { 2266 set largest $right 2267 } 2268 2269 if { $largest != $i } { 2270 switch $rowCol { 2271 r { SwapRows $name $i $largest } 2272 c { SwapColumns $name $i $largest } 2273 } 2274 SortMaxHeapify $name $largest $key $rowCol $heapSize $rev 2275 } 2276 return 2277} 2278 2279# ### ### ### ######### ######### ######### 2280## Ready 2281 2282namespace eval ::struct { 2283 # Get 'matrix::matrix' into the general structure namespace. 2284 namespace import -force matrix::matrix 2285 namespace export matrix 2286} 2287package provide struct::matrix 1.2.1 2288