source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/struct/matrix.tcl @ 8597867d

1941-docker-image-to-testdevel
Last change on this file since 8597867d was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@2556 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 71.2 KB
Line 
1# matrix.tcl --
2#
3#       Implementation of a matrix data structure for Tcl.
4#
5# Copyright (c) 2001-2004 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: matrix.tcl,v 1.22 2005/09/30 05:36:39 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    #   row heights and column widths 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 column widths
34    # - rowh    cache of row heights
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 {args} {
58    variable counter
59   
60    set src     {}
61    set srctype {}
62
63    switch -exact -- [llength [info level 0]] {
64        1 {
65            # Missing name, generate one.
66            incr counter
67            set name "matrix${counter}"
68        }
69        2 {
70            # Standard call. New empty matrix.
71            set name [lindex $args 0]
72        }
73        4 {
74            # Copy construction.
75            foreach {name as src} $args break
76            switch -exact -- $as {
77                = - := - as {
78                    set srctype matrix
79                }
80                deserialize {
81                    set srctype serial
82                }
83                default {
84                    return -code error \
85                            "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\""
86                }
87            }
88        }
89        default {
90            # Error.
91            return -code error \
92                    "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\""
93        }
94    }
95
96    # FIRST, qualify the name.
97    if {![string match "::*" $name]} {
98        # Get caller's namespace; append :: if not global namespace.
99        set ns [uplevel 1 [list namespace current]]
100        if {"::" != $ns} {
101            append ns "::"
102        }
103        set name "$ns$name"
104    }
105
106    if { [llength [info commands $name]] } {
107        return -code error "command \"$name\" already exists, unable to create matrix"
108    }
109
110    # Set up the namespace
111    namespace eval $name {
112        variable columns 0
113        variable rows    0
114
115        variable data
116        variable colw
117        variable rowh
118        variable link
119        variable lock
120        variable unset
121
122        array set data  {}
123        array set colw  {}
124        array set rowh  {}
125        array set link  {}
126        set       lock  0
127        set       unset {}
128    }
129
130    # Create the command to manipulate the matrix
131    interp alias {} $name {} ::struct::matrix::MatrixProc $name
132
133    # Automatic execution of assignment if a source
134    # is present.
135    if {$src != {}} {
136        switch -exact -- $srctype {
137            matrix {_= $name $src}
138            serial {_deserialize $name $src}
139            default {
140                return -code error \
141                        "Internal error, illegal srctype \"$srctype\""
142            }
143        }
144    }
145    return $name
146}
147
148##########################
149# Private functions follow
150
151# ::struct::matrix::MatrixProc --
152#
153#       Command that processes all matrix object commands.
154#
155# Arguments:
156#       name    Name of the matrix object to manipulate.
157#       cmd     Subcommand to invoke.
158#       args    Arguments for subcommand.
159#
160# Results:
161#       Varies based on command to perform
162
163proc ::struct::matrix::MatrixProc {name {cmd ""} args} {
164    # Do minimal args checks here
165    if { [llength [info level 0]] == 2 } {
166        return -code error "wrong # args: should be \"$name option ?arg arg ...?\""
167    }
168   
169    # Split the args into command and args components
170    set sub _$cmd
171    if {[llength [info commands ::struct::matrix::$sub]] == 0} {
172        set optlist [lsort [info commands ::struct::matrix::_*]]
173        set xlist {}
174        foreach p $optlist {
175            set p [namespace tail $p]
176            if {[string match __* $p]} {continue}
177            lappend xlist [string range $p 1 end]
178        }
179        set optlist [linsert [join $xlist ", "] "end-1" "or"]
180        return -code error \
181                "bad option \"$cmd\": must be $optlist"
182    }
183    uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name]
184}
185
186# ::struct::matrix::_= --
187#
188#       Assignment operator. Copies the source matrix into the
189#       destination, destroying the original information.
190#
191# Arguments:
192#       name    Name of the matrix object we are copying into.
193#       source  Name of the matrix object providing us with the
194#               data to copy.
195#
196# Results:
197#       Nothing.
198
199proc ::struct::matrix::_= {name source} {
200    _deserialize $name [$source serialize]
201    return
202}
203
204# ::struct::matrix::_--> --
205#
206#       Reverse assignment operator. Copies this matrix into the
207#       destination, destroying the original information.
208#
209# Arguments:
210#       name    Name of the matrix object to copy
211#       dest    Name of the matrix object we are copying to.
212#
213# Results:
214#       Nothing.
215
216proc ::struct::matrix::_--> {name dest} {
217    $dest deserialize [_serialize $name]
218    return
219}
220
221# ::struct::matrix::_add --
222#
223#       Command that processes all 'add' subcommands.
224#
225# Arguments:
226#       name    Name of the matrix object to manipulate.
227#       cmd     Subcommand of 'add' to invoke.
228#       args    Arguments for subcommand of 'add'.
229#
230# Results:
231#       Varies based on command to perform
232
233proc ::struct::matrix::_add {name {cmd ""} args} {
234    # Do minimal args checks here
235    if { [llength [info level 0]] == 2 } {
236        return -code error "wrong # args: should be \"$name add option ?arg arg ...?\""
237    }
238   
239    # Split the args into command and args components
240    set sub __add_$cmd
241    if { [llength [info commands ::struct::matrix::$sub]] == 0 } {
242        set optlist [lsort [info commands ::struct::matrix::__add_*]]
243        set xlist {}
244        foreach p $optlist {
245            set p [namespace tail $p]
246            lappend xlist [string range $p 6 end]
247        }
248        set optlist [linsert [join $xlist ", "] "end-1" "or"]
249        return -code error \
250                "bad option \"$cmd\": must be $optlist"
251    }
252    uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name]
253}
254
255# ::struct::matrix::_delete --
256#
257#       Command that processes all 'delete' subcommands.
258#
259# Arguments:
260#       name    Name of the matrix object to manipulate.
261#       cmd     Subcommand of 'delete' to invoke.
262#       args    Arguments for subcommand of 'delete'.
263#
264# Results:
265#       Varies based on command to perform
266
267proc ::struct::matrix::_delete {name {cmd ""} args} {
268    # Do minimal args checks here
269    if { [llength [info level 0]] == 2 } {
270        return -code error "wrong # args: should be \"$name delete option ?arg arg ...?\""
271    }
272   
273    # Split the args into command and args components
274    set sub __delete_$cmd
275    if { [llength [info commands ::struct::matrix::$sub]] == 0 } {
276        set optlist [lsort [info commands ::struct::matrix::__delete_*]]
277        set xlist {}
278        foreach p $optlist {
279            set p [namespace tail $p]
280            lappend xlist [string range $p 9 end]
281        }
282        set optlist [linsert [join $xlist ", "] "end-1" "or"]
283        return -code error \
284                "bad option \"$cmd\": must be $optlist"
285    }
286    uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name]
287}
288
289# ::struct::matrix::_format --
290#
291#       Command that processes all 'format' subcommands.
292#
293# Arguments:
294#       name    Name of the matrix object to manipulate.
295#       cmd     Subcommand of 'format' to invoke.
296#       args    Arguments for subcommand of 'format'.
297#
298# Results:
299#       Varies based on command to perform
300
301proc ::struct::matrix::_format {name {cmd ""} args} {
302    # Do minimal args checks here
303    if { [llength [info level 0]] == 2 } {
304        return -code error "wrong # args: should be \"$name format option ?arg arg ...?\""
305    }
306   
307    # Split the args into command and args components
308    set sub __format_$cmd
309    if { [llength [info commands ::struct::matrix::$sub]] == 0 } {
310        set optlist [lsort [info commands ::struct::matrix::__format_*]]
311        set xlist {}
312        foreach p $optlist {
313            set p [namespace tail $p]
314            lappend xlist [string range $p 9 end]
315        }
316        set optlist [linsert [join $xlist ", "] "end-1" "or"]
317        return -code error \
318                "bad option \"$cmd\": must be $optlist"
319    }
320    uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name]
321}
322
323# ::struct::matrix::_get --
324#
325#       Command that processes all 'get' subcommands.
326#
327# Arguments:
328#       name    Name of the matrix object to manipulate.
329#       cmd     Subcommand of 'get' to invoke.
330#       args    Arguments for subcommand of 'get'.
331#
332# Results:
333#       Varies based on command to perform
334
335proc ::struct::matrix::_get {name {cmd ""} args} {
336    # Do minimal args checks here
337    if { [llength [info level 0]] == 2 } {
338        return -code error "wrong # args: should be \"$name get option ?arg arg ...?\""
339    }
340   
341    # Split the args into command and args components
342    set sub __get_$cmd
343    if { [llength [info commands ::struct::matrix::$sub]] == 0 } {
344        set optlist [lsort [info commands ::struct::matrix::__get_*]]
345        set xlist {}
346        foreach p $optlist {
347            set p [namespace tail $p]
348            lappend xlist [string range $p 6 end]
349        }
350        set optlist [linsert [join $xlist ", "] "end-1" "or"]
351        return -code error \
352                "bad option \"$cmd\": must be $optlist"
353    }
354    uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name]
355}
356
357# ::struct::matrix::_insert --
358#
359#       Command that processes all 'insert' subcommands.
360#
361# Arguments:
362#       name    Name of the matrix object to manipulate.
363#       cmd     Subcommand of 'insert' to invoke.
364#       args    Arguments for subcommand of 'insert'.
365#
366# Results:
367#       Varies based on command to perform
368
369proc ::struct::matrix::_insert {name {cmd ""} args} {
370    # Do minimal args checks here
371    if { [llength [info level 0]] == 2 } {
372        return -code error "wrong # args: should be \"$name insert option ?arg arg ...?\""
373    }
374   
375    # Split the args into command and args components
376    set sub __insert_$cmd
377    if { [llength [info commands ::struct::matrix::$sub]] == 0 } {
378        set optlist [lsort [info commands ::struct::matrix::__insert_*]]
379        set xlist {}
380        foreach p $optlist {
381            set p [namespace tail $p]
382            lappend xlist [string range $p 9 end]
383        }
384        set optlist [linsert [join $xlist ", "] "end-1" "or"]
385        return -code error \
386                "bad option \"$cmd\": must be $optlist"
387    }
388    uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name]
389}
390
391# ::struct::matrix::_search --
392#
393#       Command that processes all 'search' subcommands.
394#
395# Arguments:
396#       name    Name of the matrix object to manipulate.
397#       args    Arguments for search.
398#
399# Results:
400#       Varies based on command to perform
401
402proc ::struct::matrix::_search {name args} {
403    set mode   exact
404    set nocase 0
405
406    while {1} {
407        switch -glob -- [lindex $args 0] {
408            -exact - -glob - -regexp {
409                set mode [string range [lindex $args 0] 1 end]
410                set args [lrange $args 1 end]
411            }
412            -nocase {
413                set nocase 1
414                set args [lrange $args 1 end]
415            }
416            -* {
417                return -code error \
418                        "invalid option \"[lindex $args 0]\":\
419                        should be -nocase, -exact, -glob, or -regexp"
420            }
421            default {
422                break
423            }
424        }
425    }
426
427    # Possible argument signatures after option processing
428    #
429    # \ | args
430    # --+--------------------------------------------------------
431    # 2 | all pattern
432    # 3 | row row pattern, column col pattern
433    # 6 | rect ctl rtl cbr rbr pattern
434    #
435    # All range specifications are internally converted into a
436    # rectangle.
437
438    switch -exact -- [llength $args] {
439        2 - 3 - 6 {}
440        default {
441            return -code error \
442                "wrong # args: should be\
443                \"$name search ?option...? (all|row row|column col|rect c r c r) pattern\""
444        }
445    }
446
447    set range   [lindex $args 0]
448    set pattern [lindex $args end]
449    set args    [lrange $args 1 end-1]
450
451    variable ${name}::data
452    variable ${name}::columns
453    variable ${name}::rows
454
455    switch -exact -- $range {
456        all {
457            set ctl 0 ; set cbr $columns ; incr cbr -1
458            set rtl 0 ; set rbr $rows    ; incr rbr -1
459        }
460        column {
461            set ctl [ChkColumnIndex $name [lindex $args 0]]
462            set cbr $ctl
463            set rtl 0       ; set rbr $rows ; incr rbr -1
464        }
465        row {
466            set rtl [ChkRowIndex $name [lindex $args 0]]
467            set ctl 0    ; set cbr $columns ; incr cbr -1
468            set rbr $rtl
469        }
470        rect {
471            foreach {ctl rtl cbr rbr} $args break
472            set ctl [ChkColumnIndex $name $ctl]
473            set rtl [ChkRowIndex    $name $rtl]
474            set cbr [ChkColumnIndex $name $cbr]
475            set rbr [ChkRowIndex    $name $rbr]
476            if {($ctl > $cbr) || ($rtl > $rbr)} {
477                return -code error "Invalid cell indices, wrong ordering"
478            }
479        }
480        default {
481            return -code error "invalid range spec \"$range\": should be all, column, row, or rect"
482        }
483    }
484
485    if {$nocase} {
486        set pattern [string tolower $pattern]
487    }
488
489    set matches [list]
490    for {set r $rtl} {$r <= $rbr} {incr r} {
491        for {set c $ctl} {$c <= $cbr} {incr c} {
492            set v  $data($c,$r)
493            if {$nocase} {
494                set v [string tolower $v]
495            }
496            switch -exact -- $mode {
497                exact  {set matched [string equal $pattern $v]}
498                glob   {set matched [string match $pattern $v]}
499                regexp {set matched [regexp --    $pattern $v]}
500            }
501            if {$matched} {
502                lappend matches [list $c $r]
503            }
504        }
505    }
506    return $matches
507}
508
509# ::struct::matrix::_set --
510#
511#       Command that processes all 'set' subcommands.
512#
513# Arguments:
514#       name    Name of the matrix object to manipulate.
515#       cmd     Subcommand of 'set' to invoke.
516#       args    Arguments for subcommand of 'set'.
517#
518# Results:
519#       Varies based on command to perform
520
521proc ::struct::matrix::_set {name {cmd ""} args} {
522    # Do minimal args checks here
523    if { [llength [info level 0]] == 2 } {
524        return -code error "wrong # args: should be \"$name set option ?arg arg ...?\""
525    }
526   
527    # Split the args into command and args components
528    set sub __set_$cmd
529    if { [llength [info commands ::struct::matrix::$sub]] == 0 } {
530        set optlist [lsort [info commands ::struct::matrix::__set_*]]
531        set xlist {}
532        foreach p $optlist {
533            set p [namespace tail $p]
534            lappend xlist [string range $p 6 end]
535        }
536        set optlist [linsert [join $xlist ", "] "end-1" "or"]
537        return -code error \
538                "bad option \"$cmd\": must be $optlist"
539    }
540    uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name]
541}
542
543# ::struct::matrix::_sort --
544#
545#       Command that processes all 'sort' subcommands.
546#
547# Arguments:
548#       name    Name of the matrix object to manipulate.
549#       cmd     Subcommand of 'sort' to invoke.
550#       args    Arguments for subcommand of 'sort'.
551#
552# Results:
553#       Varies based on command to perform
554
555proc ::struct::matrix::_sort {name cmd args} {
556    # Do minimal args checks here
557    if { [llength [info level 0]] == 2 } {
558        return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\""
559    }
560    if {[string equal $cmd "rows"]} {
561        set code   r
562        set byrows 1
563    } elseif {[string equal $cmd "columns"]} {
564        set code   c
565        set byrows 0
566    } else {
567        return -code error \
568                "bad option \"$cmd\": must be columns, or rows"
569    }
570
571    set revers 0 ;# Default: -increasing
572    while {1} {
573        switch -glob -- [lindex $args 0] {
574            -increasing {set revers 0}
575            -decreasing {set revers 1}
576            default {
577                if {[llength $args] > 1} {
578                    return -code error \
579                        "invalid option \"[lindex $args 0]\":\
580                        should be -increasing, or -decreasing"
581                }
582                break
583            }
584        }
585        set args [lrange $args 1 end]
586    }
587    # ASSERT: [llength $args] == 1
588
589    if {[llength $args] != 1} {
590        return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\""
591    }
592
593    set key [lindex $args 0]
594
595    if {$byrows} {
596        set key [ChkColumnIndex $name $key]
597        variable ${name}::rows
598
599        # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3
600        set heapSize $rows
601    } else {
602        set key [ChkRowIndex $name $key]
603        variable ${name}::columns
604
605        # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3
606        set heapSize $columns
607    }
608
609    for {set i [expr {int($heapSize/2)-1}]} {$i>=0} {incr i -1} {
610        SortMaxHeapify $name $i $key $code $heapSize $revers
611    }
612
613    # Adapted by EAS from remainder of HEAPSORT(A) of CRLS 6.4
614    for {set i [expr {$heapSize-1}]} {$i>=1} {incr i -1} {
615        if {$byrows} {
616            SwapRows $name 0 $i
617        } else {
618            SwapColumns $name 0 $i
619        }
620        incr heapSize -1
621        SortMaxHeapify $name 0 $key $code $heapSize $revers
622    }
623    return
624}
625
626# ::struct::matrix::_swap --
627#
628#       Command that processes all 'swap' subcommands.
629#
630# Arguments:
631#       name    Name of the matrix object to manipulate.
632#       cmd     Subcommand of 'swap' to invoke.
633#       args    Arguments for subcommand of 'swap'.
634#
635# Results:
636#       Varies based on command to perform
637
638proc ::struct::matrix::_swap {name {cmd ""} args} {
639    # Do minimal args checks here
640    if { [llength [info level 0]] == 2 } {
641        return -code error "wrong # args: should be \"$name swap option ?arg arg ...?\""
642    }
643   
644    # Split the args into command and args components
645    set sub __swap_$cmd
646    if { [llength [info commands ::struct::matrix::$sub]] == 0 } {
647        set optlist [lsort [info commands ::struct::matrix::__swap_*]]
648        set xlist {}
649        foreach p $optlist {
650            set p [namespace tail $p]
651            lappend xlist [string range $p 7 end]
652        }
653        set optlist [linsert [join $xlist ", "] "end-1" "or"]
654        return -code error \
655                "bad option \"$cmd\": must be $optlist"
656    }
657    uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name]
658}
659
660# ::struct::matrix::__add_column --
661#
662#       Extends the matrix by one column and then acts like
663#       "setcolumn" (see below) on this new column if there were
664#       "values" supplied. Without "values" the new cells will be set
665#       to the empty string. The new column is appended immediately
666#       behind the last existing column.
667#
668# Arguments:
669#       name    Name of the matrix object.
670#       values  Optional values to set into the new row.
671#
672# Results:
673#       None.
674
675proc ::struct::matrix::__add_column {name {values {}}} {
676    variable ${name}::data
677    variable ${name}::columns
678    variable ${name}::rows
679    variable ${name}::rowh
680
681    if {[set l [llength $values]] < $rows} {
682        # Missing values. Fill up with empty strings
683
684        for {} {$l < $rows} {incr l} {
685            lappend values {}
686        }
687    } elseif {[llength $values] > $rows} {
688        # To many values. Remove the superfluous items
689        set values [lrange $values 0 [expr {$rows - 1}]]
690    }
691
692    # "values" now contains the information to set into the array.
693    # Regarding the width and height caches:
694
695    # - The new column is not added to the width cache, the other
696    #   columns are not touched, the cache therefore unchanged.
697    # - The rows are either removed from the height cache or left
698    #   unchanged, depending on the contents set into the cell.
699
700    set r 0
701    foreach v $values {
702        if {$v != {}} {
703            # Data changed unpredictably, invalidate cache
704            catch {unset rowh($r)}
705        } ; # {else leave the row unchanged}
706        set data($columns,$r) $v
707        incr r
708    }
709    incr columns
710    return
711}
712
713# ::struct::matrix::__add_row --
714#
715#       Extends the matrix by one row and then acts like "setrow" (see
716#       below) on this new row if there were "values"
717#       supplied. Without "values" the new cells will be set to the
718#       empty string. The new row is appended immediately behind the
719#       last existing row.
720#
721# Arguments:
722#       name    Name of the matrix object.
723#       values  Optional values to set into the new row.
724#
725# Results:
726#       None.
727
728proc ::struct::matrix::__add_row {name {values {}}} {
729    variable ${name}::data
730    variable ${name}::columns
731    variable ${name}::rows
732    variable ${name}::colw
733
734    if {[set l [llength $values]] < $columns} {
735        # Missing values. Fill up with empty strings
736
737        for {} {$l < $columns} {incr l} {
738            lappend values {}
739        }
740    } elseif {[llength $values] > $columns} {
741        # To many values. Remove the superfluous items
742        set values [lrange $values 0 [expr {$columns - 1}]]
743    }
744
745    # "values" now contains the information to set into the array.
746    # Regarding the width and height caches:
747
748    # - The new row is not added to the height cache, the other
749    #   rows are not touched, the cache therefore unchanged.
750    # - The columns are either removed from the width cache or left
751    #   unchanged, depending on the contents set into the cell.
752
753    set c 0
754    foreach v $values {
755        if {$v != {}} {
756            # Data changed unpredictably, invalidate cache
757            catch {unset colw($c)}
758        } ; # {else leave the row unchanged}
759        set data($c,$rows) $v
760        incr c
761    }
762    incr rows
763    return
764}
765
766# ::struct::matrix::__add_columns --
767#
768#       Extends the matrix by "n" columns. The new cells will be set
769#       to the empty string. The new columns are appended immediately
770#       behind the last existing column. A value of "n" equal to or
771#       smaller than 0 is not allowed.
772#
773# Arguments:
774#       name    Name of the matrix object.
775#       n       The number of new columns to create.
776#
777# Results:
778#       None.
779
780proc ::struct::matrix::__add_columns {name n} {
781    if {$n <= 0} {
782        return -code error "A value of n <= 0 is not allowed"
783    }
784    AddColumns $name $n
785    return
786}
787
788proc ::struct::matrix::AddColumns {name n} {
789    variable ${name}::data
790    variable ${name}::columns
791    variable ${name}::rows
792
793    # The new values set into the cell is always the empty
794    # string. These have a length and height of 0, i.e. the don't
795    # influence cached widths and heights as they are at least that
796    # big. IOW there is no need to touch and change the width and
797    # height caches.
798
799    while {$n > 0} {
800        for {set r 0} {$r < $rows} {incr r} {
801            set data($columns,$r) ""
802        }
803        incr columns
804        incr n -1
805    }
806
807    return
808}
809
810# ::struct::matrix::__add_rows --
811#
812#       Extends the matrix by "n" rows. The new cells will be set to
813#       the empty string. The new rows are appended immediately behind
814#       the last existing row. A value of "n" equal to or smaller than
815#       0 is not allowed.
816#
817# Arguments:
818#       name    Name of the matrix object.
819#       n       The number of new rows to create.
820#
821# Results:
822#       None.
823
824proc ::struct::matrix::__add_rows {name n} {
825    if {$n <= 0} {
826        return -code error "A value of n <= 0 is not allowed"
827    }
828    AddRows $name $n
829    return
830}
831
832proc ::struct::matrix::AddRows {name n} {
833    variable ${name}::data
834    variable ${name}::columns
835    variable ${name}::rows
836
837    # The new values set into the cell is always the empty
838    # string. These have a length and height of 0, i.e. the don't
839    # influence cached widths and heights as they are at least that
840    # big. IOW there is no need to touch and change the width and
841    # height caches.
842
843    while {$n > 0} {
844        for {set c 0} {$c < $columns} {incr c} {
845            set data($c,$rows) ""
846        }
847        incr rows
848        incr n -1
849    }
850    return
851}
852
853# ::struct::matrix::_cells --
854#
855#       Returns the number of cells currently managed by the
856#       matrix. This is the product of "rows" and "columns".
857#
858# Arguments:
859#       name    Name of the matrix object.
860#
861# Results:
862#       The number of cells in the matrix.
863
864proc ::struct::matrix::_cells {name} {
865    variable ${name}::rows
866    variable ${name}::columns
867    return [expr {$rows * $columns}]
868}
869
870# ::struct::matrix::_cellsize --
871#
872#       Returns the length of the string representation of the value
873#       currently contained in the addressed cell.
874#
875# Arguments:
876#       name    Name of the matrix object.
877#       column  Column index of the cell to query
878#       row     Row index of the cell to query
879#
880# Results:
881#       The number of cells in the matrix.
882
883proc ::struct::matrix::_cellsize {name column row} {
884    set column [ChkColumnIndex $name $column]
885    set row    [ChkRowIndex    $name $row]
886
887    variable ${name}::data
888    return [string length $data($column,$row)]
889}
890
891# ::struct::matrix::_columns --
892#
893#       Returns the number of columns currently managed by the
894#       matrix.
895#
896# Arguments:
897#       name    Name of the matrix object.
898#
899# Results:
900#       The number of columns in the matrix.
901
902proc ::struct::matrix::_columns {name} {
903    variable ${name}::columns
904    return $columns
905}
906
907# ::struct::matrix::_columnwidth --
908#
909#       Returns the length of the longest string representation of all
910#       the values currently contained in the cells of the addressed
911#       column if these are all spanning only one line. For cell
912#       values spanning multiple lines the length of their longest
913#       line goes into the computation.
914#
915# Arguments:
916#       name    Name of the matrix object.
917#       column  The index of the column whose width is asked for.
918#
919# Results:
920#       See description.
921
922proc ::struct::matrix::_columnwidth {name column} {
923    set column [ChkColumnIndex $name $column]
924
925    variable ${name}::colw
926
927    if {![info exists colw($column)]} {
928        variable ${name}::rows
929        variable ${name}::data
930
931        set width 0
932        for {set r 0} {$r < $rows} {incr r} {
933            foreach line [split $data($column,$r) \n] {
934                set len [string length $line]
935                if {$len > $width} {
936                    set width $len
937                }
938            }
939        }
940
941        set colw($column) $width
942    }
943
944    return $colw($column)
945}
946
947# ::struct::matrix::__delete_column --
948#
949#       Deletes the specified column from the matrix and shifts all
950#       columns with higher indices one index down.
951#
952# Arguments:
953#       name    Name of the matrix.
954#       column  The index of the column to delete.
955#
956# Results:
957#       None.
958
959proc ::struct::matrix::__delete_column {name column} {
960    set column [ChkColumnIndex $name $column]
961
962    variable ${name}::data
963    variable ${name}::rows
964    variable ${name}::columns
965    variable ${name}::colw
966    variable ${name}::rowh
967
968    # Move all data from the higher columns down and then delete the
969    # superfluous data in the old last column. Move the data in the
970    # width cache too, take partial fill into account there too.
971    # Invalidate the height cache for all rows.
972
973    for {set r 0} {$r < $rows} {incr r} {
974        for {set c $column; set cn [expr {$c + 1}]} {$cn < $columns} {incr c ; incr cn} {
975            set data($c,$r) $data($cn,$r)
976            if {[info exists colw($cn)]} {
977                set colw($c) $colw($cn)
978                unset colw($cn)
979            }
980        }
981        unset data($c,$r)
982        catch {unset rowh($r)}
983    }
984    incr columns -1
985    return
986}
987
988# ::struct::matrix::__delete_columns --
989#
990#       Shrink the matrix by "n" columns (from the right).
991#       A value of "n" equal to or smaller than 0 is not
992#       allowed, nor is "n" allowed to be greater than the
993#       number of columns in the matrix.
994#
995# Arguments:
996#       name    Name of the matrix object.
997#       n       The number of columns to remove.
998#
999# Results:
1000#       None.
1001
1002proc ::struct::matrix::__delete_columns {name n} {
1003    if {$n <= 0} {
1004        return -code error "A value of n <= 0 is not allowed"
1005    }
1006
1007    variable ${name}::columns
1008
1009    if {$n > $columns} {
1010        return -code error "A value of n > #columns is not allowed"
1011    }
1012
1013    DeleteColumns $name $n
1014    return
1015}
1016
1017# ::struct::matrix::__delete_row --
1018#
1019#       Deletes the specified row from the matrix and shifts all
1020#       row with higher indices one index down.
1021#
1022# Arguments:
1023#       name    Name of the matrix.
1024#       row     The index of the row to delete.
1025#
1026# Results:
1027#       None.
1028
1029proc ::struct::matrix::__delete_row {name row} {
1030    set row [ChkRowIndex $name $row]
1031
1032    variable ${name}::data
1033    variable ${name}::rows
1034    variable ${name}::columns
1035    variable ${name}::colw
1036    variable ${name}::rowh
1037
1038    # Move all data from the higher rows down and then delete the
1039    # superfluous data in the old last row. Move the data in the
1040    # height cache too, take partial fill into account there too.
1041    # Invalidate the width cache for all columns.
1042
1043    for {set c 0} {$c < $columns} {incr c} {
1044        for {set r $row; set rn [expr {$r + 1}]} {$rn < $rows} {incr r ; incr rn} {
1045            set data($c,$r) $data($c,$rn)
1046            if {[info exists rowh($rn)]} {
1047                set rowh($r) $rowh($rn)
1048                unset rowh($rn)
1049            }
1050        }
1051        unset data($c,$r)
1052        catch {unset colw($c)}
1053    }
1054    incr rows -1
1055    return
1056}
1057
1058# ::struct::matrix::__delete_rows --
1059#
1060#       Shrink the matrix by "n" rows (from the bottom).
1061#       A value of "n" equal to or smaller than 0 is not
1062#       allowed, nor is "n" allowed to be greater than the
1063#       number of rows in the matrix.
1064#
1065# Arguments:
1066#       name    Name of the matrix object.
1067#       n       The number of rows to remove.
1068#
1069# Results:
1070#       None.
1071
1072proc ::struct::matrix::__delete_rows {name n} {
1073    if {$n <= 0} {
1074        return -code error "A value of n <= 0 is not allowed"
1075    }
1076
1077    variable ${name}::rows
1078
1079    if {$n > $rows} {
1080        return -code error "A value of n > #rows is not allowed"
1081    }
1082
1083    DeleteRows $name $n
1084    return
1085}
1086
1087# ::struct::matrix::_deserialize --
1088#
1089#       Assignment operator. Copies a serialization into the
1090#       destination, destroying the original information.
1091#
1092# Arguments:
1093#       name    Name of the matrix object we are copying into.
1094#       serial  Serialized matrix to copy from.
1095#
1096# Results:
1097#       Nothing.
1098
1099proc ::struct::matrix::_deserialize {name serial} {
1100    # As we destroy the original matrix as part of
1101    # the copying process we don't have to deal
1102    # with issues like node names from the new matrix
1103    # interfering with the old ...
1104
1105    # I. Get the serialization of the source matrix
1106    #    and check it for validity.
1107
1108    CheckSerialization $serial r c values
1109
1110    # Get all the relevant data into the scope
1111
1112    variable ${name}::rows
1113    variable ${name}::columns
1114
1115    # Resize the destination matrix for the new data
1116
1117    if {$r > $rows} {
1118        AddRows $name [expr {$r - $rows}]
1119    } elseif {$r < $rows} {
1120        DeleteRows $name [expr {$rows - $r}]
1121    }
1122    if {$c > $columns} {
1123        AddColumns $name [expr {$c - $columns}]
1124    } elseif {$c < $columns} {
1125        DeleteColumns $name [expr {$columns - $c}]
1126    }
1127
1128    set rows    $r
1129    set columns $c
1130
1131    # Copy the new data over the old information.
1132
1133    set row 0
1134    foreach rv $values {
1135        SetRow $name $row $rv
1136        incr row
1137    }
1138    while {$row < $rows} {
1139        # Fill with empty rows if there are not enough.
1140        SetRow $name $row {}
1141        incr row
1142    }
1143    return
1144}
1145
1146# ::struct::matrix::_destroy --
1147#
1148#       Destroy a matrix, including its associated command and data storage.
1149#
1150# Arguments:
1151#       name    Name of the matrix to destroy.
1152#
1153# Results:
1154#       None.
1155
1156proc ::struct::matrix::_destroy {name} {
1157    variable ${name}::link
1158
1159    # Unlink all existing arrays before destroying the object so that
1160    # we don't leave dangling references / traces.
1161
1162    foreach avar [array names link] {
1163        _unlink $name $avar
1164    }
1165
1166    namespace delete $name
1167    interp alias {}  $name {}
1168}
1169
1170# ::struct::matrix::__format_2string --
1171#
1172#       Formats the matrix using the specified report object and
1173#       returns the string containing the result of this
1174#       operation. The report has to support the "printmatrix" method.
1175#
1176# Arguments:
1177#       name    Name of the matrix.
1178#       report  Name of the report object specifying the formatting.
1179#
1180# Results:
1181#       A string containing the formatting result.
1182
1183proc ::struct::matrix::__format_2string {name {report {}}} {
1184    if {$report == {}} {
1185        # Use an internal hardwired simple report to format the matrix.
1186        # 1. Go through all columns and compute the column widths.
1187        # 2. Then iterate through all rows and dump then into a
1188        #    string, formatted to the number of characters per columns
1189
1190        array set cw {}
1191        set cols [_columns $name]
1192        for {set c 0} {$c < $cols} {incr c} {
1193            set cw($c) [_columnwidth $name $c]
1194        }
1195
1196        set result [list]
1197        set n [_rows $name]
1198        for {set r 0} {$r < $n} {incr r} {
1199            set rh [_rowheight $name $r]
1200            if {$rh < 2} {
1201                # Simple row.
1202                set line [list]
1203                for {set c 0} {$c < $cols} {incr c} {
1204                    set val [__get_cell $name $c $r]
1205                    lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]"
1206                }
1207                lappend result [join $line " "]
1208            } else {
1209                # Complex row, multiple passes
1210                for {set h 0} {$h < $rh} {incr h} {
1211                    set line [list]
1212                    for {set c 0} {$c < $cols} {incr c} {
1213                        set val [lindex [split [__get_cell $name $c $r] \n] $h]
1214                        lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]"
1215                    }
1216                    lappend result [join $line " "]
1217                }
1218            }
1219        }
1220        return [join $result \n]
1221    } else {
1222        return [$report printmatrix $name]
1223    }
1224}
1225
1226# ::struct::matrix::__format_2chan --
1227#
1228#       Formats the matrix using the specified report object and
1229#       writes the string containing the result of this operation into
1230#       the channel. The report has to support the
1231#       "printmatrix2channel" method.
1232#
1233# Arguments:
1234#       name    Name of the matrix.
1235#       report  Name of the report object specifying the formatting.
1236#       chan    Handle of the channel to write to.
1237#
1238# Results:
1239#       None.
1240
1241proc ::struct::matrix::__format_2chan {name {report {}} {chan stdout}} {
1242    if {$report == {}} {
1243        # Use an internal hardwired simple report to format the matrix.
1244        # We delegate this to the string formatter and print its result.
1245        puts -nonewline [__format_2string $name]
1246    } else {
1247        $report printmatrix2channel $name $chan
1248    }
1249    return
1250}
1251
1252# ::struct::matrix::__get_cell --
1253#
1254#       Returns the value currently contained in the cell identified
1255#       by row and column index.
1256#
1257# Arguments:
1258#       name    Name of the matrix.
1259#       column  Column index of the addressed cell.
1260#       row     Row index of the addressed cell.
1261#
1262# Results:
1263#       value   Value currently stored in the addressed cell.
1264
1265proc ::struct::matrix::__get_cell {name column row} {
1266    set column [ChkColumnIndex $name $column]
1267    set row    [ChkRowIndex    $name $row]
1268
1269    variable ${name}::data
1270    return $data($column,$row)
1271}
1272
1273# ::struct::matrix::__get_column --
1274#
1275#       Returns a list containing the values from all cells in the
1276#       column identified by the index. The contents of the cell in
1277#       row 0 are stored as the first element of this list.
1278#
1279# Arguments:
1280#       name    Name of the matrix.
1281#       column  Column index of the addressed cell.
1282#
1283# Results:
1284#       List of values stored in the addressed row.
1285
1286proc ::struct::matrix::__get_column {name column} {
1287    set column [ChkColumnIndex $name $column]
1288    return     [GetColumn      $name $column]
1289}
1290
1291proc ::struct::matrix::GetColumn {name column} {
1292    variable ${name}::data
1293    variable ${name}::rows
1294
1295    set result [list]
1296    for {set r 0} {$r < $rows} {incr r} {
1297        lappend result $data($column,$r)
1298    }
1299    return $result
1300}
1301
1302# ::struct::matrix::__get_rect --
1303#
1304#       Returns a list of lists of cell values. The values stored in
1305#       the result come from the submatrix whose top-left and
1306#       bottom-right cells are specified by "column_tl", "row_tl" and
1307#       "column_br", "row_br" resp. Note that the following equations
1308#       have to be true: column_tl <= column_br and row_tl <= row_br.
1309#       The result is organized as follows: The outer list is the list
1310#       of rows, its elements are lists representing a single row. The
1311#       row with the smallest index is the first element of the outer
1312#       list. The elements of the row lists represent the selected
1313#       cell values. The cell with the smallest index is the first
1314#       element in each row list.
1315#
1316# Arguments:
1317#       name            Name of the matrix.
1318#       column_tl       Column index of the top-left cell of the area.
1319#       row_tl          Row index of the top-left cell of the the area
1320#       column_br       Column index of the bottom-right cell of the area.
1321#       row_br          Row index of the bottom-right cell of the the area
1322#
1323# Results:
1324#       List of a list of values stored in the addressed area.
1325
1326proc ::struct::matrix::__get_rect {name column_tl row_tl column_br row_br} {
1327    set column_tl [ChkColumnIndex $name $column_tl]
1328    set row_tl    [ChkRowIndex    $name $row_tl]
1329    set column_br [ChkColumnIndex $name $column_br]
1330    set row_br    [ChkRowIndex    $name $row_br]
1331
1332    if {
1333        ($column_tl > $column_br) ||
1334        ($row_tl    > $row_br)
1335    } {
1336        return -code error "Invalid cell indices, wrong ordering"
1337    }
1338    return [GetRect $name $column_tl $row_tl $column_br $row_br]
1339}
1340
1341proc ::struct::matrix::GetRect {name column_tl row_tl column_br row_br} {
1342    variable ${name}::data
1343    set result [list]
1344
1345    for {set r $row_tl} {$r <= $row_br} {incr r} {
1346        set row [list]
1347        for {set c $column_tl} {$c <= $column_br} {incr c} {
1348            lappend row $data($c,$r)
1349        }
1350        lappend result $row
1351    }
1352
1353    return $result
1354}
1355
1356# ::struct::matrix::__get_row --
1357#
1358#       Returns a list containing the values from all cells in the
1359#       row identified by the index. The contents of the cell in
1360#       column 0 are stored as the first element of this list.
1361#
1362# Arguments:
1363#       name    Name of the matrix.
1364#       row     Row index of the addressed cell.
1365#
1366# Results:
1367#       List of values stored in the addressed row.
1368
1369proc ::struct::matrix::__get_row {name row} {
1370    set row [ChkRowIndex $name $row]
1371    return  [GetRow      $name $row]
1372}
1373
1374proc ::struct::matrix::GetRow {name row} {
1375    variable ${name}::data
1376    variable ${name}::columns
1377
1378    set result [list]
1379    for {set c 0} {$c < $columns} {incr c} {
1380        lappend result $data($c,$row)
1381    }
1382    return $result
1383}
1384
1385# ::struct::matrix::__insert_column --
1386#
1387#       Extends the matrix by one column and then acts like
1388#       "setcolumn" (see below) on this new column if there were
1389#       "values" supplied. Without "values" the new cells will be set
1390#       to the empty string. The new column is inserted just before
1391#       the column specified by the given index. This means, if
1392#       "column" is less than or equal to zero, then the new column is
1393#       inserted at the beginning of the matrix, before the first
1394#       column. If "column" has the value "Bend", or if it is greater
1395#       than or equal to the number of columns in the matrix, then the
1396#       new column is appended to the matrix, behind the last
1397#       column. The old column at the chosen index and all columns
1398#       with higher indices are shifted one index upward.
1399#
1400# Arguments:
1401#       name    Name of the matrix.
1402#       column  Index of the column where to insert.
1403#       values  Optional values to set the cells to.
1404#
1405# Results:
1406#       None.
1407
1408proc ::struct::matrix::__insert_column {name column {values {}}} {
1409    # Allow both negative and too big indices.
1410    set column [ChkColumnIndexAll $name $column]
1411
1412    variable ${name}::columns
1413
1414    if {$column > $columns} {
1415        # Same as 'addcolumn'
1416        __add_column $name $values
1417        return
1418    }
1419
1420    variable ${name}::data
1421    variable ${name}::rows
1422    variable ${name}::rowh
1423    variable ${name}::colw
1424
1425    set firstcol $column
1426    if {$firstcol < 0} {
1427        set firstcol 0
1428    }
1429
1430    if {[set l [llength $values]] < $rows} {
1431        # Missing values. Fill up with empty strings
1432
1433        for {} {$l < $rows} {incr l} {
1434            lappend values {}
1435        }
1436    } elseif {[llength $values] > $rows} {
1437        # To many values. Remove the superfluous items
1438        set values [lrange $values 0 [expr {$rows - 1}]]
1439    }
1440
1441    # "values" now contains the information to set into the array.
1442    # Regarding the width and height caches:
1443    # Invalidate all rows, move all columns
1444
1445    # Move all data from the higher columns one up and then insert the
1446    # new data into the freed space. Move the data in the
1447    # width cache too, take partial fill into account there too.
1448    # Invalidate the height cache for all rows.
1449
1450    for {set r 0} {$r < $rows} {incr r} {
1451        for {set cn $columns ; set c [expr {$cn - 1}]} {$c >= $firstcol} {incr c -1 ; incr cn -1} {
1452            set data($cn,$r) $data($c,$r)
1453            if {[info exists colw($c)]} {
1454                set colw($cn) $colw($c)
1455                unset colw($c)
1456            }
1457        }
1458        set data($firstcol,$r) [lindex $values $r]
1459        catch {unset rowh($r)}
1460    }
1461    incr columns
1462    return
1463}
1464
1465# ::struct::matrix::__insert_row --
1466#
1467#       Extends the matrix by one row and then acts like "setrow" (see
1468#       below) on this new row if there were "values"
1469#       supplied. Without "values" the new cells will be set to the
1470#       empty string. The new row is inserted just before the row
1471#       specified by the given index. This means, if "row" is less
1472#       than or equal to zero, then the new row is inserted at the
1473#       beginning of the matrix, before the first row. If "row" has
1474#       the value "end", or if it is greater than or equal to the
1475#       number of rows in the matrix, then the new row is appended to
1476#       the matrix, behind the last row. The old row at that index and
1477#       all rows with higher indices are shifted one index upward.
1478#
1479# Arguments:
1480#       name    Name of the matrix.
1481#       row     Index of the row where to insert.
1482#       values  Optional values to set the cells to.
1483#
1484# Results:
1485#       None.
1486
1487proc ::struct::matrix::__insert_row {name row {values {}}} {
1488    # Allow both negative and too big indices.
1489    set row [ChkRowIndexAll $name $row]
1490
1491    variable ${name}::rows
1492
1493    if {$row > $rows} {
1494        # Same as 'addrow'
1495        __add_row $name $values
1496        return
1497    }
1498
1499    variable ${name}::data
1500    variable ${name}::columns
1501    variable ${name}::rowh
1502    variable ${name}::colw
1503
1504    set firstrow $row
1505    if {$firstrow < 0} {
1506        set firstrow 0
1507    }
1508
1509    if {[set l [llength $values]] < $columns} {
1510        # Missing values. Fill up with empty strings
1511
1512        for {} {$l < $columns} {incr l} {
1513            lappend values {}
1514        }
1515    } elseif {[llength $values] > $columns} {
1516        # To many values. Remove the superfluous items
1517        set values [lrange $values 0 [expr {$columns - 1}]]
1518    }
1519
1520    # "values" now contains the information to set into the array.
1521    # Regarding the width and height caches:
1522    # Invalidate all columns, move all rows
1523
1524    # Move all data from the higher rows one up and then insert the
1525    # new data into the freed space. Move the data in the
1526    # height cache too, take partial fill into account there too.
1527    # Invalidate the width cache for all columns.
1528
1529    for {set c 0} {$c < $columns} {incr c} {
1530        for {set rn $rows ; set r [expr {$rn - 1}]} {$r >= $firstrow} {incr r -1 ; incr rn -1} {
1531            set data($c,$rn) $data($c,$r)
1532            if {[info exists rowh($r)]} {
1533                set rowh($rn) $rowh($r)
1534                unset rowh($r)
1535            }
1536        }
1537        set data($c,$firstrow) [lindex $values $c]
1538        catch {unset colw($c)}
1539    }
1540    incr rows
1541    return
1542}
1543
1544# ::struct::matrix::_link --
1545#
1546#       Links the matrix to the specified array variable. This means
1547#       that the contents of all cells in the matrix is stored in the
1548#       array too, with all changes to the matrix propagated there
1549#       too. The contents of the cell "(column,row)" is stored in the
1550#       array using the key "column,row". If the option "-transpose"
1551#       is specified the key "row,column" will be used instead. It is
1552#       possible to link the matrix to more than one array. Note that
1553#       the link is bidirectional, i.e. changes to the array are
1554#       mirrored in the matrix too.
1555#
1556# Arguments:
1557#       name    Name of the matrix object.
1558#       option  Either empty of '-transpose'.
1559#       avar    Name of the variable to link to
1560#
1561# Results:
1562#       None
1563
1564proc ::struct::matrix::_link {name args} {
1565    switch -exact -- [llength $args] {
1566        0 {
1567            return -code error "$name: wrong # args: link ?-transpose? arrayvariable"
1568        }
1569        1 {
1570            set transpose 0
1571            set variable  [lindex $args 0]
1572        }
1573        2 {
1574            foreach {t variable} $args break
1575            if {[string compare $t -transpose]} {
1576                return -code error "$name: illegal syntax: link ?-transpose? arrayvariable"
1577            }
1578            set transpose 1
1579        }
1580        default {
1581            return -code error "$name: wrong # args: link ?-transpose? arrayvariable"
1582        }
1583    }
1584
1585    variable ${name}::link
1586
1587    if {[info exists link($variable)]} {
1588        return -code error "$name link: Variable \"$variable\" already linked to matrix"
1589    }
1590
1591    # Ok, a new variable we are linked to. Record this information,
1592    # dump our current contents into the array, at last generate the
1593    # traces actually performing the link.
1594
1595    set link($variable) $transpose
1596
1597    upvar #0 $variable array
1598    variable ${name}::data
1599
1600    foreach key [array names data] {
1601        foreach {c r} [split $key ,] break
1602        if {$transpose} {
1603            set array($r,$c) $data($key)
1604        } else {
1605            set array($c,$r) $data($key)
1606        }
1607    }
1608
1609    trace variable array wu [list ::struct::matrix::MatTraceIn  $variable $name]
1610    trace variable data  w  [list ::struct::matrix::MatTraceOut $variable $name]
1611    return
1612}
1613
1614# ::struct::matrix::_links --
1615#
1616#       Retrieves the names of all array variable the matrix is
1617#       officially linked to.
1618#
1619# Arguments:
1620#       name    Name of the matrix object.
1621#
1622# Results:
1623#       List of variables the matrix is linked to.
1624
1625proc ::struct::matrix::_links {name} {
1626    variable ${name}::link
1627    return [array names link]
1628}
1629
1630# ::struct::matrix::_rowheight --
1631#
1632#       Returns the height of the specified row in lines. This is the
1633#       highest number of lines spanned by a cell over all cells in
1634#       the row.
1635#
1636# Arguments:
1637#       name    Name of the matrix
1638#       row     Index of the row queried for its height
1639#
1640# Results:
1641#       The height of the specified row in lines.
1642
1643proc ::struct::matrix::_rowheight {name row} {
1644    set row [ChkRowIndex $name $row]
1645
1646    variable ${name}::rowh
1647
1648    if {![info exists rowh($row)]} {
1649        variable ${name}::columns
1650        variable ${name}::data
1651
1652        set height 1
1653        for {set c 0} {$c < $columns} {incr c} {
1654            set cheight [llength [split $data($c,$row) \n]]
1655            if {$cheight > $height} {
1656                set height $cheight
1657            }
1658        }
1659
1660        set rowh($row) $height
1661    }
1662    return $rowh($row)
1663}
1664
1665# ::struct::matrix::_rows --
1666#
1667#       Returns the number of rows currently managed by the matrix.
1668#
1669# Arguments:
1670#       name    Name of the matrix object.
1671#
1672# Results:
1673#       The number of rows in the matrix.
1674
1675proc ::struct::matrix::_rows {name} {
1676    variable ${name}::rows
1677    return $rows
1678}
1679
1680# ::struct::matrix::_serialize --
1681#
1682#       Serialize a matrix object (partially) into a transportable value.
1683#       If only a rectangle is serialized the result will be a sub-
1684#       matrix in the mathematical sense of the word.
1685#
1686# Arguments:
1687#       name    Name of the matrix.
1688#       args    rectangle to place into the serialized matrix
1689#
1690# Results:
1691#       A list structure describing the part of the matrix which was serialized.
1692
1693proc ::struct::matrix::_serialize {name args} {
1694
1695    # all - boolean flag - set if and only if the all nodes of the
1696    # matrix are chosen for serialization. Because if that is true we
1697    # can skip the step finding the relevant arcs and simply take all
1698    # arcs.
1699
1700    set nargs [llength $args]
1701    if {($nargs != 0) && ($nargs != 4)} {
1702        return -code error "$name: wrong # args: serialize ?column_tl row_tl column_br row_br?"
1703    }
1704
1705    variable ${name}::rows
1706    variable ${name}::columns
1707
1708    if {$nargs == 4} {
1709        foreach {column_tl row_tl column_br row_br} $args break
1710
1711        set column_tl [ChkColumnIndex $name $column_tl]
1712        set row_tl    [ChkRowIndex    $name $row_tl]
1713        set column_br [ChkColumnIndex $name $column_br]
1714        set row_br    [ChkRowIndex    $name $row_br]
1715
1716        if {
1717            ($column_tl > $column_br) ||
1718            ($row_tl    > $row_br)
1719        } {
1720            return -code error "Invalid cell indices, wrong ordering"
1721        }
1722        set rn [expr {$row_br    - $row_tl    + 1}]
1723        set cn [expr {$column_br - $column_tl + 1}]
1724    } else {
1725        set column_tl 0
1726        set row_tl    0
1727        set column_br [expr {$columns - 1}]
1728        set row_br    [expr {$rows - 1}]
1729        set rn $rows
1730        set cn $columns
1731    }
1732
1733    # We could optimize and remove empty cells to the right and rows
1734    # to the bottom. For now we don't.
1735
1736    return [list \
1737            $rn $cn \
1738            [GetRect $name $column_tl $row_tl $column_br $row_br]]
1739}
1740
1741# ::struct::matrix::__set_cell --
1742#
1743#       Sets the value in the cell identified by row and column index
1744#       to the data in the third argument.
1745#
1746# Arguments:
1747#       name    Name of the matrix object.
1748#       column  Column index of the cell to set.
1749#       row     Row index of the cell to set.
1750#       value   The new value of the cell.
1751#
1752# Results:
1753#       None.
1754 
1755proc ::struct::matrix::__set_cell {name column row value} {
1756    set column [ChkColumnIndex $name $column]
1757    set row    [ChkRowIndex    $name $row]
1758
1759    variable ${name}::data
1760
1761    if {![string compare $value $data($column,$row)]} {
1762        # No change, ignore call!
1763        return
1764    }
1765
1766    set data($column,$row) $value
1767
1768    if {$value != {}} {
1769        variable ${name}::colw
1770        variable ${name}::rowh
1771        catch {unset colw($column)}
1772        catch {unset rowh($row)}
1773    }
1774    return
1775}
1776
1777# ::struct::matrix::__set_column --
1778#
1779#       Sets the values in the cells identified by the column index to
1780#       the elements of the list provided as the third argument. Each
1781#       element of the list is assigned to one cell, with the first
1782#       element going into the cell in row 0 and then upward. If there
1783#       are less values in the list than there are rows the remaining
1784#       rows are set to the empty string. If there are more values in
1785#       the list than there are rows the superfluous elements are
1786#       ignored. The matrix is not extended by this operation.
1787#
1788# Arguments:
1789#       name    Name of the matrix.
1790#       column  Index of the column to set.
1791#       values  Values to set into the column.
1792#
1793# Results:
1794#       None.
1795
1796proc ::struct::matrix::__set_column {name column values} {
1797    set column [ChkColumnIndex $name $column]
1798
1799    variable ${name}::data
1800    variable ${name}::columns
1801    variable ${name}::rows
1802    variable ${name}::rowh
1803    variable ${name}::colw
1804
1805    if {[set l [llength $values]] < $rows} {
1806        # Missing values. Fill up with empty strings
1807
1808        for {} {$l < $rows} {incr l} {
1809            lappend values {}
1810        }
1811    } elseif {[llength $values] > $rows} {
1812        # To many values. Remove the superfluous items
1813        set values [lrange $values 0 [expr {$rows - 1}]]
1814    }
1815
1816    # "values" now contains the information to set into the array.
1817    # Regarding the width and height caches:
1818
1819    # - Invalidate the column in the width cache.
1820    # - The rows are either removed from the height cache or left
1821    #   unchanged, depending on the contents set into the cell.
1822
1823    set r 0
1824    foreach v $values {
1825        if {$v != {}} {
1826            # Data changed unpredictably, invalidate cache
1827            catch {unset rowh($r)}
1828        } ; # {else leave the row unchanged}
1829        set data($column,$r) $v
1830        incr r
1831    }
1832    catch {unset colw($column)}
1833    return
1834}
1835
1836# ::struct::matrix::__set_rect --
1837#
1838#       Takes a list of lists of cell values and writes them into the
1839#       submatrix whose top-left cell is specified by the two
1840#       indices. If the sublists of the outer list are not of equal
1841#       length the shorter sublists will be filled with empty strings
1842#       to the length of the longest sublist. If the submatrix
1843#       specified by the top-left cell and the number of rows and
1844#       columns in the "values" extends beyond the matrix we are
1845#       modifying the over-extending parts of the values are ignored,
1846#       i.e. essentially cut off. This subcommand expects its input in
1847#       the format as returned by "getrect".
1848#
1849# Arguments:
1850#       name    Name of the matrix object.
1851#       column  Column index of the topleft cell to set.
1852#       row     Row index of the topleft cell to set.
1853#       values  Values to set.
1854#
1855# Results:
1856#       None.
1857
1858proc ::struct::matrix::__set_rect {name column row values} {
1859    # Allow negative indices!
1860    set column [ChkColumnIndexNeg $name $column]
1861    set row    [ChkRowIndexNeg    $name $row]
1862
1863    variable ${name}::data
1864    variable ${name}::columns
1865    variable ${name}::rows
1866    variable ${name}::colw
1867    variable ${name}::rowh
1868
1869    if {$row < 0} {
1870        # Remove rows from the head of values to restrict it to the
1871        # overlapping area.
1872
1873        set values [lrange $values [expr {0 - $row}] end]
1874        set row 0
1875    }
1876
1877    # Restrict it at the end too.
1878    if {($row + [llength $values]) > $rows} {
1879        set values [lrange $values 0 [expr {$rows - $row - 1}]]
1880    }
1881
1882    # Same for columns, but store it in some vars as this is required
1883    # in a loop.
1884    set firstcol 0
1885    if {$column < 0} {
1886        set firstcol [expr {0 - $column}]
1887        set column 0
1888    }
1889
1890    # Now pan through values and area and copy the external data into
1891    # the matrix.
1892
1893    set r $row
1894    foreach line $values {
1895        set line [lrange $line $firstcol end]
1896
1897        set l [expr {$column + [llength $line]}]
1898        if {$l > $columns} {
1899            set line [lrange $line 0 [expr {$columns - $column - 1}]]
1900        } elseif {$l < [expr {$columns - $firstcol}]} {
1901            # We have to take the offset into the line into account
1902            # or we add fillers we don't need, overwriting part of the
1903            # data array we shouldn't.
1904
1905            for {} {$l < [expr {$columns - $firstcol}]} {incr l} {
1906                lappend line {}
1907            }
1908        }
1909
1910        set c $column
1911        foreach cell $line {
1912            if {$cell != {}} {
1913                catch {unset rowh($r)}
1914                catch {unset colw($c)}
1915            }
1916            set data($c,$r) $cell
1917            incr c
1918        }
1919        incr r
1920    }
1921    return
1922}
1923
1924# ::struct::matrix::__set_row --
1925#
1926#       Sets the values in the cells identified by the row index to
1927#       the elements of the list provided as the third argument. Each
1928#       element of the list is assigned to one cell, with the first
1929#       element going into the cell in column 0 and then upward. If
1930#       there are less values in the list than there are columns the
1931#       remaining columns are set to the empty string. If there are
1932#       more values in the list than there are columns the superfluous
1933#       elements are ignored. The matrix is not extended by this
1934#       operation.
1935#
1936# Arguments:
1937#       name    Name of the matrix.
1938#       row     Index of the row to set.
1939#       values  Values to set into the row.
1940#
1941# Results:
1942#       None.
1943
1944proc ::struct::matrix::__set_row {name row values} {
1945    set row [ChkRowIndex $name $row]
1946    SetRow $name $row $values
1947}
1948
1949proc ::struct::matrix::SetRow {name row values} {
1950    variable ${name}::data
1951    variable ${name}::columns
1952    variable ${name}::rows
1953    variable ${name}::colw
1954    variable ${name}::rowh
1955
1956    if {[set l [llength $values]] < $columns} {
1957        # Missing values. Fill up with empty strings
1958
1959        for {} {$l < $columns} {incr l} {
1960            lappend values {}
1961        }
1962    } elseif {[llength $values] > $columns} {
1963        # To many values. Remove the superfluous items
1964        set values [lrange $values 0 [expr {$columns - 1}]]
1965    }
1966
1967    # "values" now contains the information to set into the array.
1968    # Regarding the width and height caches:
1969
1970    # - Invalidate the row in the height cache.
1971    # - The columns are either removed from the width cache or left
1972    #   unchanged, depending on the contents set into the cell.
1973
1974    set c 0
1975    foreach v $values {
1976        if {$v != {}} {
1977            # Data changed unpredictably, invalidate cache
1978            catch {unset colw($c)}
1979        } ; # {else leave the row unchanged}
1980        set data($c,$row) $v
1981        incr c
1982    }
1983    catch {unset rowh($row)}
1984    return
1985}
1986
1987# ::struct::matrix::__swap_columns --
1988#
1989#       Swaps the contents of the two specified columns.
1990#
1991# Arguments:
1992#       name            Name of the matrix.
1993#       column_a        Index of the first column to swap
1994#       column_b        Index of the second column to swap
1995#
1996# Results:
1997#       None.
1998
1999proc ::struct::matrix::__swap_columns {name column_a column_b} {
2000    set column_a [ChkColumnIndex $name $column_a]
2001    set column_b [ChkColumnIndex $name $column_b]
2002    return [SwapColumns $name $column_a $column_b]
2003}
2004
2005proc ::struct::matrix::SwapColumns {name column_a column_b} {
2006    variable ${name}::data
2007    variable ${name}::rows
2008    variable ${name}::colw
2009
2010    # Note: This operation does not influence the height cache for all
2011    # rows and the width cache only insofar as its contents has to be
2012    # swapped too for the two columns we are touching. Note that the
2013    # cache might be partially filled or not at all, so we don't have
2014    # to "swap" in some situations.
2015
2016    for {set r 0} {$r < $rows} {incr r} {
2017        set tmp                $data($column_a,$r)
2018        set data($column_a,$r) $data($column_b,$r)
2019        set data($column_b,$r) $tmp
2020    }
2021
2022    set cwa [info exists colw($column_a)]
2023    set cwb [info exists colw($column_b)]
2024
2025    if {$cwa && $cwb} {
2026        set tmp             $colw($column_a)
2027        set colw($column_a) $colw($column_b)
2028        set colw($column_b) $tmp
2029    } elseif {$cwa} {
2030        # Move contents, don't swap.
2031        set   colw($column_b) $colw($column_a)
2032        unset colw($column_a)
2033    } elseif {$cwb} {
2034        # Move contents, don't swap.
2035        set   colw($column_a) $colw($column_b)
2036        unset colw($column_b)
2037    } ; # else {nothing to do at all}
2038    return
2039}
2040
2041# ::struct::matrix::__swap_rows --
2042#
2043#       Swaps the contents of the two specified rows.
2044#
2045# Arguments:
2046#       name    Name of the matrix.
2047#       row_a   Index of the first row to swap
2048#       row_b   Index of the second row to swap
2049#
2050# Results:
2051#       None.
2052
2053proc ::struct::matrix::__swap_rows {name row_a row_b} {
2054    set row_a [ChkRowIndex $name $row_a]
2055    set row_b [ChkRowIndex $name $row_b]
2056    return [SwapRows $name $row_a $row_b]
2057}
2058
2059proc ::struct::matrix::SwapRows {name row_a row_b} {
2060    variable ${name}::data
2061    variable ${name}::columns
2062    variable ${name}::rowh
2063
2064    # Note: This operation does not influence the width cache for all
2065    # columns and the height cache only insofar as its contents has to be
2066    # swapped too for the two rows we are touching. Note that the
2067    # cache might be partially filled or not at all, so we don't have
2068    # to "swap" in some situations.
2069
2070    for {set c 0} {$c < $columns} {incr c} {
2071        set tmp             $data($c,$row_a)
2072        set data($c,$row_a) $data($c,$row_b)
2073        set data($c,$row_b) $tmp
2074    }
2075
2076    set rha [info exists rowh($row_a)]
2077    set rhb [info exists rowh($row_b)]
2078
2079    if {$rha && $rhb} {
2080        set tmp          $rowh($row_a)
2081        set rowh($row_a) $rowh($row_b)
2082        set rowh($row_b) $tmp
2083    } elseif {$rha} {
2084        # Move contents, don't swap.
2085        set   rowh($row_b) $rowh($row_a)
2086        unset rowh($row_a)
2087    } elseif {$rhb} {
2088        # Move contents, don't swap.
2089        set   rowh($row_a) $rowh($row_b)
2090        unset rowh($row_b)
2091    } ; # else {nothing to do at all}
2092    return
2093}
2094
2095# ::struct::matrix::_transpose --
2096#
2097#       Exchanges rows and columns of the matrix
2098#
2099# Arguments:
2100#       name            Name of the matrix.
2101#
2102# Results:
2103#       None.
2104
2105proc ::struct::matrix::_transpose {name} {
2106    variable ${name}::rows
2107    variable ${name}::columns
2108
2109    if {$rows == 0} {
2110        # Change the dimensions.
2111        # There is no data to shift.
2112        # The row/col caches are empty too.
2113
2114        set rows    $columns
2115        set columns 0
2116        return
2117
2118    } elseif {$columns == 0} {
2119        # Change the dimensions.
2120        # There is no data to shift.
2121        # The row/col caches are empty too.
2122
2123        set columns $rows
2124        set rows    0
2125        return
2126    }
2127
2128    variable ${name}::data
2129    variable ${name}::rowh
2130    variable ${name}::colw
2131
2132    # Exchanging the row/col caches is easy, independent of the actual
2133    # dimensions of the matrix.
2134
2135    set rhc [array get rowh]
2136    set cwc [array get colw]
2137
2138    unset rowh ; array set rowh $cwc
2139    unset colw ; array set colw $rhc
2140
2141    if {$rows == $columns} {
2142        # A square matrix. We have to swap data around, but there is
2143        # need to resize any of the arrays. Only the core is present.
2144
2145        set n $columns
2146
2147    } elseif {$rows > $columns} {
2148        # Rectangular matrix, we have to delete rows, and add columns.
2149
2150        for {set r $columns} {$r < $rows} {incr r} {
2151            for {set c 0} {$c < $columns} {incr c} {
2152                set   data($r,$c) $data($c,$r)
2153                unset data($c,$r)
2154            }
2155        }
2156
2157        set n $columns ; # Size of the core.
2158    } else {
2159        # rows < columns. Rectangular matrix, we have to delete
2160        # columns, and add rows.
2161
2162        for {set c $rows} {$c < $columns} {incr c} {
2163            for {set r 0} {$r < $rows} {incr r} {
2164                set   data($r,$c) $data($c,$r)
2165                unset data($c,$r)
2166            }
2167        }
2168
2169        set n $rows ; # Size of the core.
2170    }
2171
2172    set tmp     $rows
2173    set rows    $columns
2174    set columns $tmp
2175
2176    # Whatever the actual dimensions, a square core is always
2177    # present. The data of this core is now shuffled
2178
2179    for {set i 0} {$i < $n} {incr i} {
2180        for {set j $i ; incr j} {$j < $n} {incr j} {
2181            set tmp $data($i,$j)
2182            set data($i,$j) $data($j,$i)
2183            set data($j,$i) $tmp
2184        }
2185    }
2186    return
2187}
2188
2189# ::struct::matrix::_unlink --
2190#
2191#       Removes the link between the matrix and the specified
2192#       arrayvariable, if there is one.
2193#
2194# Arguments:
2195#       name    Name of the matrix.
2196#       avar    Name of the linked array.
2197#
2198# Results:
2199#       None.
2200
2201proc ::struct::matrix::_unlink {name avar} {
2202
2203    variable ${name}::link
2204
2205    if {![info exists link($avar)]} {
2206        # Ignore unlinking of unknown variables.
2207        return
2208    }
2209
2210    # Delete the traces first, then remove the link management
2211    # information from the object.
2212
2213    upvar #0 $avar    array
2214    variable ${name}::data
2215
2216    trace vdelete array wu [list ::struct::matrix::MatTraceIn  $avar $name]
2217    trace vdelete date  w  [list ::struct::matrix::MatTraceOut $avar $name]
2218
2219    unset link($avar)
2220    return
2221}
2222
2223# ::struct::matrix::ChkColumnIndex --
2224#
2225#       Helper to check and transform column indices. Returns the
2226#       absolute index number belonging to the specified
2227#       index. Rejects indices out of the valid range of columns.
2228#
2229# Arguments:
2230#       matrix  Matrix to look at
2231#       column  The incoming index to check and transform
2232#
2233# Results:
2234#       The absolute index to the column
2235
2236proc ::struct::matrix::ChkColumnIndex {name column} {
2237    variable ${name}::columns
2238
2239    switch -regex -- $column {
2240        {end-[0-9]+} {
2241            set column [string map {end- ""} $column]
2242            set cc [expr {$columns - 1 - $column}]
2243            if {($cc < 0) || ($cc >= $columns)} {
2244                return -code error "bad column index end-$column, column does not exist"
2245            }
2246            return $cc
2247        }
2248        end {
2249            if {$columns <= 0} {
2250                return -code error "bad column index $column, column does not exist"
2251            }
2252            return [expr {$columns - 1}]
2253        }
2254        {[0-9]+} {
2255            if {($column < 0) || ($column >= $columns)} {
2256                return -code error "bad column index $column, column does not exist"
2257            }
2258            return $column
2259        }
2260        default {
2261            return -code error "bad column index \"$column\", syntax error"
2262        }
2263    }
2264    # Will not come to this place
2265}
2266
2267# ::struct::matrix::ChkRowIndex --
2268#
2269#       Helper to check and transform row indices. Returns the
2270#       absolute index number belonging to the specified
2271#       index. Rejects indices out of the valid range of rows.
2272#
2273# Arguments:
2274#       matrix  Matrix to look at
2275#       row     The incoming index to check and transform
2276#
2277# Results:
2278#       The absolute index to the row
2279
2280proc ::struct::matrix::ChkRowIndex {name row} {
2281    variable ${name}::rows
2282
2283    switch -regex -- $row {
2284        {end-[0-9]+} {
2285            set row [string map {end- ""} $row]
2286            set rr [expr {$rows - 1 - $row}]
2287            if {($rr < 0) || ($rr >= $rows)} {
2288                return -code error "bad row index end-$row, row does not exist"
2289            }
2290            return $rr
2291        }
2292        end {
2293            if {$rows <= 0} {
2294                return -code error "bad row index $row, row does not exist"
2295            }
2296            return [expr {$rows - 1}]
2297        }
2298        {[0-9]+} {
2299            if {($row < 0) || ($row >= $rows)} {
2300                return -code error "bad row index $row, row does not exist"
2301            }
2302            return $row
2303        }
2304        default {
2305            return -code error "bad row index \"$row\", syntax error"
2306        }
2307    }
2308    # Will not come to this place
2309}
2310
2311# ::struct::matrix::ChkColumnIndexNeg --
2312#
2313#       Helper to check and transform column indices. Returns the
2314#       absolute index number belonging to the specified
2315#       index. Rejects indices out of the valid range of columns
2316#       (Accepts negative indices).
2317#
2318# Arguments:
2319#       matrix  Matrix to look at
2320#       column  The incoming index to check and transform
2321#
2322# Results:
2323#       The absolute index to the column
2324
2325proc ::struct::matrix::ChkColumnIndexNeg {name column} {
2326    variable ${name}::columns
2327
2328    switch -regex -- $column {
2329        {end-[0-9]+} {
2330            set column [string map {end- ""} $column]
2331            set cc [expr {$columns - 1 - $column}]
2332            if {$cc >= $columns} {
2333                return -code error "bad column index end-$column, column does not exist"
2334            }
2335            return $cc
2336        }
2337        end {
2338            return [expr {$columns - 1}]
2339        }
2340        {[0-9]+} {
2341            if {$column >= $columns} {
2342                return -code error "bad column index $column, column does not exist"
2343            }
2344            return $column
2345        }
2346        default {
2347            return -code error "bad column index \"$column\", syntax error"
2348        }
2349    }
2350    # Will not come to this place
2351}
2352
2353# ::struct::matrix::ChkRowIndexNeg --
2354#
2355#       Helper to check and transform row indices. Returns the
2356#       absolute index number belonging to the specified
2357#       index. Rejects indices out of the valid range of rows
2358#       (Accepts negative indices).
2359#
2360# Arguments:
2361#       matrix  Matrix to look at
2362#       row     The incoming index to check and transform
2363#
2364# Results:
2365#       The absolute index to the row
2366
2367proc ::struct::matrix::ChkRowIndexNeg {name row} {
2368    variable ${name}::rows
2369
2370    switch -regex -- $row {
2371        {end-[0-9]+} {
2372            set row [string map {end- ""} $row]
2373            set rr [expr {$rows - 1 - $row}]
2374            if {$rr >= $rows} {
2375                return -code error "bad row index end-$row, row does not exist"
2376            }
2377            return $rr
2378        }
2379        end {
2380            return [expr {$rows - 1}]
2381        }
2382        {[0-9]+} {
2383            if {$row >= $rows} {
2384                return -code error "bad row index $row, row does not exist"
2385            }
2386            return $row
2387        }
2388        default {
2389            return -code error "bad row index \"$row\", syntax error"
2390        }
2391    }
2392    # Will not come to this place
2393}
2394
2395# ::struct::matrix::ChkColumnIndexAll --
2396#
2397#       Helper to transform column indices. Returns the
2398#       absolute index number belonging to the specified
2399#       index.
2400#
2401# Arguments:
2402#       matrix  Matrix to look at
2403#       column  The incoming index to check and transform
2404#
2405# Results:
2406#       The absolute index to the column
2407
2408proc ::struct::matrix::ChkColumnIndexAll {name column} {
2409    variable ${name}::columns
2410
2411    switch -regex -- $column {
2412        {end-[0-9]+} {
2413            set column [string map {end- ""} $column]
2414            set cc [expr {$columns - 1 - $column}]
2415            return $cc
2416        }
2417        end {
2418            return $columns
2419        }
2420        {[0-9]+} {
2421            return $column
2422        }
2423        default {
2424            return -code error "bad column index \"$column\", syntax error"
2425        }
2426    }
2427    # Will not come to this place
2428}
2429
2430# ::struct::matrix::ChkRowIndexAll --
2431#
2432#       Helper to transform row indices. Returns the
2433#       absolute index number belonging to the specified
2434#       index.
2435#
2436# Arguments:
2437#       matrix  Matrix to look at
2438#       row     The incoming index to check and transform
2439#
2440# Results:
2441#       The absolute index to the row
2442
2443proc ::struct::matrix::ChkRowIndexAll {name row} {
2444    variable ${name}::rows
2445
2446    switch -regex -- $row {
2447        {end-[0-9]+} {
2448            set row [string map {end- ""} $row]
2449            set rr [expr {$rows - 1 - $row}]
2450            return $rr
2451        }
2452        end {
2453            return $rows
2454        }
2455        {[0-9]+} {
2456            return $row
2457        }
2458        default {
2459            return -code error "bad row index \"$row\", syntax error"
2460        }
2461    }
2462    # Will not come to this place
2463}
2464
2465# ::struct::matrix::MatTraceIn --
2466#
2467#       Helper propagating changes made to an array
2468#       into the matrix the array is linked to.
2469#
2470# Arguments:
2471#       avar            Name of the array which was changed.
2472#       name            Matrix to write the changes to.
2473#       var,idx,op      Standard trace arguments
2474#
2475# Results:
2476#       None.
2477
2478proc ::struct::matrix::MatTraceIn {avar name var idx op} {
2479    # Propagate changes in the linked array back into the matrix.
2480
2481    variable ${name}::lock
2482    if {$lock} {return}
2483
2484    # We have to cover two possibilities when encountering an "unset" operation ...
2485    # 1. The external array was destroyed: perform automatic unlink.
2486    # 2. An individual element was unset:  Set the corresponding cell to the empty string.
2487    #    See SF Tcllib Bug #532791.
2488
2489    if {(![string compare $op u]) && ($idx == {})} {
2490        # Possibility 1: Array was destroyed
2491        $name unlink $avar
2492        return
2493    }
2494
2495    upvar #0 $avar    array
2496    variable ${name}::data
2497    variable ${name}::link
2498
2499    set transpose $link($avar)
2500    if {$transpose} {
2501        foreach {r c} [split $idx ,] break
2502    } else {
2503        foreach {c r} [split $idx ,] break
2504    }
2505
2506    # Use standard method to propagate the change.
2507    # => Get automatically index checks, cache updates, ...
2508
2509    if {![string compare $op u]} {
2510        # Unset possibility 2: Element was unset.
2511        # Note: Setting the cell to the empty string will
2512        # invoke MatTraceOut for this array and thus try
2513        # to recreate the destroyed element of the array.
2514        # We don't want this. But we do want to propagate
2515        # the change to other arrays, as "unset". To do
2516        # all of this we use another state variable to
2517        # signal this situation.
2518
2519        variable ${name}::unset
2520        set unset $avar
2521
2522        $name set cell $c $r ""
2523
2524        set unset {}
2525        return
2526    }
2527
2528    $name set cell $c $r $array($idx)
2529    return
2530}
2531
2532# ::struct::matrix::MatTraceOut --
2533#
2534#       Helper propagating changes made to the matrix into the linked arrays.
2535#
2536# Arguments:
2537#       avar            Name of the array to write the changes to.
2538#       name            Matrix which was changed.
2539#       var,idx,op      Standard trace arguments
2540#
2541# Results:
2542#       None.
2543
2544proc ::struct::matrix::MatTraceOut {avar name var idx op} {
2545    # Propagate changes in the matrix data array into the linked array.
2546
2547    variable ${name}::unset
2548
2549    if {![string compare $avar $unset]} {
2550        # Do not change the variable currently unsetting
2551        # one of its elements.
2552        return
2553    }
2554
2555    variable ${name}::lock
2556    set lock 1 ; # Disable MatTraceIn [#532783]
2557
2558    upvar #0 $avar    array
2559    variable ${name}::data
2560    variable ${name}::link
2561
2562    set transpose $link($avar)
2563
2564    if {$transpose} {
2565        foreach {r c} [split $idx ,] break
2566    } else {
2567        foreach {c r} [split $idx ,] break
2568    }
2569
2570    if {$unset != {}} {
2571        # We are currently propagating the unset of an
2572        # element in a different linked array to this
2573        # array. We make sure that this is an unset too.
2574
2575        unset array($c,$r)
2576    } else {
2577        set array($c,$r) $data($idx)
2578    }
2579    set lock 0
2580    return
2581}
2582
2583# ::struct::matrix::SortMaxHeapify --
2584#
2585#       Helper for the 'sort' method. Performs the central algorithm
2586#       which converts the matrix into a heap, easily sortable.
2587#
2588# Arguments:
2589#       name    Matrix object which is sorted.
2590#       i       Index of the row/column currently being sorted.
2591#       key     Index of the column/row to sort the rows/columns by.
2592#       rowCol  Indicator if we are sorting rows ('r'), or columns ('c').
2593#       heapSize Number of rows/columns to sort.
2594#       rev     Boolean flag, set if sorting is done revers (-decreasing).
2595#
2596# Sideeffects:
2597#       Transforms the matrix into a heap of rows/columns,
2598#       swapping them around.
2599#
2600# Results:
2601#       None.
2602
2603proc ::struct::matrix::SortMaxHeapify {name i key rowCol heapSize {rev 0}} {
2604    # MAX-HEAPIFY, adapted by EAS from CLRS 6.2
2605    switch  $rowCol {
2606        r { set A [GetColumn $name $key] }
2607        c { set A [GetRow    $name $key] }
2608    }
2609    # Weird expressions below for clarity, as CLRS uses A[1...n]
2610    # format and TCL uses A[0...n-1]
2611    set left  [expr {int(2*($i+1)    -1)}]
2612    set right [expr {int(2*($i+1)+1  -1)}]
2613
2614    # left, right are tested as < rather than <= because they are
2615    # in A[0...n-1]
2616    if {
2617        $left < $heapSize &&
2618        ( !$rev && [lindex $A $left] > [lindex $A $i] ||
2619           $rev && [lindex $A $left] < [lindex $A $i] )
2620    } {
2621        set largest $left
2622    } else {
2623        set largest $i
2624    }
2625
2626    if {
2627        $right < $heapSize &&
2628        ( !$rev && [lindex $A $right] > [lindex $A $largest] ||
2629           $rev && [lindex $A $right] < [lindex $A $largest] )
2630    } {
2631        set largest $right
2632    }
2633
2634    if { $largest != $i } {
2635        switch $rowCol {
2636            r { SwapRows    $name $i $largest }
2637            c { SwapColumns $name $i $largest }
2638        }
2639        SortMaxHeapify $name $largest $key $rowCol $heapSize $rev
2640    }
2641    return
2642}
2643
2644# ::struct::matrix::CheckSerialization --
2645#
2646#       Validate the serialization of a matrix.
2647#
2648# Arguments:
2649#       ser     Serialization to validate.
2650#       rvar    Variable to store the number of rows into.
2651#       cvar    Variable to store the number of columns into.
2652#       dvar    Variable to store the matrix data into.
2653#
2654# Results:
2655#       none
2656
2657proc ::struct::matrix::CheckSerialization {ser rvar cvar dvar} {
2658    upvar 1 \
2659            $rvar   rows    \
2660            $cvar   columns \
2661            $dvar   data
2662
2663    # Overall length ok ?
2664    if {[llength $ser] != 3} {
2665        return -code error \
2666                "error in serialization: list length not 3."
2667    }
2668
2669    foreach {r c d} $ser break
2670
2671    # Check rows/columns information
2672
2673    if {![string is integer -strict $r] || ($r < 0)} {
2674        return -code error \
2675                "error in serialization: bad number of rows \"$r\"."
2676    }
2677    if {![string is integer -strict $c] || ($c < 0)} {
2678        return -code error \
2679                "error in serialization: bad number of columns \"$c\"."
2680    }
2681
2682    # Validate data against rows/columns. We can have less data than
2683    # rows or columns, the missing cells will be initialized to the
2684    # empty string. But too many is considered as a signal of
2685    # being something wrong.
2686
2687    if {[llength $d] > $r} {
2688        return -code error \
2689                "error in serialization: data for to many rows."       
2690    }
2691    foreach rv $d {
2692        if {[llength $rv] > $c} {
2693            return -code error \
2694                    "error in serialization: data for to many columns."
2695        }
2696    }
2697
2698    # Ok. The data is now ready for the caller.
2699
2700    set data    $d
2701    set rows    $r
2702    set columns $c
2703    return
2704}
2705
2706# ::struct::matrix::DeleteRows --
2707#
2708#       Deletes n rows from the bottom of the matrix.
2709#
2710# Arguments:
2711#       name    Name of the matrix.
2712#       n       The number of rows to delete (no greater than the number of rows).
2713#
2714# Results:
2715#       None.
2716
2717proc ::struct::matrix::DeleteRows {name n} {
2718    variable ${name}::data
2719    variable ${name}::rows
2720    variable ${name}::columns
2721    variable ${name}::colw
2722    variable ${name}::rowh
2723
2724    # Move all data from the higher rows down and then delete the
2725    # superfluous data in the old last row. Move the data in the
2726    # height cache too, take partial fill into account there too.
2727    # Invalidate the width cache for all columns.
2728
2729    set rowstart [expr {$rows - $n}]
2730
2731    for {set c 0} {$c < $columns} {incr c} {
2732        for {set r $rowstart} {$r < $rows} {incr r} {
2733            unset data($c,$r)
2734            catch {unset rowh($r)}
2735        }
2736        catch {unset colw($c)}
2737    }
2738    set rows $rowstart
2739    return
2740}
2741
2742# ::struct::matrix::DeleteColumns --
2743#
2744#       Deletes n columns from the right of the matrix.
2745#
2746# Arguments:
2747#       name    Name of the matrix.
2748#       n       The number of columns to delete.
2749#
2750# Results:
2751#       None.
2752
2753proc ::struct::matrix::DeleteColumns {name n} {
2754    variable ${name}::data
2755    variable ${name}::rows
2756    variable ${name}::columns
2757    variable ${name}::colw
2758    variable ${name}::rowh
2759
2760    # Move all data from the higher columns down and then delete the
2761    # superfluous data in the old last column. Move the data in the
2762    # width cache too, take partial fill into account there too.
2763    # Invalidate the height cache for all rows.
2764
2765    set colstart [expr {$columns - $n}]
2766
2767    for {set r 0} {$r < $rows} {incr r} {
2768        for {set c $colstart} {$c < $columns} {incr c} {
2769            unset data($c,$r)
2770            catch {unset colw($c)}
2771        }
2772        catch {unset rowh($r)}
2773    }
2774    set columns $colstart
2775    return
2776}
2777
2778
2779# ### ### ### ######### ######### #########
2780## Ready
2781
2782namespace eval ::struct {
2783    # Get 'matrix::matrix' into the general structure namespace.
2784    namespace import -force matrix::matrix
2785    namespace export matrix
2786}
2787package provide struct::matrix 2.0.1
Note: See TracBrowser for help on using the repository browser.