oasis-gui.tcl

Go to the documentation of this file.

/* !/bin/sh*/
/*  the next line restarts using wish\*/
exec wish "$0" "$@" 

if {![info exists vTcl(sourcing)]} {
    switch $tcl_platform(platform) {
    windows {
    }
    default {
        option add *Scrollbar.width 10
    }
    }
    
}
/* */
/*  Visual Tcl v1.51 Project*/
/* */

/* */
/*  VTCL LIBRARY PROCEDURES*/
/* */

if {![info exists vTcl(sourcing)]} {
ret  Window (type args) {
    global vTcl
    set cmd     [lindex $args 0]
    set name    [lindex $args 1]
    set newname [lindex $args 2]
    set rest    [lrange $args 3 end]
    if {$name == "" || $cmd == ""} { return }
    if {$newname == ""} { set newname $name }
    if {$name == "."} { wm withdraw $name; return }
    set exists [winfo exists $newname]
    switch $cmd {
        show {
            if {$exists} { wm deiconify $newname; return }
            if {[info procs vTclWindow(pre)$name] != ""} {
                eval "vTclWindow(pre)$name $newname $rest"
            }
            if {[info procs vTclWindow$name] != ""} {
                eval "vTclWindow$name $newname $rest"
            }
            if {[info procs vTclWindow(post)$name] != ""} {
                eval "vTclWindow(post)$name $newname $rest"
            }
        }
        hide    { if $exists {wm withdraw $newname; return} }
        iconify { if $exists {wm iconify $newname; return} }
        destroy { if $exists {destroy $newname; return} }
    }
}
}

if {![info exists vTcl(sourcing)]} {
namespace ::mclistbox {

ret  {::mclistbox::AdjustColumns} (type w , optional height ={)} {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    if {[string length $height] == 0} {
     height =  [winfo height $widgets(text)]
    }

    /*  resize the height of each column so it matches the height*/
    /*  of the text widget, minus a few pixels. */
    incr height -4
    foreach id $misc(columns) {
    $widgets(frame$id) configure -height $height
    }
    
    /*  if we have a fillcolumn, change its width accordingly*/
    if {$options(-fillcolumn) != ""} {

    /*  make sure the column has been defined. If not, bail (?)*/
    if {![info exists widgets(frame$options(-fillcolumn))]} {
        return
    }
     frame =  $widgets(frame$options(-fillcolumn))
     minwidth =  $misc(min-$frame)

    /*  compute current width of all columns*/
     colwidth =  0
     col =  0
    foreach id $misc(columns) {
        if {![ColumnIsHidden $w $id] && $id != $options(-fillcolumn)} {
        incr colwidth [winfo reqwidth $widgets(frame$id)]
        }
    }

    /*  this is just shorthand for later use...*/
     id =  $options(-fillcolumn)

    /*  compute optimal width*/
     optwidth =  [expr {[winfo width $widgets(text)] -  (2 * [$widgets(text) cget -padx])}]

    /*  compute the width of our fill column*/
     newwidth =  [expr {$optwidth - $colwidth}]

    if {$newwidth < $minwidth} {
         newwidth =  $minwidth
    }

    /*  adjust the width of our fill column frame*/
    $widgets(frame$id) configure -width $newwidth
        
    }
    InvalidateScrollbars $w
}

}

namespace ::mclistbox {

ret  {::mclistbox::Build} (type w , type args) {
    variable widgetOptions

    # create the namespace for this instance, and define a few
    # variables
    namespace eval ::mclistbox::$w {

    variable options
    variable widgets
    variable misc 
    }

    # this gives us access to the namespace variables within
    # this proc
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    # initially we start out with no columns
    set misc(columns) {}

    # this is our widget -- a frame of class Mclistbox. Naturally,
    # it will contain other widgets. We create it here because
    # we need it to be able to set our default options.
    set widgets(this)   [frame  $w -class Mclistbox -takefocus 1]

    # this defines all of the default options. We get the
    # values from the option database. Note that if an array
    # value is a list of length one it is an alias to another
    # option, so we just ignore it
    foreach name [array names widgetOptions] {
    if {[llength $widgetOptions($name)] == 1} continue
    set optName  [lindex $widgetOptions($name) 0]
    set optClass [lindex $widgetOptions($name) 1]
    set options($name) [option get $w $optName $optClass]
    }

    # now apply any of the options supplied on the command
    # line. This may overwrite our defaults, which is OK
    if {[llength $args] > 0} {
    array set options $args
    }
    
    # the columns all go into a text widget since it has the 
    # ability to scroll.
    set widgets(text) [text $w.text  -width 0  -height 0  -padx 0  -pady 0  -wrap none  -borderwidth 0  -highlightthickness 0  -takefocus 0  -cursor {}  ]

    $widgets(text) configure -state disabled

    # here's the tricky part (shhhh... don't tell anybody!)
    # we are going to create column that completely fills 
    # the base frame. We will use it to control the sizing
    # of the widget. The trick is, we'll pack it in the frame 
    # and then place the text widget over it so it is never
    # seen.

    set columnWidgets [NewColumn $w {__hidden__}]
    set widgets(hiddenFrame)   [lindex $columnWidgets 0]
    set widgets(hiddenListbox) [lindex $columnWidgets 1]
    set widgets(hiddenLabel)   [lindex $columnWidgets 2]

    # by default geometry propagation is turned off, but for this
    # super-secret widget we want it turned on. The idea is, we 
    # resize the listbox which resizes the frame which resizes the 
    # whole shibang.
    pack propagate $widgets(hiddenFrame) on

    pack $widgets(hiddenFrame) -side top -fill both -expand y
    place $widgets(text) -x 0 -y 0 -relwidth 1.0 -relheight 1.0
    raise $widgets(text)

    # we will later rename the frame's widget proc to be our
    # own custom widget proc. We need to keep track of this
    # new name, so we'll define and store it here...
    set widgets(frame) ::mclistbox::${w}::$w

    # this moves the original frame widget proc into our
    # namespace and gives it a handy name
    rename ::$w $widgets(frame)

    # now, create our widget proc. Obviously (?) it goes in
    # the global namespace. All mclistbox widgets will actually
    # share the same widget proc to cut down on the amount of
    # bloat. 
    proc ::$w {command args}  "eval ::mclistbox::WidgetProc {$w} \$command \$args"

    # ok, the thing exists... let's do a bit more configuration. 
    if {[catch "Configure $widgets(this) [array get options]" error]} {
    catch {destroy $w}
    }

    # and be prepared to handle selections.. (this, for -exportselection
    # support)
    selection handle $w [list ::mclistbox::SelectionHandler $w get]

    return $w
}

}

namespace ::mclistbox {

ret  {::mclistbox::Canonize} (type w , type object , type opt) {
    variable widgetOptions
    variable columnOptions
    variable widgetCommands
    variable columnCommands
    variable labelCommands

    switch $object {
    command {
        if {[lsearch -exact $widgetCommands $opt] >= 0} {
        return $opt
        }

        # command names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the columns in a temporary array so
        # we can use [array names]
        set list $widgetCommands
        foreach element $list {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }

    {label command} {
        if {[lsearch -exact $labelCommands $opt] >= 0} {
        return $opt
        }

        # command names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the columns in a temporary array so
        # we can use [array names]
        set list $labelCommands
        foreach element $list {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }

    {column command} {
        if {[lsearch -exact $columnCommands $opt] >= 0} {
        return $opt
        }

        # command names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the columns in a temporary array so
        # we can use [array names]
        set list $columnCommands
        foreach element $list {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }

    option {
            # JME : ajout pour Tk 8.5
            if {$opt == "-state"} {set opt "-relief"}
        if {[info exists widgetOptions($opt)]  && [llength $widgetOptions($opt)] == 3} {
        return $opt
        }
        set list [array names widgetOptions]
        set matches [array names widgetOptions ${opt}*]
    }

    {column option} {
        if {[info exists columnOptions($opt)]} {
        return $opt
        }
        set list [array names columnOptions]
        set matches [array names columnOptions ${opt}*]
    }

    column {
        upvar ::mclistbox::${w}::misc    misc

        if {[lsearch -exact $misc(columns) $opt] != -1} {
        return $opt
        }
        
        # column names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the columns in a temporary array so
        # we can use [array names]
        set list $misc(columns)
        foreach element $misc(columns) {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }
    }
    if {[llength $matches] == 0} {
    set choices [HumanizeList $list]
    return -code error "unknown $object \"$opt\"; must be one of $choices"

    } elseif {[llength $matches] == 1} {
    # deal with option aliases
    set opt [lindex $matches 0]
    switch $object {
        option {
        if {[llength $widgetOptions($opt)] == 1} {
            set opt $widgetOptions($opt)
        }
        }

        {column option} {
        if {[llength $columnOptions($opt)] == 1} {
            set opt $columnOptions($opt)
        }
        }
    }

    return $opt

    } else {
    set choices [HumanizeList $list]
    return -code error "ambiguous $object \"$opt\"; must be one of $choices"
    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::CheckColumnID} (type w , type id) {
    upvar ::mclistbox::${w}::misc    misc

    set id [::mclistbox::Canonize $w column $id]
    set index [lsearch -exact $misc(columns) $id]
    return $index
}

}

namespace ::mclistbox {

ret  {::mclistbox::Column-add} (type w , type args) {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    variable widgetOptions

    set id "column-[llength $misc(columns)]" ;# a suitable default

    # if the first argument doesn't have a "-" as the first
    # character, it is an id to associate with this column
    if {![string match {-*} [lindex $args 0]]} {
    # the first arg must be an id. 
    set id [lindex $args 0]
    set args [lrange $args 1 end]
    if {[lsearch -exact $misc(columns) $id] != -1} {
        return -code error "column \"$id\" already exists"
    }
    }

    # define some reasonable defaults, then add any specific
    # values supplied by the user
    set opts(-bitmap)     {}
    set opts(-image)      {}
    set opts(-visible)    1
    set opts(-resizable)  1
    set opts(-position)   "end"
    set opts(-width)      20
    set opts(-background) $options(-background)
    set opts(-foreground) $options(-foreground)
    set opts(-font)       $options(-font)
    set opts(-label)      $id

    if {[expr {[llength $args]%2}] == 1} {
    # hmmm. An odd number of elements in args
    # if the last item is a valid option we'll give a different
    # error than if its not
    set option [::mclistbox::Canonize $w "column option" [lindex $args end]]
    return -code error "value for \"[lindex $args end]\" missing"
    }
    array set opts $args

    # figure out if we have any data in the listbox yet; we'll need
    # this information in a minute...
    if {[llength $misc(columns)] > 0} {
    set col0 [lindex $misc(columns) 0]
    set existingRows [$widgets(listbox$col0) size]
    } else {
    set existingRows 0
    }

    # create the widget and assign the associated paths to our array
    set widgetlist [NewColumn $w $id]

    set widgets(frame$id)   [lindex $widgetlist 0]
    set widgets(listbox$id) [lindex $widgetlist 1]
    set widgets(label$id)   [lindex $widgetlist 2]
    
    # add this column to the list of known columns
    lappend misc(columns) $id

    # configure the options. As a side effect, it will be inserted
    # in the text widget
    eval ::mclistbox::Column-configure {$w} {$id} [array get opts]

    # now, if there is any data already in the listbox, we need to
    # add a corresponding number of blank items. At least, I *think*
    # that's the right thing to do.
    if {$existingRows > 0} {
    set blanks {}
    for {set i 0} {$i < $existingRows} {incr i} {
        lappend blanks {}
    }
    eval {$widgets(listbox$id)} insert end $blanks
    }

    InvalidateScrollbars $w
    return $id
}

}

namespace ::mclistbox {

ret  {::mclistbox::Column-configure} (type w , type id , type args) {
    variable widgetOptions
    variable columnOptions

    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    # bail if they gave us a bogus id
    set index [CheckColumnID $w $id]

    # define some shorthand
    set listbox $widgets(listbox$id)
    set frame   $widgets(frame$id)
    set label   $widgets(label$id)

    if {[llength $args] == 0} {
    # hmmm. User must be wanting all configuration information
    # note that if the value of an array element is of length
    # one it is an alias, which needs to be handled slightly
    # differently
    set results {}
    foreach opt [lsort [array names columnOptions]] {
        if {[llength $columnOptions($opt)] == 1} {
        set alias $columnOptions($opt)
        set optName $columnOptions($alias)
        lappend results [list $opt $optName]
        } else {
        set optName  [lindex $columnOptions($opt) 0]
        set optClass [lindex $columnOptions($opt) 1]
        set default [option get $frame $optName $optClass]
        lappend results [list $opt $optName $optClass  $default $options($id:$opt)]
        }
    }

    return $results


    } elseif {[llength $args] == 1} {

    # the user must be querying something... I need to get this
    # to return a bona fide list like the "real" configure 
    # command, but it's not a priority at the moment. I still
    # have to work on the option database support foo.
    set option [::mclistbox::Canonize $w "column option" [lindex $args 0]]

    set value $options($id:$option)
    set optName  [lindex $columnOptions($option) 0]
    set optClass [lindex $columnOptions($option) 1]
    set default  [option get $frame $optName $optClass]
    set results  [list $option $optName $optClass $default $value]
    return $results

    }

    # if we have an odd number of values, bail. 
    if {[expr {[llength $args]%2}] == 1} {
    # hmmm. An odd number of elements in args
    return -code error "value for \"[lindex $args end]\" missing"
    }
    
    # Great. An even number of options. Let's make sure they 
    # are all valid before we do anything. Note that Canonize
    # will generate an error if it finds a bogus option; otherwise
    # it returns the canonical option name
    foreach {name value} $args {
    set name [::mclistbox::Canonize $w "column option" $name]
    set opts($name) $value
    }

    # if we get to here, the user is wanting to set some options
    foreach option [array names opts] {
    set value $opts($option)
    set options($id:$option) $value

    switch -- $option {
        -label {
        $label configure -text $value
        }
        
        -image -
        -bitmap {
        $label configure $option $value
        }

        -width {
        set font [$listbox cget -font]
        set factor [font measure $options(-font) "0"]
        set width [expr {$value * $factor}]

        $widgets(frame$id) configure -width $width
        set misc(min-$widgets(frame$id)) $width
        AdjustColumns $w
        }
        -font -
        -foreground -
        -background {
        if {[string length $value] == 0} {set value $options($option)}
        $listbox configure $option $value
        }

        -labelrelief {
        $widgets(label$id) configure -relief $value
        }

        -resizable {
        if {[catch {
            if {$value} {
            set options($id:-resizable) 1
            } else {
            set options($id:-resizable) 0
            }
        } msg]} {
            return -code error "expected boolean but got \"$value\""
        }
        }

        -visible {
        if {[catch {
            if {$value} {
            set options($id:-visible) 1
            $widgets(text) configure -state normal
            $widgets(text) window configure 1.$index -window $frame
            $widgets(text) configure -state disabled

            } else {
            set options($id:-visible) 0
            $widgets(text) configure -state normal
            $widgets(text) window configure 1.$index -window {}
            $widgets(text) configure -state disabled
            }
            InvalidateScrollbars $w
        } msg]} {
            return -code error "expected boolean but got \"$value\""
        }

        }

        -position {
        if {[string compare $value "start"] == 0} {
            set position 0

        } elseif {[string compare $value "end"] == 0} {

            set position [expr {[llength $misc(columns)] -1}]
        } else {

            # ought to check for a legal value here, but I'm 
            # lazy
            set position $value
        }

        if {$position >= [llength $misc(columns)]} {
            set max [expr {[llength $misc(columns)] -1}]
            return -code error "bad position; must be in the range of 0-$max"
        }

        # rearrange misc(columns) to reflect the new ordering
        set current [lsearch -exact $misc(columns) $id]
        set misc(columns) [lreplace $misc(columns) $current $current]
        set misc(columns) [linsert $misc(columns) $position $id]
        
        set frame $widgets(frame$id)
        $widgets(text) configure -state normal
        $widgets(text) window create 1.$position  -window $frame -stretch 1
        $widgets(text) configure -state disabled
        }

    }
    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::ColumnIsHidden} (type w , type id) {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::misc    misc
    
    set retval 1
    set col [lsearch -exact $misc(columns) $id]

    if {$col != ""} {
    set index "1.$col"
    catch {
        set window [$widgets(text) window cget $index -window]
        if {[string length $window] > 0 && [winfo exists $window]} {
        set retval 0
        }
    }
    }
    return $retval
}

}

namespace ::mclistbox {

ret  {::mclistbox::Configure} (type w , type args) {
    variable widgetOptions

    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc
    
    if {[llength $args] == 0} {
    # hmmm. User must be wanting all configuration information
    # note that if the value of an array element is of length
    # one it is an alias, which needs to be handled slightly
    # differently
    set results {}
    foreach opt [lsort [array names widgetOptions]] {
        if {[llength $widgetOptions($opt)] == 1} {
        set alias $widgetOptions($opt)
        set optName $widgetOptions($alias)
        lappend results [list $opt $optName]
        } else {
        set optName  [lindex $widgetOptions($opt) 0]
        set optClass [lindex $widgetOptions($opt) 1]
        set default [option get $w $optName $optClass]
        lappend results [list $opt $optName $optClass  $default $options($opt)]
        }
    }

    return $results
    }
    
    # one argument means we are looking for configuration
    # information on a single option
    if {[llength $args] == 1} {
    set opt [::mclistbox::Canonize $w option [lindex $args 0]]

    set optName  [lindex $widgetOptions($opt) 0]
    set optClass [lindex $widgetOptions($opt) 1]
    set default [option get $w $optName $optClass]
    set results [list $opt $optName $optClass  $default $options($opt)]
    return $results
    }

    # if we have an odd number of values, bail. 
    if {[expr {[llength $args]%2}] == 1} {
    # hmmm. An odd number of elements in args
    return -code error "value for \"[lindex $args end]\" missing"
    }
    
    # Great. An even number of options. Let's make sure they 
    # are all valid before we do anything. Note that Canonize
    # will generate an error if it finds a bogus option; otherwise
    # it returns the canonical option name
    foreach {name value} $args {
    set name [::mclistbox::Canonize $w option $name]
    set opts($name) $value
    }

    # process all of the configuration options
    foreach option [array names opts] {

    set newValue $opts($option)
    if {[info exists options($option)]} {
        set oldValue $options($option)
#       set options($option) $newValue
    }

    switch -- $option {
        -exportselection {
        if {$newValue} {
            SelectionHandler $w own
            set options($option) 1
        } else {
            set options($option) 0
        }
        }

        -fillcolumn {
        # if the fill column changed, we need to adjust
        # the columns.
        AdjustColumns $w
        set options($option) $newValue
        }

        -takefocus {
        $widgets(frame) configure -takefocus $newValue
        set options($option) [$widgets(frame) cget $option]
        }

        -background {
        foreach id $misc(columns) {
            $widgets(listbox$id) configure -background $newValue
            $widgets(frame$id) configure   -background $newValue
        }
        $widgets(frame) configure -background $newValue

        $widgets(text) configure -background $newValue
        set options($option) [$widgets(frame) cget $option]
        }

        # { the following all must be applied to each listbox }
        -foreground -
        -font -
        -selectborderwidth -
        -selectforeground -
        -selectbackground -
        -setgrid {
        foreach id $misc(columns) {
            $widgets(listbox$id) configure $option $newValue
        }
        $widgets(hiddenListbox) configure $option $newValue
        set options($option) [$widgets(hiddenListbox) cget $option]
        }

        # { the following all must be applied to each listbox and frame }
        -cursor {
        foreach id $misc(columns) {
            $widgets(listbox$id) configure $option $newValue
            $widgets(frame$id) configure -cursor $newValue
        }

        # -cursor also needs to be applied to the 
        # frames of each column
        foreach id $misc(columns) {
            $widgets(frame$id) configure -cursor $newValue
        }

        $widgets(hiddenListbox) configure $option $newValue
        set options($option) [$widgets(hiddenListbox) cget $option]
        }

        # { this just requires to pack or unpack the labels }
        -labels {
        if {$newValue} {
            set newValue 1
            foreach id $misc(columns) {
            pack $widgets(label$id)  -side top -fill x -expand n  -before $widgets(listbox$id)
            }
            pack $widgets(hiddenLabel)  -side top -fill x -expand n  -before $widgets(hiddenListbox)

        } else {
            set newValue 
            foreach id $misc(columns) {
            pack forget $widgets(label$id)
            }
            pack forget $widgets(hiddenLabel)
        }
        set options($option) $newValue
        }

        -height {
        $widgets(hiddenListbox) configure -height $newValue
        InvalidateScrollbars $w
        set options($option) [$widgets(hiddenListbox) cget $option]
        }

        -width {
        if {$newValue == 0} {
            return -code error "a -width of zero is not supported. "
        }

        $widgets(hiddenListbox) configure -width $newValue
        InvalidateScrollbars $w
        set options($option) [$widgets(hiddenListbox) cget $option]
        }

        # { the following all must be applied to each column frame }
        -columnborderwidth -
        -columnrelief {
        regsub {column} $option {} listboxoption
        foreach id $misc(columns) {
            $widgets(listbox$id) configure $listboxoption $newValue
        }
        $widgets(hiddenListbox) configure $listboxoption $newValue
        set options($option) [$widgets(hiddenListbox) cget  $listboxoption]
        }

        -resizablecolumns {
        if {$newValue} {
            set options($option) 1
        } else {
            set options($option) 0
        }
        }
        
        # { the following all must be applied to each column header }
        -labelimage -
        -labelheight -
        -labelrelief -
        -labelfont -
        -labelanchor -
        -labelbackground -
        -labelforeground -
        -labelborderwidth {
        regsub {label} $option {} labeloption
        foreach id $misc(columns) {
            $widgets(label$id) configure $labeloption $newValue
        }
        $widgets(hiddenLabel) configure $labeloption $newValue
        set options($option) [$widgets(hiddenLabel) cget $labeloption]
        }

        # { the following apply only to the topmost frame}
        -borderwidth -
        -highlightthickness -
        -highlightcolor -
        -highlightbackground -
        -relief {
        $widgets(frame) configure $option $newValue
        set options($option) [$widgets(frame) cget $option]
        }

        -selectmode {
        set options($option) $newValue
        }

        -selectcommand {
        set options($option) $newValue
        }

        -xscrollcommand {
        InvalidateScrollbars $w
        set options($option) $newValue
        }

        -yscrollcommand {
        InvalidateScrollbars $w
        set options($option) $newValue
        }
    }
    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::DestroyHandler} (type w) {
    # kill off any idle event we might have pending
    if {[info exists ::mclistbox::${w}::misc(afterid)]} {
    catch {
        after cancel $::mclistbox::${w}::misc(afterid)
        unset ::mclistbox::${w}::misc(afterid)
    }
    }

    # if the widget actually being destroyed is of class Mclistbox,
    # crush the namespace and kill the proc. Get it? Crush. Kill. 
    # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it
    # brings tears to my eyes.
    if {[string compare [winfo class $w] "Mclistbox"] == 0} {
    namespace delete ::mclistbox::$w
    rename $w {}
    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::FindResizableNeighbor} (type w , type id , optional direction =right) {
    upvar ::mclistbox::${w}::widgets       widgets
    upvar ::mclistbox::${w}::options       options
    upvar ::mclistbox::${w}::misc          misc


    if {$direction == "right"} {
    set incr 1
    set stop [llength $misc(columns)]
    set start [expr {[lsearch -exact $misc(columns) $id] + 1}]
    } else {
    set incr -1
    set stop -1
    set start [expr {[lsearch -exact $misc(columns) $id] - 1}]
    } 

    for {set i $start} {$i != $stop} {incr i $incr} {
    set col [lindex $misc(columns) $i]
    if {![ColumnIsHidden $w $col] && $options($col:-resizable)} {
        return $col
    }
    }
    return ""
}

}

namespace ::mclistbox {

ret  {::mclistbox::HumanizeList} (type list) {
    if {[llength $list] == 1} {
    return [lindex $list 0]
    } else {
    set list [lsort $list]
    set secondToLast [expr {[llength $list] -2}]
    set most [lrange $list 0 $secondToLast]
    set last [lindex $list end]

    return "[join $most {, }] or $last"
    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::Init} () {
    variable widgetOptions
    variable columnOptions
    variable widgetCommands
    variable columnCommands
    variable labelCommands

    # here we match up command line options with option database names
    # and classes. As it turns out, this is a handy reference of all of the
    # available options. Note that if an item has a value with only one
    # item (like -bd, for example) it is a synonym and the value is the
    # actual item.

    array set widgetOptions [list  -background          {background          Background}  -bd                  -borderwidth  -bg                  -background  -borderwidth         {borderWidth         BorderWidth}  -columnbd            -columnborderwidth  -columnborderwidth   {columnBorderWidth   BorderWidth}  -columnrelief        {columnRelief        Relief}  -cursor              {cursor              Cursor}  -exportselection     {exportSelection     ExportSelection}  -fg                  -foreground  -fillcolumn          {fillColumn          FillColumn}  -font                {font                Font}  -foreground          {foreground          Foreground}  -height              {height              Height}  -highlightbackground {highlightBackground HighlightBackground}  -highlightcolor      {highlightColor      HighlightColor}  -highlightthickness  {highlightThickness  HighlightThickness}  -labelanchor         {labelAnchor         Anchor}  -labelbackground     {labelBackground     Background}  -labelbd             -labelborderwidth  -labelbg             -labelbackground  -labelborderwidth    {labelBorderWidth    BorderWidth}  -labelfg             -labelforeground  -labelfont           {labelFont           Font}  -labelforeground     {labelForeground     Foreground}  -labelheight         {labelHeight         Height}  -labelimage          {labelImage          Image}  -labelrelief         {labelRelief         Relief}  -labels              {labels              Labels}  -relief              {relief              Relief}  -resizablecolumns    {resizableColumns    ResizableColumns}  -selectbackground    {selectBackground    Foreground}  -selectborderwidth   {selectBorderWidth   BorderWidth}  -selectcommand       {selectCommand       Command}  -selectforeground    {selectForeground    Background}  -selectmode          {selectMode          SelectMode}  -setgrid             {setGrid             SetGrid}  -takefocus           {takeFocus           TakeFocus}  -width               {width               Width}  -xscrollcommand      {xScrollCommand      ScrollCommand}  -yscrollcommand      {yScrollCommand      ScrollCommand}  ]

    # and likewise for column-specific stuff. 
    array set columnOptions [list  -background         {background           Background}  -bitmap       {bitmap               Bitmap}  -font               {font                 Font}  -foreground         {foreground           Foreground}  -image              {image                Image}  -label         {label                Label}  -position           {position             Position}  -labelrelief        {labelrelief          Labelrelief}  -resizable          {resizable            Resizable}  -visible            {visible              Visible}  -width              {width                Width}  ]

    # this defines the valid widget commands. It's important to
    # list them here; we use this list to validate commands and
    # expand abbreviations.
    set widgetCommands [list  activate   bbox       cget     column    configure   curselection delete     get      index     insert  label        nearest    scan     see       selection   size         xview      yview
    ]

    set columnCommands [list add cget configure delete names nearest]
    set labelCommands  [list bind]

    ######################################################################
    #- this initializes the option database. Kinda gross, but it works
    #- (I think). 
    ######################################################################

    set packages [package names]

    # why check for the Tk package? This lets us be sourced into 
    # an interpreter that doesn't have Tk loaded, such as the slave
    # interpreter used by pkg_mkIndex. In theory it should have no
    # side effects when run 
    if {[lsearch -exact [package names] "Tk"] != -1} {

    # compute a widget name we can use to create a temporary widget
    set tmpWidget ".__tmp__"
    set count 0
    while {[winfo exists $tmpWidget] == 1} {
        set tmpWidget ".__tmp__$count"
        incr count
    }

    # steal options from the listbox
    # we want darn near all options, so we'll go ahead and do
    # them all. No harm done in adding the one or two that we
    # don't use.
    listbox $tmpWidget 
    foreach foo [$tmpWidget configure] {
        if {[llength $foo] == 5} {
        set option [lindex $foo 1]
        set value [lindex $foo 4]
        option add *Mclistbox.$option $value widgetDefault

        # these options also apply to the individual columns...
        if {[string compare $option "foreground"] == 0  || [string compare $option "background"] == 0  || [string compare $option "font"] == 0} {
            option add *Mclistbox*MclistboxColumn.$option $value  widgetDefault
        }
        }
    }
    destroy $tmpWidget

    # steal some options from label widgets; we only want a subset
    # so we'll use a slightly different method. No harm in *not*
    # adding in the one or two that we don't use... :-)
    label $tmpWidget
    foreach option [list Anchor Background Font  Foreground Height Image  ] {
        set values [$tmpWidget configure -[string tolower $option]]
        option add *Mclistbox.label$option [lindex $values 3]
    }
    destroy $tmpWidget

    # these are unique to us...
    option add *Mclistbox.columnBorderWidth   0      widgetDefault
    option add *Mclistbox.columnRelief        flat   widgetDefault
    option add *Mclistbox.labelBorderWidth    1      widgetDefault
    option add *Mclistbox.labelRelief         raised widgetDefault
    option add *Mclistbox.labels              1      widgetDefault
    option add *Mclistbox.resizableColumns    1      widgetDefault
    option add *Mclistbox.selectcommand       {}     widgetDefault
    option add *Mclistbox.fillcolumn          {}     widgetDefault

    # column options
    option add *Mclistbox*MclistboxColumn.visible       1      widgetDefault
    option add *Mclistbox*MclistboxColumn.resizable     1      widgetDefault
    option add *Mclistbox*MclistboxColumn.position      end    widgetDefault
    option add *Mclistbox*MclistboxColumn.label         ""     widgetDefault
    option add *Mclistbox*MclistboxColumn.width         0      widgetDefault
    option add *Mclistbox*MclistboxColumn.bitmap        ""     widgetDefault
    option add *Mclistbox*MclistboxColumn.image         ""     widgetDefault
    }

    ######################################################################
    # define the class bindings
    ######################################################################
    
    SetClassBindings
}

}

namespace ::mclistbox {

ret  {::mclistbox::Insert} (type w , type index , type arglist) {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    foreach list $arglist {
    # make sure we have enough elements for each column
    for {set i [llength $list]} {$i < [llength $misc(columns)]} {incr i} {
        lappend list {}
    }

    set column 0
    foreach id $misc(columns) {
        $widgets(listbox$id) insert $index [lindex $list $column]
        incr column
    }

    # we also want to add a bogus item to the hidden listbox. Why?
    # For standard listboxes, if you specify a height of zero the
    # listbox will resize to be just big enough to hold all the lines.
    # Since we use a hidden listbox to regulate the size of the widget
    # and we want this same behavior, this listbox needs the same number
    # of elements as the visible listboxes
    #
    # (NB: we might want to make this listbox contain the contents
    # of all columns as a properly formatted list; then the get 
    # command can query this listbox instead of having to query
    # each individual listbox. The disadvantage is that it doubles
    # the memory required to hold all the data)
    $widgets(hiddenListbox) insert $index "x"
    }
    return ""
}

}

namespace ::mclistbox {

ret  {::mclistbox::InvalidateScrollbars} (type w) {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    if {![info exists misc(afterid)]} {
    set misc(afterid)  [after idle "catch {::mclistbox::UpdateScrollbars $w}"]
    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::LabelEvent} (type w , type id , type code) {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options

    # only fire the binding if the cursor is our default cursor
    # (ie: if we aren't in a "resize zone")
    set cursor [$widgets(label$id) cget -cursor]
    if {[string compare $cursor $options(-cursor)] == 0} {
    uplevel \#0 $code
    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::MassageIndex} (type w , type index) {
    upvar ::mclistbox::${w}::widgets   widgets
    upvar ::mclistbox::${w}::misc      misc

    if {[regexp {@([0-9]+),([0-9]+)} $index matchvar x y]} {
    set id [lindex $misc(columns) 0]
    
    incr y -[winfo y $widgets(listbox$id)]
    incr y -[winfo y $widgets(frame$id)]
    incr x [winfo x $widgets(listbox$id)]
    incr x [winfo x $widgets(frame$id)]

    set index @${x},${y}
    }

    return $index
}

}

namespace ::mclistbox {

ret  {::mclistbox::NewColumn} (type w , type id) {
    upvar ::mclistbox::${w}::widgets   widgets
    upvar ::mclistbox::${w}::options   options
    upvar ::mclistbox::${w}::misc      misc
    upvar ::mclistbox::${w}::columnID  columnID

    # the columns are all children of the text widget we created... 
    set frame      [frame $w.frame$id  -takefocus 0  -highlightthickness 0  -class MclistboxColumn  -background $options(-background)  ]

    set listbox    [listbox $frame.listbox  -takefocus 0  -bd 0  -setgrid $options(-setgrid)  -exportselection false  -selectmode $options(-selectmode)  -highlightthickness 0  ]

    set label      [label $frame.label  -takefocus 0  -relief raised  -bd 1  -highlightthickness 0  ]

    # define mappings from widgets to columns
    set columnID($label) $id
    set columnID($frame) $id
    set columnID($listbox) $id

    # we're going to associate a new bindtag for the label to
    # handle our resize bindings. Why? We want the bindings to
    # be specific to this widget but we don't want to use the
    # widget name. If we use the widget name then the bindings
    # could get mixed up with user-supplied bindigs (via the 
    # "label bind" command). 
    set tag MclistboxLabel
    bindtags $label  [list MclistboxMouseBindings $label]

    # reconfigure the label based on global options
    foreach option [list bd image height relief font anchor  background foreground borderwidth] {
    if {[info exists options(-label$option)]  && $options(-label$option) != ""} {
        $label configure -$option $options(-label$option)
    }
    }

    # reconfigure the column based on global options
    foreach option [list borderwidth relief] {
    if {[info exists options(-column$option)]  && $options(-column$option) != ""} {
        $frame configure -$option $options(-column$option)
    }
    }

    # geometry propagation must be off so we can control the size
    # of the listbox by setting the size of the containing frame
    pack propagate $frame off

    pack $label   -side top -fill x -expand n
    pack $listbox -side top -fill both -expand y -pady 2

    # any events that happen in the listbox gets handled by the class
    # bindings. This has the unfortunate side effect 
    bindtags $listbox [list $w Mclistbox all]

    # return a list of the widgets we created.
    return [list $frame $listbox $label]
}

}

namespace ::mclistbox {

ret  {::mclistbox::ResizeEvent} (type w , type type , type widget , type x , type X , type Y) {
    upvar ::mclistbox::${w}::widgets       widgets
    upvar ::mclistbox::${w}::options       options
    upvar ::mclistbox::${w}::misc          misc
    upvar ::mclistbox::${w}::columnID      columnID

    # if the widget doesn't allow resizable cursors, there's
    # nothing here to do...
    if {!$options(-resizablecolumns)} {
    return
    }

    # this lets us keep track of some internal state while
    # the user is dragging the mouse
    variable drag

    # this lets us define a small window around the edges of
    # the column. 
    set threshold [expr {$options(-labelborderwidth) + 4}]

    # this is what we use for the "this is resizable" cursor
    set resizeCursor sb_h_double_arrow

    # if we aren't over an area that we care about, bail.
    if {![info exists columnID($widget)]} {
    return
    }

    # id refers to the column name
    set id $columnID($widget)

    switch $type {

    buttonpress {
        # we will do all the work of initiating a drag only if
        # the cursor is not the defined cursor. In theory this
        # will only be the case if the mouse moves over the area
        # in which a drag can happen.
        if {[$widgets(label$id) cget -cursor] == $resizeCursor} {
        if {$x <= $threshold} {
            set lid [::mclistbox::FindResizableNeighbor $w $id left]
            if {$lid == ""} return
            set drag(leftFrame)  $widgets(frame$lid)
            set drag(rightFrame) $widgets(frame$id)

            set drag(leftListbox)  $widgets(listbox$lid)
            set drag(rightListbox) $widgets(listbox$id)

        } else {
            set rid [::mclistbox::FindResizableNeighbor $w $id right]
            if {$rid == ""} return
            set drag(leftFrame)  $widgets(frame$id)
            set drag(rightFrame) $widgets(frame$rid)

            set drag(leftListbox)  $widgets(listbox$id)
            set drag(rightListbox) $widgets(listbox$rid)

        }
        

        set drag(leftWidth)  [winfo width $drag(leftFrame)]
        set drag(rightWidth) [winfo width $drag(rightFrame)]

        # it seems to be a fact that windows can never be 
        # less than one pixel wide. So subtract that one pixel
        # from our max deltas...
        set drag(maxDelta)   [expr {$drag(rightWidth) - 1}]
        set drag(minDelta)  -[expr {$drag(leftWidth) - 1}]

        set drag(x) $X
        }
    }

    motion {
        if {[info exists drag(x)]} {return}

        # this is just waaaaay too much work for a motion 
        # event, IMO.

        set resizable 0

        # is the column the user is over resizable?
        if {!$options($id:-resizable)} {return}

        # did the user click on the left of a column? 
        if {$x < $threshold} {
        set leftColumn [::mclistbox::FindResizableNeighbor $w $id left]
        if {$leftColumn != ""} {
            set resizable 1
        }

        } elseif {$x > [winfo width $widget] - $threshold} {
        set rightColumn [::mclistbox::FindResizableNeighbor $w $id  right]
        if {$rightColumn != ""} {
            set resizable 1
        }
        }

        # if it's resizable, change the cursor 
        set cursor [$widgets(label$id) cget -cursor]
        if {$resizable && $cursor != $resizeCursor} {
        $widgets(label$id) configure -cursor $resizeCursor

        } elseif {!$resizable && $cursor == $resizeCursor} {
        $widgets(label$id) configure -cursor $options(-cursor)
        }
    }

    drag {
        # if the state is set up, do the drag...
        if {[info exists drag(x)]} {

        set delta [expr {$X - $drag(x)}]
        if {$delta >= $drag(maxDelta)} {
            set delta $drag(maxDelta)

        } elseif {$delta <= $drag(minDelta)} {
            set delta $drag(minDelta)
        }

        set lwidth [expr {$drag(leftWidth) + $delta}]
        set rwidth [expr {$drag(rightWidth) - $delta}]

        $drag(leftFrame)   configure -width $lwidth
        $drag(rightFrame)  configure -width $rwidth

        }
    }

    buttonrelease {
        set fillColumnID $options(-fillcolumn)
        if {[info exists drag(x)] && $fillColumnID != {}} {
        set fillColumnFrame $widgets(frame$fillColumnID)
        if {[string compare $drag(leftFrame) $fillColumnFrame] == 0  || [string compare $drag(rightFrame) $fillColumnFrame] == 0} {
            set width [$fillColumnFrame cget -width]
            set misc(minFillColumnSize) $width
        }
        set misc(min-$drag(leftFrame))  [$drag(leftFrame) cget -width]
        set misc(min-$drag(rightFrame)) [$drag(rightFrame) cget -width]
        }

        # reset the state and the cursor
        catch {unset drag}
        $widgets(label$id) configure -cursor $options(-cursor)

    }
    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::SelectionHandler} (type w , type type , optional offset ={) {length {}}} {
    upvar ::mclistbox::${w}::options   options
    upvar ::mclistbox::${w}::misc      misc
    upvar ::mclistbox::${w}::widgets   widgets

    switch -exact $type {

    own {
        selection own  -command [list ::mclistbox::SelectionHandler $w lose]  -selection PRIMARY  $w
    }

    lose {
        if {$options(-exportselection)} {
        foreach id $misc(columns) {
            $widgets(listbox$id) selection clear 0 end
        }
        }
    }

    get {
         end =  [expr {$length + $off - 1}]

        set =  column [lindex $misc(columns) 0]
         curselection =  [$widgets(listbox$column) curselection]

        /*  this is really, really slow (relatively speaking).*/
        /*  but the only way I can think of to speed this up*/
        /*  is to duplicate all the data in our hidden listbox,*/
        /*  which I really don't want to do because of memory*/
        /*  considerations.*/
         data =  ""
        foreach index $curselection {
         rowdata =  [join [::mclistbox::WidgetProc-get $w $index]  "\t"]
        lappend data $rowdata
        }
         data =  [join $data "\n"]
        return [string range $data $off $end = ]
    }

    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::SetBindings} (type w) {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    # we must do this so that the columns fill the text widget in
    # the y direction
    bind $widgets(text) <Configure>  [list ::mclistbox::AdjustColumns $w %h]
}

}

namespace ::mclistbox {

ret  {::mclistbox::SetClassBindings} () {
    # this allows us to clean up some things when we go away
    bind Mclistbox <Destroy> [list ::mclistbox::DestroyHandler %W]

    # steal all of the standard listbox bindings. Note that if a user
    # clicks in a column, %W will return that column. This is bad,
    # so we have to make a substitution in all of the bindings to
    # compute the real widget name (ie: the name of the topmost 
    # frame)
    foreach event [bind Listbox] {
    set binding [bind Listbox $event]
    regsub -all {%W} $binding {[::mclistbox::convert %W -W]} binding
    regsub -all {%x} $binding {[::mclistbox::convert %W -x %x]} binding
    regsub -all {%y} $binding {[::mclistbox::convert %W -y %y]} binding
    bind Mclistbox $event $binding
    }

    # these define bindings for the column labels for resizing. Note
    # that we need both the name of this widget (calculated by $this)
    # as well as the specific widget that the event occured over.
    # Also note that $this is a constant string that gets evaluated
    # when the binding fires.
    # What a pain.
    set this {[::mclistbox::convert %W -W]}
    bind MclistboxMouseBindings <ButtonPress-1>  "::mclistbox::ResizeEvent $this buttonpress %W %x %X %Y"
    bind MclistboxMouseBindings <ButtonRelease-1>  "::mclistbox::ResizeEvent $this buttonrelease %W %x %X %Y"
    bind MclistboxMouseBindings <Enter>  "::mclistbox::ResizeEvent $this motion %W %x %X %Y"
    bind MclistboxMouseBindings <Motion>  "::mclistbox::ResizeEvent $this motion %W %x %X %Y"
    bind MclistboxMouseBindings <B1-Motion>  "::mclistbox::ResizeEvent $this drag %W %x %X %Y"
}

}

namespace ::mclistbox {

ret  {::mclistbox::UpdateScrollbars} (type w) {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    if {![winfo ismapped $w]} {
    catch {unset misc(afterid)}
    return
    }

    update idletasks
    if {[llength $misc(columns)] > 0} {
    if {[string length $options(-yscrollcommand)] != 0} {
        set col0 [lindex $misc(columns) 0]
        set yview [$widgets(listbox$col0) yview]
        eval $options(-yscrollcommand) $yview
    }

    if {[string length $options(-xscrollcommand)] != 0} {
        set col0 [lindex $misc(columns) 0]
        set xview [$widgets(text) xview]
        eval $options(-xscrollcommand) $xview
    }
    }
    catch {unset misc(afterid)}
}

}

namespace ::mclistbox {

ret  {::mclistbox::WidgetProc} (type w , type command , type args) {
    variable widgetOptions

    upvar ::mclistbox::${w}::widgets   widgets
    upvar ::mclistbox::${w}::options   options
    upvar ::mclistbox::${w}::misc      misc
    upvar ::mclistbox::${w}::columnID  columnID

    set command [::mclistbox::Canonize $w command $command]

    # some commands have subcommands. We'll check for that here 
    # and mung the command and args so that we can treat them as 
    # distinct commands in the following switch statement
    if {[string compare $command "column"] == 0} {
    set subcommand [::mclistbox::Canonize $w "column command"  [lindex $args 0]]
    set command "$command-$subcommand"
    set args [lrange $args 1 end]

    } elseif {[string compare $command "label"] == 0} {
    set subcommand [::mclistbox::Canonize $w "label command"  [lindex $args 0]]
    set command "$command-$subcommand"
    set args [lrange $args 1 end]
    }

    set result ""
    catch {unset priorSelection}

    # here we go. Error checking be damned!
    switch $command {
    xview {
        # note that at present, "xview <index>" is broken. I'm
        # not even sure how to do it. Unless I attach our hidden
        # listbox to the scrollbar and use it. Hmmm..... I'll
        # try that later. (FIXME)
        set result [eval {$widgets(text)} xview $args]
        InvalidateScrollbars $w
    }

    yview {
        if {[llength $args] == 0} {
        # length of zero means to fetch the yview; we can
        # get this from a single listbox
        set result [$widgets(hiddenListbox) yview]

        } else {

        # if it's one argument, it's an index. We'll pass that 
        # index through the index command to properly translate
        # @x,y indicies, and place the value back in args
        if {[llength $args] == 1} {
            set index [::mclistbox::MassageIndex $w [lindex $args 0]]
            set args [list $index]
        }

        # run the yview command on every column.
        foreach id $misc(columns) {
            eval {$widgets(listbox$id)} yview $args
        }
        eval {$widgets(hiddenListbox)} yview $args

        InvalidateScrollbars $w

        set result ""
        }
    }

    activate {
        if {[llength $args] != 1} {
        return -code error "wrong \# of args: should be $w activate index"
        }
        set index [::mclistbox::MassageIndex $w [lindex $args 0]]

        foreach id $misc(columns) {
        $widgets(listbox$id) activate $index
        }
        set result ""
    }

    bbox {
        if {[llength $args] != 1} {
        return -code error "wrong \# of args: should be $w bbox index"
        }
        # get a real index. This will adjust @x,y indicies
        # to account for the label, if any.
        set index [::mclistbox::MassageIndex $w [lindex $args 0]]

        set id [lindex $misc(columns) 0]

        # we can get the x, y, and height from the first 
        # column.
        set bbox [$widgets(listbox$id) bbox $index]
        if {[string length $bbox] == 0} {return ""}

        foreach {x y w h} $bbox {}
        
        # the x and y coordinates have to be adjusted for the
        # fact that the listbox is inside a frame, and the 
        # frame is inside a text widget. All of those add tiny
        # offsets. Feh.
        incr y [winfo y $widgets(listbox$id)]
        incr y [winfo y $widgets(frame$id)]
        incr x [winfo x $widgets(listbox$id)]
        incr x [winfo x $widgets(frame$id)]

        # we can get the width by looking at the relative x 
        # coordinate of the right edge of the last column
        set id [lindex $misc(columns) end]
        set w [expr {[winfo width $widgets(frame$id)] +  [winfo x $widgets(frame$id)]}]
        set bbox [list $x $y [expr {$x + $w}] $h]
        set result $bbox
    }

    label-bind {
        # we are just too clever for our own good. (that's a 
        # polite way of saying this is more complex than it
        # needs to be)

        set id [lindex $args 0]
        set index [CheckColumnID $w $id]

        set args [lrange $args 1 end]
        if {[llength $args] == 0} {
        set result [bind $widgets(label$id)]
        } else {

        # when we create a binding, we'll actually have the 
        # binding run our own command with the user's command
        # as an argument. This way we can do some sanity checks
        # before running the command. So, when querying a binding
        # we need to only return the user's code
        set sequence [lindex $args 0]
        if {[llength $args] == 1} {
            set result [lindex [bind $widgets(label$id) $sequence] end]
        } else {
        
            # replace %W with our toplevel frame, then
            # do the binding
            set code [lindex $args 1]
            regsub -all {%W} $code $w code
            
            set result [bind $widgets(label$id) $sequence  [list ::mclistbox::LabelEvent $w $id $code]]
        }
        }
    }

    column-add {
        eval ::mclistbox::Column-add {$w} $args
        AdjustColumns $w
        set result ""
    }

    column-delete {
        foreach id $args {
        set index [CheckColumnID $w $id]

        # remove the reference from our list of columns
        set misc(columns) [lreplace $misc(columns) $index $index]

        # whack the widget
        destroy $widgets(frame$id)

        # clear out references to the individual widgets
        unset widgets(frame$id)
        unset widgets(listbox$id)
        unset widgets(label$id)
        }
        InvalidateScrollbars $w
        set result ""
    }

    column-cget {
        if {[llength $args] != 2} {
        return -code error "wrong # of args: should be \"$w column cget name option\""
        }
        set id [::mclistbox::Canonize $w column [lindex $args 0]]
        set option [lindex $args 1]
        set data [::mclistbox::Column-configure $w $id $option]
        set result [lindex $data 4]
    }

    column-configure {
        set id [::mclistbox::Canonize $w column [lindex $args 0]]
        set args [lrange $args 1 end]
        set result [eval ::mclistbox::Column-configure {$w} {$id} $args]
    }

    column-names {
        if {[llength $args] != 0} {
        return -code error "wrong # of args: should be \"$w column names\""
        }
        set result $misc(columns)
    }

    column-nearest {
        if {[llength $args] != 1} {
        return -code error "wrong # of args: should be \"$w column nearest x\""
        }

        set x [lindex $args 0]
        set tmp [$widgets(text) index @$x,0]
        set tmp [split $tmp "."]
        set index [lindex $tmp 1]

        set result [lindex $misc(columns) $index]
    }

    cget {
        if {[llength $args] != 1} {
        return -code error "wrong # args: should be $w cget option"
        }
        set opt [::mclistbox::Canonize $w option [lindex $args 0]]

        set result $options($opt)
    }


    configure {
        set result [eval ::mclistbox::Configure {$w} $args]

    }

    curselection {
        set id [lindex $misc(columns) 0]
        set result [$widgets(listbox$id) curselection]
    }

    delete {
        if {[llength $args] < 1 || [llength $args] > 2} {
        return -code error "wrong \# of args: should be $w delete first ?last?"
        }

        # it's possible that the selection will change because
        # of something we do. So, grab the current selection before
        # we do anything. Just before returning we'll see if the
        # selection has changed. If so, we'll call our selectcommand
        if {$options(-selectcommand) != ""} {
        set col0 [lindex $misc(columns) 0]
        set priorSelection [$widgets(listbox$col0) curselection]
        }

        set index1 [::mclistbox::MassageIndex $w [lindex $args 0]]
        if {[llength $args] == 2} {
        set index2 [::mclistbox::MassageIndex $w [lindex $args 1]]
        } else {
        set index2 ""
        }

        # note we do an eval here to make index2 "disappear" if it
        # is set to an empty string.
        foreach id $misc(columns) {
        eval {$widgets(listbox$id)} delete $index1 $index2
        }
        eval {$widgets(hiddenListbox)} delete $index1 $index2

        InvalidateScrollbars $w

        set result ""
    }

    get {
        if {[llength $args] < 1 || [llength $args] > 2} {
        return -code error "wrong \# of args: should be $w get first ?last?"
        }
        set index1 [::mclistbox::MassageIndex $w [lindex $args 0]]
        if {[llength $args] == 2} {
        set index2 [::mclistbox::MassageIndex $w [lindex $args 1]]
        } else {
        set index2 ""
        }

        set result [eval ::mclistbox::WidgetProc-get {$w} $index1 $index2]

    }

    index {

        if {[llength $args] != 1} {
        return -code error "wrong \# of args: should be $w index index"
        }

        set index [::mclistbox::MassageIndex $w [lindex $args 0]]
        set id [lindex $misc(columns) 0]

        set result [$widgets(listbox$id) index $index]
    }

    insert {
        if {[llength $args] < 1} {
        return -code error "wrong \# of args: should be $w insert ?element  element...?"
        }

        # it's possible that the selection will change because
        # of something we do. So, grab the current selection before
        # we do anything. Just before returning we'll see if the
        # selection has changed. If so, we'll call our selectcommand
        if {$options(-selectcommand) != ""} {
        set col0 [lindex $misc(columns) 0]
        set priorSelection [$widgets(listbox$col0) curselection]
        }

        set index [::mclistbox::MassageIndex $w [lindex $args 0]]

        ::mclistbox::Insert $w $index [lrange $args 1 end]

        InvalidateScrollbars $w
        set result ""
    }

    nearest {
        if {[llength $args] != 1} {
        return -code error "wrong \# of args: should be $w nearest y"
        }

        # translate the y coordinate into listbox space
        set id [lindex $misc(columns) 0]
        set y [lindex $args 0]
        incr y -[winfo y $widgets(listbox$id)]
        incr y -[winfo y $widgets(frame$id)]

        set col0 [lindex $misc(columns) 0]

        set result [$widgets(listbox$col0) nearest $y]
    }

    scan {
        foreach {subcommand x y} $args {}
        switch $subcommand {
        mark {
            # we have to treat scrolling in x and y differently;
            # scrolling in the y direction affects listboxes and
            # scrolling in the x direction affects the text widget.
            # to facilitate that, we need to keep a local copy
            # of the scan mark.
            set misc(scanmarkx) $x
            set misc(scanmarky) $y
            
            # set the scan mark for each column
            foreach id $misc(columns) {
            $widgets(listbox$id) scan mark $x $y
            }

            # we can't use the x coordinate given us, since it 
            # is relative to whatever column we are over. So,
            # we'll just usr the results of [winfo pointerx].
            $widgets(text) scan mark [winfo pointerx $w]  $y
        }
        dragto {
            # we want the columns to only scan in the y direction,
            # so we'll force the x componant to remain constant
            foreach id $misc(columns) {
            $widgets(listbox$id) scan dragto $misc(scanmarkx) $y
            }

            # since the scan mark of the text widget was based
            # on the pointer location, so must be the x
            # coordinate to the dragto command. And since we
            # want the text widget to only scan in the x
            # direction, the y componant will remain constant
            $widgets(text) scan dragto  [winfo pointerx $w] $misc(scanmarky)

            # make sure the scrollbars reflect the changes.
            InvalidateScrollbars $w
        }

        set result ""
        }
    }

    see {
        if {[llength $args] != 1} {
        return -code error "wrong \# of args: should be $w see index"
        }
        set index [::mclistbox::MassageIndex $w [lindex $args 0]]

        foreach id $misc(columns) {
        $widgets(listbox$id) see $index
        }
        InvalidateScrollbars $w
        set result {}
    }

    selection {
        # it's possible that the selection will change because
        # of something we do. So, grab the current selection before
        # we do anything. Just before returning we'll see if the
        # selection has changed. If so, we'll call our selectcommand
        if {$options(-selectcommand) != ""} {
        set col0 [lindex $misc(columns) 0]
        set priorSelection [$widgets(listbox$col0) curselection]
        }

        set subcommand [lindex $args 0]
        set args [lrange $args 1 end]

        set prefix "wrong \# of args: should be $w"
        switch $subcommand {
        includes {
            if {[llength $args] != 1} {
            return -code error "$prefix selection $subcommand index"
            }
            set index [::mclistbox::MassageIndex $w [lindex $args 0]]
            set id [lindex $misc(columns) 0]
            set result [$widgets(listbox$id) selection includes $index]
        }

        set {
            switch [llength $args] {
            1 {
                set index1 [::mclistbox::MassageIndex $w  [lindex $args 0]]
                set index2 ""
            }
            2 {
                set index1 [::mclistbox::MassageIndex $w  [lindex $args 0]]
                set index2 [::mclistbox::MassageIndex $w  [lindex $args 1]]
            }
            default {
                return -code error "$prefix selection clear first ?last?"
            }
            }

            if {$options(-exportselection)} {
            SelectionHandler $w own
            }
            if {$index1 != ""} {
            foreach id $misc(columns) {
                eval {$widgets(listbox$id)} selection set  $index1 $index2
            }
            }

            set result ""
        }

        anchor {
            if {[llength $args] != 1} {
            return -code error "$prefix selection $subcommand index"
            }
            set index [::mclistbox::MassageIndex $w [lindex $args 0]]

            if {$options(-exportselection)} {
            SelectionHandler $w own
            }
            foreach id $misc(columns) {
            $widgets(listbox$id) selection anchor $index
            }
            set result ""
        }

        clear {
            switch [llength $args] {
            1 {
                set index1 [::mclistbox::MassageIndex $w  [lindex $args 0]]
                set index2 ""
            }
            2 {
                set index1 [::mclistbox::MassageIndex $w  [lindex $args 0]]
                set index2 [::mclistbox::MassageIndex $w  [lindex $args 1]]
            }
            default {
                return -code error "$prefix selection clear first ?last?"
            }
            }

            if {$options(-exportselection)} {
            SelectionHandler $w own
            }
            foreach id $misc(columns) {
            eval {$widgets(listbox$id)} selection clear  $index1 $index2
            }
            set result ""
        }
        }
    }

    size {
        set id [lindex $misc(columns) 0]
        set result [$widgets(listbox$id) size]
    }
    }

    # if the user has a selectcommand defined and the selection changed,
    # run the selectcommand
    if {[info exists priorSelection] && $options(-selectcommand) != ""} {
    set column [lindex $misc(columns) 0]
    set currentSelection [$widgets(listbox$column) curselection]
    if {[string compare $priorSelection $currentSelection] != 0} {
        # this logic keeps us from getting into some sort of
        # infinite loop of the selectcommand changes the selection
        # (not particularly well tested, but it seems like the
        # right thing to do...)
        if {![info exists misc(skipRecursiveCall)]} {
        set misc(skipRecursiveCall) 1
        uplevel \#0 $options(-selectcommand) $currentSelection
        catch {unset misc(skipRecursiveCall)}
        }
    }
    }

    return $result
}

}

namespace ::mclistbox {

ret  {::mclistbox::WidgetProc-get} (type w , type args) {
    upvar ::mclistbox::${w}::widgets widgets
    upvar ::mclistbox::${w}::options options
    upvar ::mclistbox::${w}::misc    misc

    set returnType "list"
    # the listbox "get" command returns different things
    # depending on whether it has one or two args. Internally
    # we *always* want a valid list, so we'll force a second
    # arg which in turn forces the listbox to return a list,
    # even if its a list of one element
    if {[llength $args] == 1} {
    lappend args [lindex $args 0]
    set returnType "listOfLists"
    }

    # get all the data from each column
    foreach id $misc(columns) {
    set data($id) [eval {$widgets(listbox$id)} get $args]
    }

    # now join the data together one row at a time. Ugh.
    set result {}
    set rows [llength $data($id)]
    for {set i 0} {$i < $rows} {incr i} {
    set this {}
    foreach column $misc(columns) {
        lappend this [lindex $data($column) $i]
    }
    lappend result $this
    }
    
    # now to unroll the list if necessary. If the user gave
    # us only one indicie we want to return a single list
    # of values. If they gave use two indicies we want to return
    # a list of lists.
    if {[string compare $returnType "list"] == 0} {
    return $result
    } else {
    return [lindex $result 0]
    }
}

}

namespace ::mclistbox {

ret  {::mclistbox::convert} (type w , type args) {
    set result {}
    if {![winfo exists $w]} {
    return -code error "window \"$w\" doesn't exist"
    }

    while {[llength $args] > 0} {
    set option [lindex $args 0]
    set args [lrange $args 1 end]

    switch -exact -- $option {
        -x {
        set value [lindex $args 0]
        set args [lrange $args 1 end]
        set win $w
        while {[winfo class $win] != "Mclistbox"} {
            incr value [winfo x $win]
            set win [winfo parent $win]
            if {$win == "."} break
        }
        lappend result $value
        }

        -y {
        set value [lindex $args 0]
        set args [lrange $args 1 end]
        set win $w
        while {[winfo class $win] != "Mclistbox"} {
            incr value [winfo y $win]
            set win [winfo parent $win]
            if {$win == "."} break
        }
        lappend result $value
        }

        -w -
        -W {
        set win $w
        while {[winfo class $win] != "Mclistbox"} {
            set win [winfo parent $win]
            if {$win == "."} break;
        }
        lappend result $win
        }
    }
    }
    return $result
}

}

namespace ::mclistbox {

ret  {::mclistbox::mclistbox} (type args) {
    variable widgetOptions

    # perform a one time initialization
    if {![info exists widgetOptions]} {
      __mclistbox_Setup
    Init
    }

    # make sure we at least have a widget name
    if {[llength $args] == 0} {
    return -code error "wrong # args: should be \"mclistbox pathName ?options?\""
    }

    # ... and make sure a widget doesn't already exist by that name
    if {[winfo exists [lindex $args 0]]} {
    return -code error "window name \"[lindex $args 0]\" already exists"
    }

    # and check that all of the args are valid
    foreach {name value} [lrange $args 1 end] {
    Canonize [lindex $args 0] option $name
    }

    # build it...
    set w [eval Build $args]

    # set some bindings...
    SetBindings $w

    # and we are done!
    return $w
}

}

ret  {__mclistbox_Setup} () {
    namespace eval ::mclistbox {

        # this is the public interface
        namespace export mclistbox

        # these contain references to available options
        variable widgetOptions
        variable columnOptions

        # these contain references to available commands and subcommands
        variable widgetCommands
        variable columnCommands
        variable labelCommands
    }
}

ret  {vTcl:DefineAlias} (type target , type alias , type widgetProc , type top_, type or_, type alias , type cmdalias) {
    global widget

    set widget($alias) $target
    set widget(rev,$target) $alias

    if {$cmdalias} {
        interp alias {} $alias {} $widgetProc $target
    }

    if {$top_or_alias != ""} {
        set widget($top_or_alias,$alias) $target

        if {$cmdalias} {
            interp alias {} $top_or_alias.$alias {} $widgetProc $target
        }
    }
}

ret  {vTcl:Toplevel:WidgetProc} (type w , type args) {
    if {[llength $args] == 0} {
        return -code error "wrong # args: should be \"$w option ?arg arg ...?\""
    }

    ## The first argument is a switch, they must be doing a configure.
    if {[string index $args 0] == "-"} {
        set command configure

        ## There's only one argument, must be a cget.
        if {[llength $args] == 1} {
            set command cget
        }
    } else {
        set command [lindex $args 0]
        set args [lrange $args 1 end]
    }

    switch -- $command {
        "hide" -
        "Hide" {
            Window hide $w
        }

        "show" -
        "Show" {
            Window show $w
        }

        "ShowModal" {
            Window show $w
            raise $w
            grab $w
            tkwait window $w
            grab release $w
        }

        default {
            eval $w $command $args
        }
    }
}

ret  {vTcl:WidgetProc} (type w , type args) {
    if {[llength $args] == 0} {
        return -code error "wrong # args: should be \"$w option ?arg arg ...?\""
    }

    ## The first argument is a switch, they must be doing a configure.
    if {[string index $args 0] == "-"} {
        set command configure

        ## There's only one argument, must be a cget.
        if {[llength $args] == 1} {
            set command cget
        }
    } else {
        set command [lindex $args 0]
        set args [lrange $args 1 end]
    }

    eval $w $command $args
}
}

if {[info exists vTcl(sourcing)]} {
ret  vTcl:project:info () {
    namespace eval ::widgets::.gui {
        array set save {}
    }
    namespace eval ::widgets::.gui.cpd17 {
        array set save {-background 1 -borderwidth 1 -height 1 -relief 1 -width 1}
    }
    namespace eval ::widgets::.gui.cpd17.01 {
        array set save {-anchor 1 -borderwidth 1 -font 1 -menu 1 -padx 1 -pady 1 -text 1 -underline 1 -width 1}
    }
    namespace eval ::widgets::.gui.cpd17.01.02 {
        array set save {-cursor 1 -tearoff 1}
    }
    namespace eval ::widgets::.gui.cpd17.settingbutton {
        array set save {-font 1 -menu 1 -padx 1 -pady 1 -text 1 -underline 1}
    }
    namespace eval ::widgets::.gui.cpd17.settingbutton.m {
        array set save {}
    }
    namespace eval ::widgets::.gui.pr {
        array set save {-borderwidth 1 -height 1 -relief 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.tools {
        array set save {-height 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.tools.infolabel {
        array set save {-anchor 1 -background 1 -borderwidth 1 -font 1 -relief 1 -text 1}
    }
    namespace eval ::widgets::.gui.pr.tools.resizescrl {
        array set save {-bigincrement 1 -borderwidth 1 -command 1 -from 1 -highlightthickness 1 -orient 1 -relief 1 -resolution 1 -showvalue 1 -sliderlength 1 -tickinterval 1 -to 1 -troughcolor 1 -variable 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe {
        array set save {-borderwidth 1 -height 1 -relief 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.toolsbox {
        array set save {-background 1 -height 1 -highlightbackground 1 -highlightcolor 1 -relief 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.toolsbox.fobt {
        array set save {-borderwidth 1 -command 1 -text 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.toolsbox.but34 {
        array set save {-command 1 -padx 1 -text 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.toolsbox.but35 {
        array set save {-command 1 -padx 1 -text 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.toolsbox.but32 {
        array set save {-anchor 1 -borderwidth 1 -command 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.entityframe {
        array set save {-borderwidth 1 -height 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.entityframe.comprb {
        array set save {-anchor 1 -borderwidth 1 -command 1 -font 1 -highlightthickness 1 -padx 1 -pady 1 -selectcolor 1 -text 1 -value 1 -variable 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.entityframe.ficrb {
        array set save {-anchor 1 -command 1 -font 1 -highlightthickness 1 -padx 1 -pady 1 -text 1 -value 1 -variable 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.entityframe.cnxrb {
        array set save {-anchor 1 -command 1 -font 1 -highlightthickness 1 -padx 1 -pady 1 -text 1 -value 1 -variable 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.entityframe.fieldsrb {
        array set save {-anchor 1 -command 1 -font 1 -highlightthickness 1 -padx 1 -pady 1 -text 1 -value 1 -variable 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.buttonfrc {
        array set save {-height 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.buttonfrc.editb {
        array set save {-command 1 -font 1 -padx 1 -pady 1 -text 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.buttonfrc.deleteb {
        array set save {-command 1 -font 1 -padx 1 -pady 1 -state 1 -text 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.cpd18 {
        array set save {-borderwidth 1 -height 1 -relief 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.cpd18.02 {
        array set save {-borderwidth 1 -command 1 -orient 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.cpd18.03 {
        array set save {-borderwidth 1 -command 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.toolframe.cpd18.01 {
        array set save {-background 1 -borderwidth 1 -font 1 -height 1 -labelanchor 1 -labelborderwidth 1 -labelrelief 1 -relief 1 -selectborderwidth 1 -selectmode 1 -width 1 -xscrollcommand 1 -yscrollcommand 1}
    }
    namespace eval ::widgets::.gui.pr.zoomframe {
        array set save {-height 1 -relief 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.zoomframe.viewframe {
        array set save {-borderwidth 1 -height 1 -relief 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.zoomframe.viewframe.viewcommcheck {
        array set save {-command 1 -font 1 -pady 1 -text 1 -variable 1}
    }
    namespace eval ::widgets::.gui.pr.zoomframe.zm {
        array set save {-borderwidth 1 -command 1 -padx 1 -pady 1 -relief 1 -text 1}
    }
    namespace eval ::widgets::.gui.pr.zoomframe.zp {
        array set save {-borderwidth 1 -command 1 -padx 1 -pady 1 -relief 1 -text 1}
    }
    namespace eval ::widgets::.gui.pr.cpd22 {
        array set save {-borderwidth 1 -height 1 -relief 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.cpd22.01 {
        array set save {-borderwidth 1 -command 1 -jump 1 -orient 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.cpd22.02 {
        array set save {-borderwidth 1 -command 1 -jump 1 -width 1}
    }
    namespace eval ::widgets::.gui.pr.cpd22.03 {
        array set save {-background 1 -borderwidth 1 -closeenough 1 -height 1 -relief 1 -scrollregion 1 -width 1 -xscrollcommand 1 -yscrollcommand 1}
    }
    namespace eval ::widgets::.ballon_object {
        array set save {-borderwidth 1}
    }
    namespace eval ::widgets::.ballon_object.text {
        array set save {-background 1 -font 1 -foreground 1}
    }
    namespace eval ::widgets_bindings {
        set tagslist {}
    }
}
}
/* */
/*  USER DEFINED PROCEDURES*/
/* */

namespace ::combobox {

ret  {::combobox::Build} (type w , type args) {
variable widgetOptions

    if {[winfo exists $w]} {
    error "window name \"$w\" already exists"
    }

    # create the namespace for this instance, and define a few
    # variables
    namespace eval ::combobox::$w {

    variable ignoreTrace 0
    variable oldFocus    {}
    variable oldGrab     {}
    variable oldValue    {}
    variable options
    variable this
    variable widgets

    set widgets(foo) foo  ;# coerce into an array
    set options(foo) foo  ;# coerce into an array

    unset widgets(foo)
    unset options(foo)
    }

    # import the widgets and options arrays into this proc so
    # we don't have to use fully qualified names, which is a
    # pain.
    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    # this is our widget -- a frame of class Combobox. Naturally,
    # it will contain other widgets. We create it here because
    # we need it in order to set some default options.
    set widgets(this)   [frame  $w -class Combobox -takefocus 0]
    set widgets(entry)  [entry  $w.entry -takefocus 1]
    set widgets(button) [label  $w.button -takefocus 0]

    # this defines all of the default options. We get the
    # values from the option database. Note that if an array
    # value is a list of length one it is an alias to another
    # option, so we just ignore it
    foreach name [array names widgetOptions] {
    if {[llength $widgetOptions($name)] == 1} continue

    set optName  [lindex $widgetOptions($name) 0]
    set optClass [lindex $widgetOptions($name) 1]

    set value [option get $w $optName $optClass]
    set options($name) $value
    }

    # a couple options aren't available in earlier versions of
    # tcl, so we'll set them to sane values. For that matter, if
    # they exist but are empty, set them to sane values.
    if {[string length $options(-disabledforeground)] == 0} {
        set options(-disabledforeground) $options(-foreground)
    }
    if {[string length $options(-disabledbackground)] == 0} {
        set options(-disabledbackground) $options(-background)
    }

    # if -value is set to null, we'll remove it from our
    # local array. The assumption is, if the user sets it from
    # the option database, they will set it to something other
    # than null (since it's impossible to determine the difference
    # between a null value and no value at all).
    if {[info exists options(-value)]  && [string length $options(-value)] == 0} {
    unset options(-value)
    }

    # we will later rename the frame's widget proc to be our
    # own custom widget proc. We need to keep track of this
    # new name, so we'll define and store it here...
    set widgets(frame) ::combobox::${w}::$w

    # gotta do this sooner or later. Might as well do it now
    pack $widgets(entry)  -side left  -fill both -expand yes
    pack $widgets(button) -side right -fill y    -expand no

    # I should probably do this in a catch, but for now it's
    # good enough... What it does, obviously, is put all of
    # the option/values pairs into an array. Make them easier
    # to handle later on...
    array set options $args

    # now, the dropdown list... the same renaming nonsense
    # must go on here as well...
    set widgets(dropdown)   [toplevel  $w.top]
    set widgets(listbox) [listbox   $w.top.list]
    set widgets(vsb)     [scrollbar $w.top.vsb]

    pack $widgets(listbox) -side left -fill both -expand y

    # fine tune the widgets based on the options (and a few
    # arbitrary values...)

    # NB: we are going to use the frame to handle the relief
    # of the widget as a whole, so the entry widget will be
    # flat. This makes the button which drops down the list
    # to appear "inside" the entry widget.

    $widgets(vsb) configure  -command "$widgets(listbox) yview"  -highlightthickness 0

    $widgets(button) configure  -highlightthickness 0  -borderwidth 1  -relief raised  -width [expr {[winfo reqwidth $widgets(vsb)] - 2}]

    $widgets(entry) configure  -borderwidth 0  -relief flat  -highlightthickness 0

    $widgets(dropdown) configure  -borderwidth 1  -relief sunken

    $widgets(listbox) configure  -selectmode browse  -background [$widgets(entry) cget -bg]  -yscrollcommand "$widgets(vsb) set"  -exportselection false  -borderwidth 0


#    trace variable ::combobox::${w}::entryTextVariable w  #        [list ::combobox::EntryTrace $w]
    
    # do some window management foo on the dropdown window
    wm overrideredirect $widgets(dropdown) 1
    wm transient        $widgets(dropdown) [winfo toplevel $w]
    wm group            $widgets(dropdown) [winfo parent $w]
    wm resizable        $widgets(dropdown) 0 0
    wm withdraw         $widgets(dropdown)

    # this moves the original frame widget proc into our
    # namespace and gives it a handy name
    rename ::$w $widgets(frame)

    # now, create our widget proc. Obviously (?) it goes in
    # the global namespace. All combobox widgets will actually
    # share the same widget proc to cut down on the amount of
    # bloat.
    proc ::$w {command args}  "eval ::combobox::WidgetProc $w \$command \$args"


    # ok, the thing exists... let's do a bit more configuration.
    if {[catch "::combobox::Configure [list $widgets(this)] [array get options]" error]} {
    catch {destroy $w}
    error "internal error: $error"
    }

    return ""
}

}

namespace ::combobox {

ret  {::combobox::CallCommand} (type w , type newValue) {
upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    # call the associated command, if defined and -commandstate is
    # set to "normal"
    if {$options(-commandstate) == "normal" &&  [string length $options(-command)] > 0} {
    set args [list $widgets(this) $newValue]
    uplevel \#0 $options(-command) $args
    }
}

}

namespace ::combobox {

ret  {::combobox::Canonize} (type w , type object , type opt) {
variable widgetOptions
    variable columnOptions
    variable widgetCommands
    variable listCommands
    variable scanCommands

    switch $object {
    command {
        if {[lsearch -exact $widgetCommands $opt] >= 0} {
        return $opt
        }

        # command names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the commands in a temporary array so
        # we can use [array names]
        set list $widgetCommands
        foreach element $list {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }

    {list command} {
        if {[lsearch -exact $listCommands $opt] >= 0} {
        return $opt
        }

        # command names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the commands in a temporary array so
        # we can use [array names]
        set list $listCommands
        foreach element $list {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }

    {scan command} {
        if {[lsearch -exact $scanCommands $opt] >= 0} {
        return $opt
        }

        # command names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the commands in a temporary array so
        # we can use [array names]
        set list $scanCommands
        foreach element $list {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }

    option {
        if {[info exists widgetOptions($opt)]  && [llength $widgetOptions($opt)] == 2} {
        return $opt
        }
        set list [array names widgetOptions]
        set matches [array names widgetOptions ${opt}*]
    }

    }

    if {[llength $matches] == 0} {
    set choices [HumanizeList $list]
    error "unknown $object \"$opt\"; must be one of $choices"

    } elseif {[llength $matches] == 1} {
    set opt [lindex $matches 0]

    # deal with option aliases
    switch $object {
        option {
        set opt [lindex $matches 0]
        if {[llength $widgetOptions($opt)] == 1} {
            set opt $widgetOptions($opt)
        }
        }
    }

    return $opt

    } else {
    set choices [HumanizeList $list]
    error "ambiguous $object \"$opt\"; must be one of $choices"
    }
}

}

namespace ::combobox {

ret  {::combobox::ComputeGeometry} (type w) {
upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    if {$options(-height) == 0 && $options(-maxheight) != "0"} {
    # if this is the case, count the items and see if
    # it exceeds our maxheight. If so, set the listbox
    # size to maxheight...
    set nitems [$widgets(listbox) size]
    if {$nitems > $options(-maxheight)} {
        # tweak the height of the listbox
        $widgets(listbox) configure -height $options(-maxheight)
    } else {
        # un-tweak the height of the listbox
        $widgets(listbox) configure -height 0
    }
    update idletasks
    }

    # compute height and width of the dropdown list
    set bd [$widgets(dropdown) cget -borderwidth]
    set height [expr {[winfo reqheight $widgets(dropdown)] + $bd + $bd}]
    if {[string length $options(-dropdownwidth)] == 0 ||
        $options(-dropdownwidth) == 0} {
        set width [winfo width $widgets(this)]
    } else {
        set m [font measure [$widgets(listbox) cget -font] "m"]
        set width [expr {$options(-dropdownwidth) * $m}]
    }

    # figure out where to place it on the screen, trying to take into
    # account we may be running under some virtual window manager
    set screenWidth  [winfo screenwidth $widgets(this)]
    set screenHeight [winfo screenheight $widgets(this)]
    set rootx        [winfo rootx $widgets(this)]
    set rooty        [winfo rooty $widgets(this)]
    set vrootx       [winfo vrootx $widgets(this)]
    set vrooty       [winfo vrooty $widgets(this)]

    # the x coordinate is simply the rootx of our widget, adjusted for
    # the virtual window. We won't worry about whether the window will
    # be offscreen to the left or right -- we want the illusion that it
    # is part of the entry widget, so if part of the entry widget is off-
    # screen, so will the list. If you want to change the behavior,
    # simply change the if statement... (and be sure to update this
    # comment!)
    set x  [expr {$rootx + $vrootx}]
    if {0} {
    set rightEdge [expr {$x + $width}]
    if {$rightEdge > $screenWidth} {
        set x [expr {$screenWidth - $width}]
    }
    if {$x < 0} {set x 0}
    }

    # the y coordinate is the rooty plus vrooty offset plus
    # the height of the static part of the widget plus 1 for a
    # tiny bit of visual separation...
    set y [expr {$rooty + $vrooty + [winfo reqheight $widgets(this)] + 1}]
    set bottomEdge [expr {$y + $height}]

    if {$bottomEdge >= $screenHeight} {
    # ok. Fine. Pop it up above the entry widget isntead of
    # below.
    set y [expr {($rooty - $height - 1) + $vrooty}]

    if {$y < 0} {
        # this means it extends beyond our screen. How annoying.
        # Now we'll try to be real clever and either pop it up or
        # down, depending on which way gives us the biggest list.
        # then, we'll trim the list to fit and force the use of
        # a scrollbar

        # (sadly, for windows users this measurement doesn't
        # take into consideration the height of the taskbar,
        # but don't blame me -- there isn't any way to detect
        # it or figure out its dimensions. The same probably
        # applies to any window manager with some magic windows
        # glued to the top or bottom of the screen)

        if {$rooty > [expr {$screenHeight / 2}]} {
        # we are in the lower half of the screen --
        # pop it up. Y is zero; that parts easy. The height
        # is simply the y coordinate of our widget, minus
        # a pixel for some visual separation. The y coordinate
        # will be the topof the screen.
        set y 1
        set height [expr {$rooty - 1 - $y}]

        } else {
        # we are in the upper half of the screen --
        # pop it down
        set y [expr {$rooty + $vrooty +  [winfo reqheight $widgets(this)] + 1}]
        set height [expr {$screenHeight - $y}]

        }

        # force a scrollbar
        HandleScrollbar $widgets(this) crop
    }   
    }

    if {$y < 0} {
    # hmmm. Bummer.
    set y 0
    set height $screenheight
    }

    set geometry [format "=%dx%d+%d+%d" $width $height $x $y]

    return $geometry
}

}

namespace ::combobox {

ret  {::combobox::Configure} (type w , type args) {
variable widgetOptions
    variable defaultEntryCursor

    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    if {[llength $args] == 0} {
    # hmmm. User must be wanting all configuration information
    # note that if the value of an array element is of length
    # one it is an alias, which needs to be handled slightly
    # differently
    set results {}
    foreach opt [lsort [array names widgetOptions]] {
        if {[llength $widgetOptions($opt)] == 1} {
        set alias $widgetOptions($opt)
        set optName $widgetOptions($alias)
        lappend results [list $opt $optName]
        } else {
        set optName  [lindex $widgetOptions($opt) 0]
        set optClass [lindex $widgetOptions($opt) 1]
        set default [option get $w $optName $optClass]
        if {[info exists options($opt)]} {
            lappend results [list $opt $optName $optClass  $default $options($opt)]
        } else {
            lappend results [list $opt $optName $optClass  $default ""]
        }
        }
    }

    return $results
    }

    # one argument means we are looking for configuration
    # information on a single option
    if {[llength $args] == 1} {
    set opt [::combobox::Canonize $w option [lindex $args 0]]

    set optName  [lindex $widgetOptions($opt) 0]
    set optClass [lindex $widgetOptions($opt) 1]
    set default [option get $w $optName $optClass]
    set results [list $opt $optName $optClass  $default $options($opt)]
    return $results
    }

    # if we have an odd number of values, bail.
    if {[expr {[llength $args]%2}] == 1} {
    # hmmm. An odd number of elements in args
    error "value for \"[lindex $args end]\" missing"
    }

    # Great. An even number of options. Let's make sure they
    # are all valid before we do anything. Note that Canonize
    # will generate an error if it finds a bogus option; otherwise
    # it returns the canonical option name
    foreach {name value} $args {
    set name [::combobox::Canonize $w option $name]
    set opts($name) $value
    }

    # process all of the configuration options
    # some (actually, most) options require us to
    # do something, like change the attributes of
    # a widget or two. Here's where we do that...
    #
    # note that the handling of disabledforeground and
    # disabledbackground is a little wonky. First, we have
    # to deal with backwards compatibility (ie: tk 8.3 and below
    # didn't have such options for the entry widget), and
    # we have to deal with the fact we might want to disable
    # the entry widget but use the normal foreground/background
    # for when the combobox is not disabled, but not editable either.

    set updateVisual 0
    foreach option [array names opts] {
    set newValue $opts($option)
    if {[info exists options($option)]} {
        set oldValue $options($option)
    }

    switch -- $option {
        -background {
        set updateVisual 1
        set options($option) $newValue
        }

        -borderwidth {
        $widgets(frame) configure -borderwidth $newValue
        set options($option) $newValue
        }

        -command {
        # nothing else to do...
        set options($option) $newValue
        }

        -commandstate {
        # do some value checking...
        if {$newValue != "normal" && $newValue != "disabled"} {
            set options($option) $oldValue
            set message "bad state value \"$newValue\";"
            append message " must be normal or disabled"
            error $message
        }
        set options($option) $newValue
        }

        -cursor {
        $widgets(frame) configure -cursor $newValue
        $widgets(entry) configure -cursor $newValue
        $widgets(listbox) configure -cursor $newValue
        set options($option) $newValue
        }

        -disabledforeground {
        set updateVisual 1
        set options($option) $newValue
        }

        -disabledbackground {
        set updateVisual 1
        set options($option) $newValue
        }

            -dropdownwidth {
                set options($option) $newValue
            }

        -editable {
        set updateVisual 1
        if {$newValue} {
            # it's editable...
            $widgets(entry) configure  -state normal  -cursor $defaultEntryCursor
        } else {
            $widgets(entry) configure  -state disabled  -cursor $options(-cursor)
        }
        set options($option) $newValue
        }

        -font {
        $widgets(entry) configure -font $newValue
        $widgets(listbox) configure -font $newValue
        set options($option) $newValue
        }

        -foreground {
        set updateVisual 1
        set options($option) $newValue
        }

        -height {
        $widgets(listbox) configure -height $newValue
        HandleScrollbar $w
        set options($option) $newValue
        }

        -highlightbackground {
        $widgets(frame) configure -highlightbackground $newValue
        set options($option) $newValue
        }

        -highlightcolor {
        $widgets(frame) configure -highlightcolor $newValue
        set options($option) $newValue
        }

        -highlightthickness {
        $widgets(frame) configure -highlightthickness $newValue
        set options($option) $newValue
        }
    
        -image {
        if {[string length $newValue] > 0} {
            $widgets(button) configure -image $newValue
        } else {
            $widgets(button) configure -image ::combobox::bimage
        }
        set options($option) $newValue
        }

        -maxheight {
        # ComputeGeometry may dork with the actual height
        # of the listbox, so let's undork it
        $widgets(listbox) configure -height $options(-height)
        HandleScrollbar $w
        set options($option) $newValue
        }

        -opencommand {
        # nothing else to do...
        set options($option) $newValue
        }

        -relief {
        $widgets(frame) configure -relief $newValue
        set options($option) $newValue
        }

        -selectbackground {
        $widgets(entry) configure -selectbackground $newValue
        $widgets(listbox) configure -selectbackground $newValue
        set options($option) $newValue
        }

        -selectborderwidth {
        $widgets(entry) configure -selectborderwidth $newValue
        $widgets(listbox) configure -selectborderwidth $newValue
        set options($option) $newValue
        }

        -selectforeground {
        $widgets(entry) configure -selectforeground $newValue
        $widgets(listbox) configure -selectforeground $newValue
        set options($option) $newValue
        }

        -state {
        if {$newValue == "normal"} {
            set updateVisual 1
            # it's enabled

            set editable [::combobox::GetBoolean  $options(-editable)]
            if {$editable} {
            $widgets(entry) configure -state normal
            $widgets(entry) configure -takefocus 1
            }

                    # note that $widgets(button) is actually a label,
                    # not a button. And being able to disable labels
                    # wasn't possible until tk 8.3. (makes me wonder
            # why I chose to use a label, but that answer is
            # lost to antiquity)
                    if {[info patchlevel] >= 8.3} {
                        $widgets(button) configure -state normal
                    }

        } elseif {$newValue == "disabled"}  {
            set updateVisual 1
            # it's disabled
            $widgets(entry) configure -state disabled
            $widgets(entry) configure -takefocus 0
                    # note that $widgets(button) is actually a label,
                    # not a button. And being able to disable labels
                    # wasn't possible until tk 8.3. (makes me wonder
            # why I chose to use a label, but that answer is
            # lost to antiquity)
                    if {$::tcl_version >= 8.3} {
                        $widgets(button) configure -state disabled
                    }

        } else {
            set options($option) $oldValue
            set message "bad state value \"$newValue\";"
            append message " must be normal or disabled"
            error $message
        }

        set options($option) $newValue
        }

        -takefocus {
        $widgets(entry) configure -takefocus $newValue
        set options($option) $newValue
        }

        -textvariable {
        $widgets(entry) configure -textvariable $newValue
        set options($option) $newValue
        }

        -value {
        ::combobox::SetValue $widgets(this) $newValue
        set options($option) $newValue
        }

        -width {
        $widgets(entry) configure -width $newValue
        $widgets(listbox) configure -width $newValue
        set options($option) $newValue
        }

        -xscrollcommand {
        $widgets(entry) configure -xscrollcommand $newValue
        set options($option) $newValue
        }
    }   

    if {$updateVisual} {UpdateVisualAttributes $w}
    }
}

}

namespace ::combobox {

ret  {::combobox::DestroyHandler} (type w) {
# if the widget actually being destroyed is of class Combobox,
    # crush the namespace and kill the proc. Get it? Crush. Kill.
    # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it
    # brings tears to my eyes.
    if {[string compare [winfo class $w] "Combobox"] == 0} {
    upvar ::combobox::${w}::widgets  widgets
    upvar ::combobox::${w}::options  options

    # delete the namespace and the proc which represents
    # our widget
    namespace delete ::combobox::$w
    rename $w {}
    }

    return ""
}

}

namespace ::combobox {

ret  {::combobox::DoInternalWidgetCommand} (type w , type subwidget , type command , type args) {
upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    set subcommand $command
    set command [concat $widgets($subwidget) $command $args]
    if {[catch $command result]} {
    # replace the subwidget name with the megawidget name
    regsub $widgets($subwidget) $result $widgets(this) result

    # replace specific instances of the subwidget command
    # with out megawidget command
    switch $subwidget,$subcommand {
        listbox,index  {regsub "index"  $result "list index"  result}
        listbox,insert {regsub "insert" $result "list insert" result}
        listbox,delete {regsub "delete" $result "list delete" result}
        listbox,get    {regsub "get"    $result "list get"    result}
        listbox,size   {regsub "size"   $result "list size"   result}
    }
    error $result

    } else {
    return $result
    }
}

}

namespace ::combobox {

ret  {::combobox::Find} (type w , optional exact =0) {
upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    ## *sigh* this logic is rather gross and convoluted. Surely
    ## there is a more simple, straight-forward way to implement
    ## all this. As the saying goes, I lack the time to make it
    ## shorter...

    # use what is already in the entry widget as a pattern
    set pattern [$widgets(entry) get]

    if {[string length $pattern] == 0} {
    # clear the current selection
    $widgets(listbox) see 0
    $widgets(listbox) selection clear 0 end
    $widgets(listbox) selection anchor 0
    $widgets(listbox) activate 0
    return
    }

    # we're going to be searching this list...
    set list [$widgets(listbox) get 0 end]

    # if we are doing an exact match, try to find,
    # well, an exact match
    set exactMatch -1
    if {$exact} {
    set exactMatch [lsearch -exact $list $pattern]
    }

    # search for it. We'll try to be clever and not only
    # search for a match for what they typed, but a match for
    # something close to what they typed. We'll keep removing one
    # character at a time from the pattern until we find a match
    # of some sort.
    set index -1
    while {$index == -1 && [string length $pattern]} {
    set index [lsearch -glob $list "$pattern*"]
    if {$index == -1} {
        regsub {.$} $pattern {} pattern
    }
    }

    # this is the item that most closely matches...
    set thisItem [lindex $list $index]

    # did we find a match? If so, do some additional munging...
    if {$index != -1} {

    # we need to find the part of the first item that is
    # unique WRT the second... I know there's probably a
    # simpler way to do this...

    set nextIndex [expr {$index + 1}]
    set nextItem [lindex $list $nextIndex]

    # we don't really need to do much if the next
    # item doesn't match our pattern...
    if {[string match $pattern* $nextItem]} {
        # ok, the next item matches our pattern, too
        # now the trick is to find the first character
        # where they *don't* match...
        set marker [string length $pattern]
        while {$marker <= [string length $pattern]} {
        set a [string index $thisItem $marker]
        set b [string index $nextItem $marker]
        if {[string compare $a $b] == 0} {
            append pattern $a
            incr marker
        } else {
            break
        }
        }
    } else {
        set marker [string length $pattern]
    }
    
    } else {
    set marker end
    set index 0
    }

    # ok, we know the pattern and what part is unique;
    # update the entry widget and listbox appropriately
    if {$exact && $exactMatch == -1} {
    # this means we didn't find an exact match
    $widgets(listbox) selection clear 0 end
    $widgets(listbox) see $index


    } elseif {!$exact}  {
    # this means we found something, but it isn't an exact
    # match. If we find something that *is* an exact match we
    # don't need to do the following, since it would merely
    # be replacing the data in the entry widget with itself
    set oldstate [$widgets(entry) cget -state]
    $widgets(entry) configure -state normal
    $widgets(entry) delete 0 end
    $widgets(entry) insert end $thisItem
    $widgets(entry) selection clear
    $widgets(entry) selection range $marker end
    $widgets(listbox) activate $index
    $widgets(listbox) selection clear 0 end
    $widgets(listbox) selection anchor $index
    $widgets(listbox) selection set $index
    $widgets(listbox) see $index
    $widgets(entry) configure -state $oldstate
    }
}

}

namespace ::combobox {

ret  {::combobox::GetBoolean} (type value , optional errorValue =1) {
if {[catch {expr {([string trim $value])?1:0}} res]} {
    return $errorValue
    } else {
    return $res
    }
}

}

namespace ::combobox {

ret  {::combobox::HandleEvent} (type w , type event , type args) {
upvar ::combobox::${w}::widgets  widgets
    upvar ::combobox::${w}::options  options
    upvar ::combobox::${w}::oldValue oldValue

    # for all of these events, if we have a special action we'll
    # do that and do a "return -code break" to keep additional
    # bindings from firing. Otherwise we'll let the event fall
    # on through.
    switch $event {

        "<MouseWheel>" {
        if {[winfo ismapped $widgets(dropdown)]} {
                set D [lindex $args 0]
                # the '120' number in the following expression has
                # it's genesis in the tk bind manpage, which suggests
                # that the smallest value of %D for mousewheel events
                # will be 120. The intent is to scroll one line at a time.
                $widgets(listbox) yview scroll [expr {-($D/120)}] units
            }
        }

    "<Any-KeyPress>" {
        # if the widget is editable, clear the selection.
        # this makes it more obvious what will happen if the
        # user presses <Return> (and helps our code know what
        # to do if the user presses return)
        if {$options(-editable)} {
        $widgets(listbox) see 0
        $widgets(listbox) selection clear 0 end
        $widgets(listbox) selection anchor 0
        $widgets(listbox) activate 0
        }
    }

    "<FocusIn>" {
        set oldValue [$widgets(entry) get]
    }

    "<FocusOut>" {
        if {![winfo ismapped $widgets(dropdown)]} {
        # did the value change?
        set newValue [$widgets(entry) get]
        if {$oldValue != $newValue} {
            CallCommand $widgets(this) $newValue
        }
        }
    }

    "<1>" {
        set editable [::combobox::GetBoolean $options(-editable)]
        if {!$editable} {
        if {[winfo ismapped $widgets(dropdown)]} {
            $widgets(this) close
            return -code break;

        } else {
            if {$options(-state) != "disabled"} {
            $widgets(this) open
            return -code break;
            }
        }
        }
    }

    "<Double-1>" {
        if {$options(-state) != "disabled"} {
        $widgets(this) toggle
        return -code break;
        }
    }

    "<Tab>" {
        if {[winfo ismapped $widgets(dropdown)]} {
        ::combobox::Find $widgets(this) 0
        return -code break;
        } else {
        ::combobox::SetValue $widgets(this) [$widgets(this) get]
        }
    }

    "<Escape>" {
#       $widgets(entry) delete 0 end
#       $widgets(entry) insert 0 $oldValue
        if {[winfo ismapped $widgets(dropdown)]} {
        $widgets(this) close
        return -code break;
        }
    }

    "<Return>" {
        # did the value change?
        set newValue [$widgets(entry) get]
        if {$oldValue != $newValue} {
        CallCommand $widgets(this) $newValue
        }

        if {[winfo ismapped $widgets(dropdown)]} {
        ::combobox::Select $widgets(this)  [$widgets(listbox) curselection]
        return -code break;
        }

    }

    "<Next>" {
        $widgets(listbox) yview scroll 1 pages
        set index [$widgets(listbox) index @0,0]
        $widgets(listbox) see $index
        $widgets(listbox) activate $index
        $widgets(listbox) selection clear 0 end
        $widgets(listbox) selection anchor $index
        $widgets(listbox) selection set $index

    }

    "<Prior>" {
        $widgets(listbox) yview scroll -1 pages
        set index [$widgets(listbox) index @0,0]
        $widgets(listbox) activate $index
        $widgets(listbox) see $index
        $widgets(listbox) selection clear 0 end
        $widgets(listbox) selection anchor $index
        $widgets(listbox) selection set $index
    }

    "<Down>" {
        if {[winfo ismapped $widgets(dropdown)]} {
        ::combobox::tkListboxUpDown $widgets(listbox) 1
        return -code break;

        } else {
        if {$options(-state) != "disabled"} {
            $widgets(this) open
            return -code break;
        }
        }
    }
    "<Up>" {
        if {[winfo ismapped $widgets(dropdown)]} {
        ::combobox::tkListboxUpDown $widgets(listbox) -1
        return -code break;

        } else {
        if {$options(-state) != "disabled"} {
            $widgets(this) open
            return -code break;
        }
        }
    }
    }

    return ""
}

}

namespace ::combobox {

ret  {::combobox::HandleScrollbar} (type w , optional action =unknown) {
upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    if {$options(-height) == 0} {
    set hlimit $options(-maxheight)
    } else {
    set hlimit $options(-height)
    }       

    switch $action {
    "grow" {
        if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} {
        pack $widgets(vsb) -side right -fill y -expand n
        }
    }

    "shrink" {
        if {$hlimit > 0 && [$widgets(listbox) size] <= $hlimit} {
        pack forget $widgets(vsb)
        }
    }

    "crop" {
        # this means the window was cropped and we definitely
        # need a scrollbar no matter what the user wants
        pack $widgets(vsb) -side right -fill y -expand n
    }

    default {
        if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} {
        pack $widgets(vsb) -side right -fill y -expand n
        } else {
        pack forget $widgets(vsb)
        }
    }
    }

    return ""
}

}

namespace ::combobox {

ret  {::combobox::HumanizeList} (type list) {
if {[llength $list] == 1} {
    return [lindex $list 0]
    } else {
    set list [lsort $list]
    set secondToLast [expr {[llength $list] -2}]
    set most [lrange $list 0 $secondToLast]
    set last [lindex $list end]

    return "[join $most {, }] or $last"
    }
}

}

namespace ::combobox {

ret  {::combobox::Init} () {
variable widgetOptions
    variable widgetCommands
    variable scanCommands
    variable listCommands
    variable defaultEntryCursor

    array set widgetOptions [list  -background          {background          Background}  -bd                  -borderwidth  -bg                  -background  -borderwidth         {borderWidth         BorderWidth}  -command             {command             Command}  -commandstate        {commandState        State}  -cursor              {cursor              Cursor}  -disabledbackground  {disabledBackground  DisabledBackground}  -disabledforeground  {disabledForeground  DisabledForeground}  -dropdownwidth       {dropdownWidth       DropdownWidth}  -editable            {editable            Editable}  -fg                  -foreground  -font                {font                Font}  -foreground          {foreground          Foreground}  -height              {height              Height}  -highlightbackground {highlightBackground HighlightBackground}  -highlightcolor      {highlightColor      HighlightColor}  -highlightthickness  {highlightThickness  HighlightThickness}  -image               {image               Image}  -maxheight           {maxHeight           Height}  -opencommand         {opencommand         Command}  -relief              {relief              Relief}  -selectbackground    {selectBackground    Foreground}  -selectborderwidth   {selectBorderWidth   BorderWidth}  -selectforeground    {selectForeground    Background}  -state               {state               State}  -takefocus           {takeFocus           TakeFocus}  -textvariable        {textVariable        Variable}  -value               {value               Value}  -width               {width               Width}  -xscrollcommand      {xScrollCommand      ScrollCommand}  ]


    set widgetCommands [list  bbox      cget     configure    curselection  delete    get      icursor      index         insert    list     scan         selection     xview     select   toggle       open          close      ]

    set listCommands [list  delete       get       index        insert       size  ]

    set scanCommands [list mark dragto]

    # why check for the Tk package? This lets us be sourced into
    # an interpreter that doesn't have Tk loaded, such as the slave
    # interpreter used by pkg_mkIndex. In theory it should have no
    # side effects when run
    if {[lsearch -exact [package names] "Tk"] != -1} {

    ##################################################################
    #- this initializes the option database. Kinda gross, but it works
    #- (I think).
    ##################################################################

    # the image used for the button...
    if {$::tcl_platform(platform) == "windows"} {
        image create bitmap ::combobox::bimage -data {
        #define down_arrow_width 12
        #define down_arrow_height 12
        static char down_arrow_bits[] = {
            0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
            0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0,
            0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00;
        }
        }
    } else {
        image create bitmap ::combobox::bimage -data  {
        #define down_arrow_width 15
        #define down_arrow_height 15
        static char down_arrow_bits[] = {
            0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80,
            0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83,
            0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80,
            0x00,0x80,0x00,0x80,0x00,0x80
        }
        }
    }

    # compute a widget name we can use to create a temporary widget
    set tmpWidget ".__tmp__"
    set count 0
    while {[winfo exists $tmpWidget] == 1} {
        set tmpWidget ".__tmp__$count"
        incr count
    }

    # get the scrollbar width. Because we try to be clever and draw our
    # own button instead of using a tk widget, we need to know what size
    # button to create. This little hack tells us the width of a scroll
    # bar.
    #
    # NB: we need to be sure and pick a window  that doesn't already
    # exist...
    scrollbar $tmpWidget
    set sb_width [winfo reqwidth $tmpWidget]
    destroy $tmpWidget

    # steal options from the entry widget
    # we want darn near all options, so we'll go ahead and do
    # them all. No harm done in adding the one or two that we
    # don't use.
    entry $tmpWidget
    foreach foo [$tmpWidget configure] {
        # the cursor option is special, so we'll save it in
        # a special way
        if {[lindex $foo 0] == "-cursor"} {
        set defaultEntryCursor [lindex $foo 4]
        }
        if {[llength $foo] == 5} {
        set option [lindex $foo 1]
        set value [lindex $foo 4]
        option add *Combobox.$option $value widgetDefault

        # these options also apply to the dropdown listbox
        if {[string compare $option "foreground"] == 0  || [string compare $option "background"] == 0  || [string compare $option "font"] == 0} {
            option add *Combobox*ComboboxListbox.$option $value  widgetDefault
        }
        }
    }
    destroy $tmpWidget

    # these are unique to us...
    option add *Combobox.dropdownWidth       {}     widgetDefault
    option add *Combobox.openCommand         {}     widgetDefault
    option add *Combobox.cursor              {}     widgetDefault
    option add *Combobox.commandState        normal widgetDefault
    option add *Combobox.editable            1      widgetDefault
    option add *Combobox.maxHeight           10     widgetDefault
    option add *Combobox.height              0
    }

    # set class bindings
    SetClassBindings
}

}

namespace ::combobox {

ret  {::combobox::Select} (type w , type index) {
upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    # the catch is because I'm sloppy -- presumably, the only time
    # an error will be caught is if there is no selection.
    if {![catch {set data [$widgets(listbox) get [lindex $index 0]]}]} {
    ::combobox::SetValue $widgets(this) $data

    $widgets(listbox) selection clear 0 end
    $widgets(listbox) selection anchor $index
    $widgets(listbox) selection set $index

    }
    $widgets(entry) selection range 0 end

    $widgets(this) close

    return ""
}

}

namespace ::combobox {

ret  {::combobox::SetBindings} (type w) {
upvar ::combobox::${w}::widgets  widgets
    upvar ::combobox::${w}::options  options

    # juggle the bindtags. The basic idea here is to associate the
    # widget name with the entry widget, so if a user does a bind
    # on the combobox it will get handled properly since it is
    # the entry widget that has keyboard focus.
    bindtags $widgets(entry)  [concat $widgets(this) [bindtags $widgets(entry)]]

    bindtags $widgets(button)  [concat $widgets(this) [bindtags $widgets(button)]]

    # override the default bindings for tab and shift-tab. The
    # focus procs take a widget as their only parameter and we
    # want to make sure the right window gets used (for shift-
    # tab we want it to appear as if the event was generated
    # on the frame rather than the entry.
    bind $widgets(entry) <Tab>  "::combobox::tkTabToWindow \[tk_focusNext $widgets(entry)\]; break"
    bind $widgets(entry) <Shift-Tab>  "::combobox::tkTabToWindow \[tk_focusPrev $widgets(this)\]; break"

    # this makes our "button" (which is actually a label)
    # do the right thing
    bind $widgets(button) <ButtonPress-1> [list $widgets(this) toggle]

    # this lets the autoscan of the listbox work, even if they
    # move the cursor over the entry widget.
    bind $widgets(entry) <B1-Enter> "break"

    bind $widgets(listbox) <ButtonRelease-1>  "::combobox::Select [list $widgets(this)]  \[$widgets(listbox) nearest %y\]; break"

    bind $widgets(vsb) <ButtonPress-1>   {continue}
    bind $widgets(vsb) <ButtonRelease-1> {continue}

    bind $widgets(listbox) <Any-Motion> {
    %W selection clear 0 end
    %W activate @%x,%y
    %W selection anchor @%x,%y
    %W selection set @%x,%y @%x,%y
    # need to do a yview if the cursor goes off the top
    # or bottom of the window... (or do we?)
    }

    # these events need to be passed from the entry widget
    # to the listbox, or otherwise need some sort of special
    # handling.
    foreach event [list <Up> <Down> <Tab> <Return> <Escape>  <Next> <Prior> <Double-1> <1> <Any-KeyPress>  <FocusIn> <FocusOut>] {
    bind $widgets(entry) $event  [list ::combobox::HandleEvent $widgets(this) $event]
    }

    # like the other events, <MouseWheel> needs to be passed from
    # the entry widget to the listbox. However, in this case we
    # need to add an additional parameter
    catch {
    bind $widgets(entry) <MouseWheel>  [list ::combobox::HandleEvent $widgets(this) <MouseWheel> %D]
    }
}

}

namespace ::combobox {

ret  {::combobox::SetClassBindings} () {
# make sure we clean up after ourselves...
    bind Combobox <Destroy> [list ::combobox::DestroyHandler %W]

    # this will (hopefully) close (and lose the grab on) the
    # listbox if the user clicks anywhere outside of it. Note
    # that on Windows, you can click on some other app and
    # the listbox will still be there, because tcl won't see
    # that button click
    set this {[::combobox::convert %W -W]}
    bind Combobox <Any-ButtonPress>   "$this close"
    bind Combobox <Any-ButtonRelease> "$this close"

    # this helps (but doesn't fully solve) focus issues. The general
    # idea is, whenever the frame gets focus it gets passed on to
    # the entry widget
    bind Combobox <FocusIn> {::combobox::tkTabToWindow [::combobox::convert %W -W].entry}

    # this closes the listbox if we get hidden
    bind Combobox <Unmap> {[::combobox::convert %W -W] close}

    return ""
}

}

namespace ::combobox {

ret  {::combobox::SetValue} (type w , type newValue) {
upvar ::combobox::${w}::widgets     widgets
    upvar ::combobox::${w}::options     options
    upvar ::combobox::${w}::ignoreTrace ignoreTrace
    upvar ::combobox::${w}::oldValue    oldValue

    if {[info exists options(-textvariable)]  && [string length $options(-textvariable)] > 0} {
    set variable ::$options(-textvariable)
    set $variable $newValue
    } else {
    set oldstate [$widgets(entry) cget -state]
    $widgets(entry) configure -state normal
    $widgets(entry) delete 0 end
    $widgets(entry) insert 0 $newValue
    $widgets(entry) configure -state $oldstate
    }

    # set our internal textvariable; this will cause any public
    # textvariable (ie: defined by the user) to be updated as
    # well
#    set ::combobox::${w}::entryTextVariable $newValue

    # redefine our concept of the "old value". Do it before running
    # any associated command so we can be sure it happens even
    # if the command somehow fails.
    set oldValue $newValue


    # call the associated command. The proc will handle whether or
    # not to actually call it, and with what args
    CallCommand $w $newValue

    return ""
}

}

namespace ::combobox {

ret  {::combobox::UpdateVisualAttributes} (type w) {
upvar ::combobox::${w}::widgets     widgets
    upvar ::combobox::${w}::options     options

    if {$options(-state) == "normal"} {

    set foreground $options(-foreground)
    set background $options(-background)
    
    } elseif {$options(-state) == "disabled"} {

    set foreground $options(-disabledforeground)
    set background $options(-disabledbackground)
    }

    $widgets(entry)   configure -foreground $foreground -background $background
    $widgets(listbox) configure -foreground $foreground -background $background
    $widgets(button)  configure -foreground $foreground
    $widgets(vsb)     configure -background $background -troughcolor $background
    $widgets(frame)   configure -background $background

    # we need to set the disabled colors in case our widget is disabled.
    # We could actually check for disabled-ness, but we also need to
    # check whether we're enabled but not editable, in which case the
    # entry widget is disabled but we still want the enabled colors. It's
    # easier just to set everything and be done with it.

    if {$::tcl_version >= 8.4} {
    $widgets(entry) configure  -disabledforeground $foreground  -disabledbackground $background
    $widgets(button)  configure -disabledforeground $foreground
    $widgets(listbox) configure -disabledforeground $foreground
    }
}

}

namespace ::combobox {

ret  {::combobox::WidgetProc} (type w , type command , type args) {
upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options
    upvar ::combobox::${w}::oldFocus oldFocus
    upvar ::combobox::${w}::oldFocus oldGrab

    set command [::combobox::Canonize $w command $command]

    # this is just shorthand notation...
    set doWidgetCommand  [list ::combobox::DoInternalWidgetCommand $widgets(this)]

    if {$command == "list"} {
    # ok, the next argument is a list command; we'll
    # rip it from args and append it to command to
    # create a unique internal command
    #
    # NB: because of the sloppy way we are doing this,
    # we'll also let the user enter our secret command
    # directly (eg: listinsert, listdelete), but we
    # won't document that fact
    set command "list-[lindex $args 0]"
    set args [lrange $args 1 end]
    }

    set result ""

    # many of these commands are just synonyms for specific
    # commands in one of the subwidgets. We'll get them out
    # of the way first, then do the custom commands.
    switch $command {
    bbox -
    delete -
    get -
    icursor -
    index -
    insert -
    scan -
    selection -
    xview {
        set result [eval $doWidgetCommand entry $command $args]
    }
    list-get    {set result [eval $doWidgetCommand listbox get $args]}
    list-index  {set result [eval $doWidgetCommand listbox index $args]}
    list-size   {set result [eval $doWidgetCommand listbox size $args]}

    select {
        if {[llength $args] == 1} {
        set index [lindex $args 0]
        set result [Select $widgets(this) $index]
        } else {
        error "usage: $w select index"
        }
    }

    subwidget {
        set knownWidgets [list button entry listbox dropdown vsb]
        if {[llength $args] == 0} {
        return $knownWidgets
        }

        set name [lindex $args 0]
        if {[lsearch $knownWidgets $name] != -1} {
        set result $widgets($name)
        } else {
        error "unknown subwidget $name"
        }
    }

    curselection {
        set result [eval $doWidgetCommand listbox curselection]
    }

    list-insert {
        eval $doWidgetCommand listbox insert $args
        set result [HandleScrollbar $w "grow"]
    }

    list-delete {
        eval $doWidgetCommand listbox delete $args
        set result [HandleScrollbar $w "shrink"]
    }

    toggle {
        # ignore this command if the widget is disabled...
        if {$options(-state) == "disabled"} return

        # pops down the list if it is not, hides it
        # if it is...
        if {[winfo ismapped $widgets(dropdown)]} {
        set result [$widgets(this) close]
        } else {
        set result [$widgets(this) open]
        }
    }

    open {

        # if this is an editable combobox, the focus should
        # be set to the entry widget
        if {$options(-editable)} {
        focus $widgets(entry)
        $widgets(entry) select range 0 end
        $widgets(entry) icur end
        }

        # if we are disabled, we won't allow this to happen
        if {$options(-state) == "disabled"} {
        return 0
        }

        # if there is a -opencommand, execute it now
        if {[string length $options(-opencommand)] > 0} {
        # hmmm... should I do a catch, or just let the normal
        # error handling handle any errors? For now, the latter...
        uplevel \#0 $options(-opencommand)
        }

        # compute the geometry of the window to pop up, and set
        # it, and force the window manager to take notice
        # (even if it is not presently visible).
        #
        # this isn't strictly necessary if the window is already
        # mapped, but we'll go ahead and set the geometry here
        # since its harmless and *may* actually reset the geometry
        # to something better in some weird case.
        set geometry [::combobox::ComputeGeometry $widgets(this)]
        wm geometry $widgets(dropdown) $geometry
        update idletasks

        # if we are already open, there's nothing else to do
        if {[winfo ismapped $widgets(dropdown)]} {
        return 0
        }

        # save the widget that currently has the focus; we'll restore
        # the focus there when we're done
        set oldFocus [focus]

        # ok, tweak the visual appearance of things and
        # make the list pop up
        $widgets(button) configure -relief sunken
        raise $widgets(dropdown) [winfo parent $widgets(this)]
        wm deiconify $widgets(dropdown)
        raise $widgets(dropdown)

        # force focus to the entry widget so we can handle keypress
        # events for traversal
        focus -force $widgets(entry)

        # select something by default, but only if its an
        # exact match...
        ::combobox::Find $widgets(this) 1

        # save the current grab state for the display containing
        # this widget. We'll restore it when we close the dropdown
        # list
        set status "none"
        set grab [grab current $widgets(this)]
        if {$grab != ""} {set status [grab status $grab]}
        set oldGrab [list $grab $status]
        unset grab status

        # *gasp* do a global grab!!! Mom always told me not to
        # do things like this, but sometimes a man's gotta do
        # what a man's gotta do.
        grab -global $widgets(this)

        # fake the listbox into thinking it has focus. This is
        # necessary to get scanning initialized properly in the
        # listbox.
        event generate $widgets(listbox) <B1-Enter>

        return 1
    }

    close {
        # if we are already closed, don't do anything...
        if {![winfo ismapped $widgets(dropdown)]} {
        return 0
        }

        # restore the focus and grab, but ignore any errors...
        # we're going to be paranoid and release the grab before
        # trying to set any other grab because we really really
        # really want to make sure the grab is released.
        catch {focus $oldFocus} result
        catch {grab release $widgets(this)}
        catch {
        set status [lindex $oldGrab 1]
        if {$status == "global"} {
            grab -global [lindex $oldGrab 0]
        } elseif {$status == "local"} {
            grab [lindex $oldGrab 0]
        }
        unset status
        }

        # hides the listbox
        $widgets(button) configure -relief raised
        wm withdraw $widgets(dropdown)

        # select the data in the entry widget. Not sure
        # why, other than observation seems to suggest that's
        # what windows widgets do.
        set editable [::combobox::GetBoolean $options(-editable)]
        if {$editable} {
        $widgets(entry) selection range 0 end
        $widgets(button) configure -relief raised
        }


        # magic tcl stuff (see tk.tcl in the distribution
        # lib directory)
        ::combobox::tkCancelRepeat

        return 1
    }

    cget {
        if {[llength $args] != 1} {
        error "wrong # args: should be $w cget option"
        }
        set opt [::combobox::Canonize $w option [lindex $args 0]]

        if {$opt == "-value"} {
        set result [$widgets(entry) get]
        } else {
        set result $options($opt)
        }
    }

    configure {
        set result [eval ::combobox::Configure {$w} $args]
    }

    default {
        error "bad option \"$command\""
    }
    }

    return $result
}

}

namespace ::combobox {

ret  {::combobox::combobox} (type w , type args) {
variable widgetOptions
    variable widgetCommands
    variable scanCommands
    variable listCommands

    # perform a one time initialization
    if {![info exists widgetOptions]} {
    Init
    }

    # build it...
    eval Build $w $args

    # set some bindings...
    SetBindings $w

    # and we are done!
    return $w
}

}

namespace ::combobox {

ret  {::combobox::convert} (type w , type args) {
set result {}
    if {![winfo exists $w]} {
    error "window \"$w\" doesn't exist"
    }

    while {[llength $args] > 0} {
    set option [lindex $args 0]
    set args [lrange $args 1 end]

    switch -exact -- $option {
        -x {
        set value [lindex $args 0]
        set args [lrange $args 1 end]
        set win $w
        while {[winfo class $win] != "Combobox"} {
            incr value [winfo x $win]
            set win [winfo parent $win]
            if {$win == "."} break
        }
        lappend result $value
        }

        -y {
        set value [lindex $args 0]
        set args [lrange $args 1 end]
        set win $w
        while {[winfo class $win] != "Combobox"} {
            incr value [winfo y $win]
            set win [winfo parent $win]
            if {$win == "."} break
        }
        lappend result $value
        }

        -w -
        -W {
        set win $w
        while {[winfo class $win] != "Combobox"} {
            set win [winfo parent $win]
            if {$win == "."} break;
        }
        lappend result $win
        }
    }
    }
    return $result
}

}

namespace ::dom::libxml2 {

ret  {::dom::libxml2::parse} (type xml , type args) {
array set options {
    -keep normal
    -retainpath /*
    }
    array set options $args

    if {[catch {eval ::xml::parser -parser libxml2 [array get options]} parser]} {
    return -code error "unable to create XML parser due to \"$parser\""
    }

    if {[catch {$parser parse $xml} msg]} {
    return -code error $msg
    }

    set doc [$parser get document]
    set dom [dom::libxml2::adoptdocument $doc]
    $parser free

    return $dom
}

}

namespace ::dom {

ret  {::dom::parse} (type xml , type args) {
return [eval ::dom::libxml2::parse [list $xml] $args]
}

}

namespace ::sgml {

ret  {::sgml::Boolean} (type value) {
regsub {1|true|yes|on} $value 1 value
    regsub {0|false|no|off} $value 0 value
    return $value
}

}

namespace ::sgml {

ret  {::sgml::CModelMakeSyntaxTree} (type state , type spec) {
upvar #0 $state var
    variable Wsp
    variable name

    # Translate the spec into a Tcl list.

    # none of the Tcl special characters are allowed in a content model spec.
    if {[regexp {\$|\[|\]|\{|\}} $spec]} {
    return -code error "illegal characters in specification"
    }

    regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
    regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
    regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec

    array set var {stack {} state start}
    eval $spec

    # Peel off the outer seq, its redundant
    return [lindex [lindex $var(stack) 1] 0]
}

}

namespace ::sgml {

ret  {::sgml::CModelMakeTransitionTable} (type state , type st) {
upvar #0 $state var

    # Construct nullable, firstpos and lastpos functions
    array set var {number 0}
    foreach {nullable firstpos lastpos} [    TraverseDepth1st $state $st {
        # Evaluated for leaf nodes
        # Compute nullable(n)
        # Compute firstpos(n)
        # Compute lastpos(n)
        set nullable [nullable leaf $rep $name]
        set firstpos [list {} $var(number)]
        set lastpos [list {} $var(number)]
        set var(pos:$var(number)) $name
    } {
        # Evaluated for nonterminal nodes
        # Compute nullable, firstpos, lastpos
        set firstpos [firstpos $cs $firstpos $nullable]
        set lastpos  [lastpos  $cs $lastpos  $nullable]
        set nullable [nullable nonterm $rep $cs $nullable]
    }    ] break

    set accepting [incr var(number)]
    set var(pos:$accepting) #

    # var(pos:N) maps from position to symbol.
    # Construct reverse map for convenience.
    # NB. A symbol may appear in more than one position.
    # var is about to be reset, so use different arrays.

    foreach {pos symbol} [array get var pos:*] {
    set pos [lindex [split $pos :] 1]
    set pos2symbol($pos) $symbol
    lappend sym2pos($symbol) $pos
    }

    # Construct the followpos functions
    catch {unset var}
    followpos $state $st $firstpos $lastpos

    # Construct transition table
    # Dstates is [union $marked $unmarked]
    set unmarked [list [lindex $firstpos 1]]
    while {[llength $unmarked]} {
    set T [lindex $unmarked 0]
    lappend marked $T
    set unmarked [lrange $unmarked 1 end]

    # Find which input symbols occur in T
    set symbols {}
    foreach pos $T {
        if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
        lappend symbols $pos2symbol($pos)
        }
    }
    foreach a $symbols {
        set U {}
        foreach pos $sym2pos($a) {
        if {[lsearch $T $pos] >= 0} {
            # add followpos($pos)
                if {$var($pos) == {}} {
                    lappend U $accepting
                } else {
                    eval lappend U $var($pos)
                }
        }
        }
        set U [makeSet $U]
        if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
        lappend unmarked $U
        }
        set Dtran($T,$a) $U
    }
    
    }

    return [list [array get Dtran] [array get sym2pos] $accepting]
}

}

namespace ::sgml {

ret  {::sgml::CModelParse} (type state , type value) {
upvar #0 $state var

    # First build syntax tree
    set syntaxTree [CModelMakeSyntaxTree $state $value]

    # Build transition table
    set transitionTable [CModelMakeTransitionTable $state $syntaxTree]

    return [list $syntaxTree $transitionTable]
}

}

namespace ::sgml {

ret  {::sgml::CModelSTcloseParen} (type state , type rep , type cs , type args) {
upvar #0 $state var

    if {[llength $args]} {
    return -code error "syntax error in specification: \"$args\""
    }

    set cp [lindex $var(stack) end]
    set var(stack) [lreplace $var(stack) end end]
    set var(state) [lreplace $var(state) end end]
    CModelSTcp $state $cp $rep $cs
}

}

namespace ::sgml {

ret  {::sgml::CModelSTcp} (type state , type cp , type rep , type cs) {
upvar #0 $state var

    switch -glob -- [lindex $var(state) end]=$cs {
    start= {
        set var(state) [lreplace $var(state) end end end]
        # Add (dummy) grouping, either choice or sequence will do
        CModelSTcsSet $state ,
        CModelSTcpAdd $state $cp $rep
    }
    :choice= -
    :seq= {
        set var(state) [lreplace $var(state) end end end]
        CModelSTcpAdd $state $cp $rep
    }
    start=| -
    start=, {
        set var(state) [lreplace $var(state) end end [expr {$cs == "," ? ":seq" : ":choice"}]]
        CModelSTcsSet $state $cs
        CModelSTcpAdd $state $cp $rep
    }
    :choice=| -
    :seq=, {
        CModelSTcpAdd $state $cp $rep
    }
    :choice=, -
    :seq=| {
        return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs == "," ? "|" : ","}]\""
    }
    end=* {
        return -code error "syntax error in specification: no delimiter before \"$cp\""
    }
    default {
        return -code error "syntax error"
    }
    }
}

}

namespace ::sgml {

ret  {::sgml::CModelSTcpAdd} (type state , type cp , type rep) {
upvar #0 $state var

    if {[llength $var(stack)]} {
    set top [lindex $var(stack) end]
        lappend top [list $rep $cp]
    set var(stack) [lreplace $var(stack) end end $top]
    } else {
    set var(stack) [list $rep $cp]
    }
}

}

namespace ::sgml {

ret  {::sgml::CModelSTcsSet} (type state , type cs) {
upvar #0 $state var

    set cs [expr {$cs == "," ? ":seq" : ":choice"}]

    if {[llength $var(stack)]} {
    set var(stack) [lreplace $var(stack) end end $cs]
    } else {
    set var(stack) [list $cs {}]
    }
}

}

namespace ::sgml {

ret  {::sgml::CModelSTname} (type state , type name , type rep , type cs , type args) {
if {[llength $args]} {
    return -code error "syntax error in specification: \"$args\""
    }

    CModelSTcp $state $name $rep $cs
}

}

namespace ::sgml {

ret  {::sgml::CModelSTopenParen} (type state , type args) {
upvar #0 $state var

    if {[llength $args]} {
    return -code error "syntax error in specification: \"$args\""
    }

    lappend var(state) start
    lappend var(stack) [list {} {}]
}

}

namespace ::sgml {

ret  {::sgml::DTD:ATTLIST} (type opts , type name , type attspec) {
variable attlist_exp
    variable attlist_enum_exp
    variable attlist_fixed_exp

    array set options $opts

    # Parse the attribute list.  If it were regular, could just use foreach,
    # but some attributes may have values.
    regsub -all {([][$\\])} $attspec {\\\1} attspec
    regsub -all $attlist_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {} \{" attspec
    regsub -all $attlist_enum_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {} {\\4} \{" attspec
    regsub -all $attlist_fixed_exp $attspec "\}\nDTDAttribute {$options(-attlistdeclcommand)} $name $options(attlistdecls) {\\1} {\\2} {\\3} {\\4} \{" attspec

    eval "noop \{$attspec\}"

    return {}
}

}

namespace ::sgml {

ret  {::sgml::DTD:ELEMENT} (type opts , type name , type modspec) {
variable Wsp
    array set options $opts

    upvar #0 $options(elementdecls) elements

    if {$options(-validate) && [info exists elements($name)]} {
    eval $options(-errorcommand) [list elementdeclared "element \"$name\" already declared"]
    } else {
    switch -- $modspec {
        EMPTY {
            set elements($name) {}
        uplevel #0 $options(-elementdeclcommand) $name {{}}
        }
        ANY {
            set elements($name) *
        uplevel #0 $options(-elementdeclcommand) $name *
        }
        default {
        # Don't parse the content model for now,
        # just pass the model to the application
        if {0 && [regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
            set cm($name) [list MIXED [split $mtoks |]]
        } elseif {0} {
            if {[catch {CModelParse $state(state) $value} result]} {
            eval $options(-errorcommand) [list element? $result]
            } else {
            set cm($id) [list ELEMENT $result]
            }
        } else {
            set elements($name) $modspec
            uplevel #0 $options(-elementdeclcommand) $name [list $modspec]
        }
        }
    }
    }
}

}

namespace ::sgml {

ret  {::sgml::DTD:ENTITY} (type opts , type name , type param , type value) {
array set options $opts

    if {[string compare % $param]} {
    # Entity declaration - general or external
    upvar #0 $options(entities) ents
    upvar #0 $options(extentities) externals

    if {[info exists ents($name)] || [info exists externals($name)]} {
        eval $options(-warningcommand) entity [list "entity \"$name\" already declared"]
    } else {
        if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
        return -code error "unable to parse entity declaration due to \"$value\""
        }
        switch -glob [lindex $value 0],[lindex $value 3] {
        internal, {
            set ents($name) [EntitySubst [array get options] [lindex $value 1]]
            uplevel #0 $options(-entitydeclcommand) [list $name $ents($name)]
        }
        internal,* {
            return -code error "unexpected NDATA declaration"
        }
        external, {
            set externals($name) [lrange $value 1 2]
            uplevel #0 $options(-entitydeclcommand) [eval list $name [lrange $value 1 2]]
        }
        external,* {
            set externals($name) [lrange $value 1 3]
            uplevel #0 $options(-unparsedentitydeclcommand) [eval list $name [lrange $value 1 3]]
        }
        default {
            return -code error "internal error: unexpected parser state"
        }
        }
    }
    } else {
    # Parameter entity declaration
    upvar #0 $options(parameterentities) PEnts
    upvar #0 $options(externalparameterentities) ExtPEnts

    if {[info exists PEnts($name)] || [info exists ExtPEnts($name)]} {
        eval $options(-warningcommand) parameterentity [list "parameter entity \"$name\" already declared"]
    } else {
        if {[catch {uplevel #0 $options(-parseentitydeclcommand) [list $value]} value]} {
        return -code error "unable to parse parameter entity declaration due to \"$value\""
        }
        if {[string length [lindex $value 3]]} {
        return -code error "NDATA illegal in parameter entity declaration"
        }
        switch [lindex $value 0] {
        internal {
            # Substitute character references and PEs (XML: 4.5)
            set value [EntitySubst [array get options] [lindex $value 1]]

            set PEnts($name) $value
            uplevel #0 $options(-parameterentitydeclcommand) [list $name $value]
        }
        external -
        default {
            # Get the replacement text now.
            # Could wait until the first reference, but easier
            # to just do it now.

            set token [uri::geturl [uri::resolve $options(-baseuri) [lindex $value 1]]]

            set ExtPEnts($name) [lindex [array get $token data] 1]
            uplevel #0 $options(-parameterentitydeclcommand) [eval list $name [lrange $value 1 2]]
        }
        }
    }
    }
}

}

namespace ::sgml {

ret  {::sgml::DTD:NOTATION} (type opts , type name , type value) {
return {}

    variable notation_exp
    upvar opts state

    if {[regexp $notation_exp $value x scheme data] == 2} {
    } else {
    eval $state(-errorcommand) [list notationvalue "notation value \"$value\" incorrectly specified"]
    }
}

}

namespace ::sgml {

ret  {::sgml::DTDAttribute} (type args) {
# BUG: Some problems with parameter passing - deal with it later
    foreach {callback name var att type default value text} $args break

    upvar #0 $var atts

    if {[string length [string trim $text]]} {
    return -code error "unexpected text \"$text\" in attribute definition"
    }

    # What about overridden attribute defns?
    # A non-validating app may want to know about them
    # (eg. an editor)
    if {![info exists atts($name/$att)]} {
    set atts($name/$att) [list $type $default $value]
    uplevel #0 $callback [list $name $att $type $default $value]
    }

    return {}
}

}

namespace ::sgml {

ret  {::sgml::DeProtect} (type cmd , type text) {
set text [lindex $text 0]
    if {[string compare {} $text]} {
    regsub -all {\\([]$[{}\\])} $text {\1} text
    uplevel #0 $cmd [list $text]
    }
}

}

namespace ::sgml {

ret  {::sgml::DeProtect1} (type cmd , type text) {
if {[string compare {} $text]} {
    regsub -all {\\([]$[{}\\])} $text {\1} text
    uplevel #0 $cmd [list $text]
    }
}

}

namespace ::sgml {

ret  {::sgml::Entity} (type opts , type entityrefcmd , type pcdatacmd , type entities , type ref) {
array set options $opts
    upvar #0 $options(-statevariable) state

    if {![string length $entities]} {
    set entities [namespace current]::EntityPredef
    }

    switch -glob -- $ref {
    %* {
        # Parameter entity - not recognised outside of a DTD
    }
    #x* {
        # Character entity - hex
        if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} {
        return -code error "malformed character entity \"$ref\""
        }
        uplevel #0 $pcdatacmd [list $char]

        return {}

    }
    #* {
        # Character entity - decimal
        if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} {
        return -code error "malformed character entity \"$ref\""
        }
        uplevel #0 $pcdatacmd [list $char]

        return {}

    }
    default {
        # General entity
        upvar #0 $entities map
        if {[info exists map($ref)]} {

        if {![regexp {<|&} $map($ref)]} {

            # Simple text replacement - optimise
            uplevel #0 $pcdatacmd [list $map($ref)]

            return {}

        }

        # Otherwise an additional round of parsing is required.
        # This only applies to XML, since HTML doesn't have general entities

        # Must parse the replacement text for start & end tags, etc
        # This text must be self-contained: balanced closing tags, and so on

        set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr]
        set options(-final) 0
        eval parseEvent [list $tokenised] [array get options]

        return {}

        } elseif {[string compare $entityrefcmd "::sgml::noop"]} {

        set result [uplevel #0 $entityrefcmd [list $ref]]

        if {[string length $result]} {
            uplevel #0 $pcdatacmd [list $result]
        }

        return {}

        } else {

        # Reconstitute entity reference

        uplevel #0 $options(-errorcommand) [list illegalentity "undefined entity reference \"$ref\""]

        return {}

        }
    }
    }

    # If all else fails leave the entity reference untouched
    uplevel #0 $pcdatacmd [list &$ref\;]

    return {}
}

}

namespace ::sgml {

ret  {::sgml::EntitySubst} (type opts , type value) {
array set options $opts

    # Protect Tcl special characters
    regsub -all {([{}\\])} $value {\\\1} value

    # Find entity references
    regsub -all (&#\[0-9\]+|&#x\[0-9a-fA-F\]+|%${::sgml::Name})\; $value "\[EntitySubstValue [list $options(parameterentities)] {\\1}\]" value

    set result [subst $value]

    return $result
}

}

namespace ::sgml {

ret  {::sgml::EntitySubstValue} (type PEvar , type ref) {
switch -glob -- $ref {
    &#x* {
        scan [string range $ref 3 end] %x hex
        return [format %c $hex]
    }
    &#* {
        return [format %c [string range $ref 2 end]]
    }
    %* {
        upvar #0 $PEvar PEs
        set ref [string range $ref 1 end]
        if {[info exists PEs($ref)]} {
        return $PEs($ref)
        } else {
        return -code error "parameter entity \"$ref\" not declared"
        }
    }
    default {
        return -code error "internal error - unexpected entity reference"
    }
    }
    return {}
}

}

namespace ::sgml {

ret  {::sgml::Error} (type args) {
uplevel return -code error [list $args]
}

}

namespace ::sgml {

ret  {::sgml::Normalize} (type name , type req) {
if {$req} {
    return [string toupper $name]
    } else {
    return $name
    }
}

}

namespace ::sgml {

ret  {::sgml::PCDATA} (type opts , type pcdata) {
array set options $opts

    if {$options(-ignorewhitespace) &&  ![string length [string trim $pcdata]]} {
    return {}
    }

    if {![regexp ^[cl $::sgml::Char]*\$ $pcdata]} {
    upvar \#0 $options(-statevariable) state
    uplevel \#0 $options(-errorcommand) [list illegalcharacters "illegal, non-Unicode characters found in text \"$pcdata\" around line $state(line)"]
    }

    uplevel \#0 $options(-characterdatacommand) [list $pcdata]
}

}

namespace ::sgml {

ret  {::sgml::ParseDTD:EntityMode} (type opts , type modeVar , type replTextVar , type declVar , type valueVar , type textVar , type delimiter , type name , type param) {
upvar 1 $modeVar mode
    upvar 1 $replTextVar replText
    upvar 1 $declVar decl
    upvar 1 $valueVar value
    upvar 1 $textVar text
    array set options $opts

    switch $mode {
    {} {
        # Pass through to normal processing section
    }
    entity {
        # Look for closing delimiter
        if {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $decl discard val1 remainder]} {
        append replText <$val1
        DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
        set decl /
        set text $remainder\ $value>$text
        set value {}
        set mode {}
        } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $value discard val2 remainder]} {
        append replText <$decl\ $val2
        DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
        set decl /
        set text $remainder>$text
        set value {}
        set mode {}
        } elseif {[regexp ([cl ^$delimiter]*)${delimiter}(.*) $text discard val3 remainder]} {
        append replText <$decl\ $value>$val3
        DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
        set decl /
        set text $remainder
        set value {}
        set mode {}
        } else {

        # Remain in entity mode
        append replText <$decl\ $value>$text
        return -code continue

        }
    }

    ignore {
        upvar #0 $options(-statevariable) state

        if {[regexp {]](.*)$} $decl discard remainder]} {
        set state(condSections) [lreplace $state(condSections) end end]
        set decl $remainder
        set mode {}
        } elseif {[regexp {]](.*)$} $value discard remainder]} {
        set state(condSections) [lreplace $state(condSections) end end]
        regexp <[cl $::sgml::Wsp]*($::sgml::Name)(.*) $remainder discard decl value
        set mode {}
        } elseif {[regexp {]]>(.*)$} $text discard remainder]} {
        set state(condSections) [lreplace $state(condSections) end end]
        set decl /
        set value {}
        set text $remainder
        #regexp <[cl $::sgml::Wsp]*($::sgml::Name)([cl ^>]*)>(.*) $remainder discard decl value text
        set mode {}
        } else {
        set decl /
        }

    }

    comment {
        # Look for closing comment delimiter

        upvar #0 $options(-statevariable) state

        if {[regexp (.*?)--(.*)\$ $decl discard data1 remainder]} {
        } elseif {[regexp (.*?)--(.*)\$ $value discard data1 remainder]} {
        } elseif {[regexp (.*?)--(.*)\$ $text discard data1 remainder]} {
        } else {
        # comment continues
        append state(commentdata) <$decl\ $value>$text
        set decl /
        set value {}
        set text {}
        }
    }

    }

    return {}
}

}

namespace ::sgml {

ret  {::sgml::ParseDTD:External} (type opts , type dtd) {
variable MarkupDeclExpr
    variable MarkupDeclSub
    variable declExpr

    array set options $opts
    upvar #0 $options(parameterentities) PEnts
    upvar #0 $options(externalparameterentities) ExtPEnts
    upvar #0 $options(-statevariable) state

    # As with the internal DTD subset, watch out for
    # entities with angle brackets
    set mode {} ;# normal
    set delimiter {}
    set name {}
    set param {}

    set oldState 0
    catch {set oldState $state(inInternalDTD)}
    set state(inInternalDTD) 0

    # Initialise conditional section stack
    if {![info exists state(condSections)]} {
    set state(condSections) {}
    }
    set startCondSectionDepth [llength $state(condSections)]

    while {[string length $dtd]} {
    set progress 0
    set PEref {}
    if {![string compare $mode "ignore"]} {
        set progress 1
        if {[regexp {]]>(.*)} $dtd discard dtd]} {
        set remainder {}
        set mode {} ;# normal
        set state(condSections) [lreplace $state(condSections) end end]
        continue
        } else {
        uplevel #0 $options(-errorcommand) [list missingdelimiter "IGNORE conditional section closing delimiter not found"]
        }
    } elseif {[regexp ^(.*?)%($::sgml::Name)\;(.*)\$ $dtd discard data PEref remainder]} {
        set progress 1
    } else {
        set data $dtd
        set dtd {}
        set remainder {}
    }

    # Tokenize the DTD (so far)

    # Protect Tcl special characters
    regsub -all {([{}\\])} $data {\\\1} dataP

    set n [regsub -all $MarkupDeclExpr $dataP $MarkupDeclSub dataP]

    if {$n} {
        set progress 1
        # All but the last markup declaration should have no text
        set dataP [lrange "{} {} \{$dataP\}" 3 end]
        if {[llength $dataP] > 3} {
        foreach {decl value text} [lrange $dataP 0 [expr [llength $dataP] - 4]] {
            ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
            ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param

            if {[string length [string trim $text]]} {
            # check for conditional section close
            if {[regexp {]]>(.*)$} $text discard text]} {
                if {[string length [string trim $text]]} {
                uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
                }
                if {![llength $state(condSections)]} {
                uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
                }
                set state(condSections) [lreplace $state(condSections) end end]
                if {![string compare $mode "ignore"]} {
                set mode {} ;# normal
                }
            } else {
                uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\""]
            }
            }
        }
        }
        # Do the last declaration
        foreach {decl value text} [lrange $dataP [expr [llength $dataP] - 3] end] {
        ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param
        ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode repltextVar text param
        }
    }

    # Now expand the PE reference, if any
    switch -glob $mode,[string length $PEref],$n {
        ignore,0,* {
        set dtd $text
        }
        ignore,*,* {
        set dtd $text$remainder
        }
        *,0,0 {
        set dtd $data
        }
        *,0,* {
        set dtd $text
        }
        *,*,0 {
        if {[catch {append data $PEnts($PEref)}]} {
            if {[info exists ExtPEnts($PEref)]} {
            set externalParser [$options(-cmd) entityparser]
            $externalParser parse $ExtPEnts($PEref) -dtdsubset external
            #$externalParser free
            } else {
            uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
            }
        }
        set dtd $data$remainder
        }
        default {
        if {[catch {append text $PEnts($PEref)}]} {
            if {[info exists ExtPEnts($PEref)]} {
            set externalParser [$options(-cmd) entityparser]
            $externalParser parse $ExtPEnts($PEref) -dtdsubset external
            #$externalParser free
            } else {
            uplevel #0 $options(-errorcommand) [list entityundeclared "parameter entity \"$PEref\" not declared"]
            }
        }
        set dtd $text$remainder
        }
    }

    # Check whether a conditional section has been terminated
    if {[regexp {^(.*?)]]>(.*)$} $dtd discard t1 t2]} {
        if {![regexp <.*> $t1]} {
        if {[string length [string trim $t1]]} {
            uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
        }
        if {![llength $state(condSections)]} {
            uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
        }
        set state(condSections) [lreplace $state(condSections) end end]
        if {![string compare $mode "ignore"]} {
            set mode {} ;# normal
        }
        set dtd $t2
        set progress 1
        }
    }

    if {!$progress} {
        # No parameter entity references were found and 
        # the text does not contain a well-formed markup declaration
        # Avoid going into an infinite loop
        upvar #0 $options(-errorcommand) [list syntaxerror "external entity does not contain well-formed markup declaration"]
        break
    }
    }

    set state(inInternalDTD) $oldState

    # Check that conditional sections have been closed properly
    if {[llength $state(condSections)] > $startCondSectionDepth} {
    uplevel #0 $options(-errorcommand) [list syntaxerror "[lindex $state(condSections) end] conditional section not closed"]
    }
    if {[llength $state(condSections)] < $startCondSectionDepth} {
    uplevel #0 $options(-errorcommand) [list syntaxerror "too many conditional section closures"]
    }

    return {}
}

}

namespace ::sgml {

ret  {::sgml::ParseDTD:Internal} (type opts , type dtd) {
variable MarkupDeclExpr
    variable MarkupDeclSub

    array set options {}
    array set options $opts

    upvar #0 $options(-statevariable) state
    upvar #0 $options(parameterentities) PEnts
    upvar #0 $options(externalparameterentities) ExtPEnts

    # Bug 583947: remove comments before further processing
    regsub -all {<!--.*?-->} $dtd {} dtd

    # Tokenize the DTD

    # Protect Tcl special characters
    regsub -all {([{}\\])} $dtd {\\\1} dtd

    regsub -all $MarkupDeclExpr $dtd $MarkupDeclSub dtd

    # Entities may have angle brackets in their replacement
    # text, which breaks the RE processing.  So, we must
    # use a similar technique to processing doc instances
    # to rebuild the declarations from the pieces

    set mode {} ;# normal
    set delimiter {}
    set name {}
    set param {}

    set state(inInternalDTD) 1

    # Process the tokens
    foreach {decl value text} [lrange "{} {} \{$dtd\}" 3 end] {

    # Keep track of line numbers
    incr state(line) [regsub -all \n $text {} discard]

    ParseDTD:EntityMode [array get options] mode replText decl value text $delimiter $name $param

    ParseDTD:ProcessMarkupDecl [array get options] decl value delimiter name mode replText text param

    # There may be parameter entity references between markup decls

    if {[regexp {%.*;} $text]} {

        # Protect Tcl special characters
        regsub -all {([{}\\])} $text {\\\1} text

        regsub -all %($::sgml::Name)\; $text "\} {\\1} \{" text

        set PElist "\{$text\}"
        set PElist [lreplace $PElist end end]
        foreach {text entref} $PElist {
        if {[string length [string trim $text]]} {
            uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text in internal DTD subset around line $state(line)"]
        }

        # Expand parameter entity and recursively parse
        # BUG: no checks yet for recursive entity references

        if {[info exists PEnts($entref)]} {
            set externalParser [$options(-cmd) entityparser]
            $externalParser parse $PEnts($entref) -dtdsubset internal
        } elseif {[info exists ExtPEnts($entref)]} {
            set externalParser [$options(-cmd) entityparser]
            $externalParser parse $ExtPEnts($entref) -dtdsubset external
            #$externalParser free
        } else {
            uplevel #0 $options(-errorcommand) [list illegalreference "reference to undeclared parameter entity \"$entref\""]
        }
        }

    }

    }

    return {}
}

}

namespace ::sgml {

ret  {::sgml::ParseDTD:ProcessMarkupDecl} (type opts , type declVar , type valueVar , type delimiterVar , type nameVar , type modeVar , type replTextVar , type textVar , type paramVar) {
upvar 1 $modeVar mode
    upvar 1 $replTextVar replText
    upvar 1 $textVar text
    upvar 1 $declVar decl
    upvar 1 $valueVar value
    upvar 1 $nameVar name
    upvar 1 $delimiterVar delimiter
    upvar 1 $paramVar param

    variable declExpr
    variable ExternalEntityExpr

    array set options $opts
    upvar #0 $options(-statevariable) state

    switch -glob -- $decl {

    / {
        # continuation from entity processing
    }

    !ELEMENT {
        # Element declaration
        if {[regexp $declExpr $value discard tag cmodel]} {
        DTD:ELEMENT [array get options] $tag $cmodel
        } else {
        uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed element declaration around line $state(line)"]
        }
    }

    !ATTLIST {
        # Attribute list declaration
        variable declExpr
        if {[regexp $declExpr $value discard tag attdefns]} {
        if {[catch {DTD:ATTLIST [array get options] $tag $attdefns} err]} {
            #puts stderr "Stack trace: $::errorInfo\n***\n"
            # Atttribute parsing has bugs at the moment
            #return -code error "$err around line $state(line)"
            return {}
        }
        } else {
        uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed attribute list declaration around line $state(line)"]
        }
    }

    !ENTITY {
        # Entity declaration
        variable EntityExpr

        if {[regexp $EntityExpr $value discard param name value]} {

        # Entity replacement text may have a '>' character.
        # In this case, the real delimiter will be in the following
        # text.  This is complicated by the possibility of there
        # being several '<','>' pairs in the replacement text.
        # At this point, we are searching for the matching quote delimiter.

        if {[regexp $ExternalEntityExpr $value]} {
            DTD:ENTITY [array get options] $name [string trim $param] $value
        } elseif {[regexp ("|')(.*?)\\1(.*) $value discard delimiter replText value]} {

            if {[string length [string trim $value]]} {
            uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
            } else {
            DTD:ENTITY [array get options] $name [string trim $param] $delimiter$replText$delimiter
            }
        } elseif {[regexp ("|')(.*) $value discard delimiter replText]} {
            append replText >$text
            set text {}
            set mode entity
        } else {
            uplevel #0 $options(-errorcommand) [list illegaldeclaration "no delimiter for entity declaration around line $state(line)"]
        }

        } else {
        uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
        }
    }

    !NOTATION {
        # Notation declaration
        if {[regexp $declExpr param discard tag notation]} {
        DTD:ENTITY [array get options] $tag $notation
        } else {
        uplevel #0 $options(-errorcommand) [list illegaldeclaration "malformed entity declaration around line $state(line)"]
        }
    }

    !--* {
        # Start of a comment

        if {[regexp !--(.*?)--\$ $decl discard data]} {
        if {[string length [string trim $value]]} {
            uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$value\""]
        }
        uplevel #0 $options(-commentcommand) [list $data]
        set decl /
        set value {}
        } elseif {[regexp -- ^(.*?)--\$ $value discard data2]} {
        regexp !--(.*)\$ $decl discard data1
        uplevel #0 $options(-commentcommand) [list $data1\ $data2]
        set decl /
        set value {}
        } elseif {[regexp (.*?)-->(.*)\$ $text discard data3 remainder]} {
        regexp !--(.*)\$ $decl discard data1
        uplevel #0 $options(-commentcommand) [list $data1\ $value>$data3]
        set decl /
        set value {}
        set text $remainder
        } else {
        regexp !--(.*)\$ $decl discard data1
        set state(commentdata) $data1\ $value>$text
        set decl /
        set value {}
        set text {}
        set mode comment
        }
    }

    !*INCLUDE* -
    !*IGNORE* {
        if {$state(inInternalDTD)} {
        uplevel #0 $options(-errorcommand) [list illegalsection "conditional section not permitted in internal DTD subset around line $state(line)"]
        }

        if {[regexp {^!\[INCLUDE\[(.*)} $decl discard remainder]} {
        # Push conditional section stack, popped by ]]> sequence

        if {[regexp {(.*?)]]$} $remainder discard r2]} {
            # section closed immediately
            if {[string length [string trim $r2]]} {
            uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
            }
        } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
            # section closed immediately
            if {[string length [string trim $r2]]} {
            uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
            }
            if {[string length [string trim $r3]]} {
            uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
            }
        } else {

            lappend state(condSections) INCLUDE

            set parser [$options(-cmd) entityparser]
            $parser parse $remainder\ $value> -dtdsubset external
            #$parser free

            if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
            if {[string length [string trim $t1]]} {
                uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
            }
            if {![llength $state(condSections)]} {
                uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
            }
            set state(condSections) [lreplace $state(condSections) end end]
            set text $t2
            }

        }
        } elseif {[regexp {^!\[IGNORE\[(.*)} $decl discard remainder]} {
        # Set ignore mode.  Still need a stack
        set mode ignore

        if {[regexp {(.*?)]]$} $remainder discard r2]} {
            # section closed immediately
            if {[string length [string trim $r2]]} {
            uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
            }
        } elseif {[regexp {(.*?)]](.*)} $value discard r2 r3]} {
            # section closed immediately
            if {[string length [string trim $r2]]} {
            uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r2\" in conditional section"]
            }
            if {[string length [string trim $r3]]} {
            uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$r3\" in conditional section"]
            }
        } else {
            
            lappend state(condSections) IGNORE

            if {[regexp {(.*?)]]>(.*)} $text discard t1 t2]} {
            if {[string length [string trim $t1]]} {
                uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$t1\""]
            }
            if {![llength $state(condSections)]} {
                uplevel #0 $options(-errorcommand) [list illegalsection "extraneous conditional section close"]
            }
            set state(condSections) [lreplace $state(condSections) end end]
            set text $t2
            }

        }
        } else {
        uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\" around line $state(line)"]
        }

    }

    default {
        if {[regexp {^\?(.*)} $decl discard target]} {
        # Processing instruction
        } else {
        uplevel #0 $options(-errorcommand) [list illegaldeclaration "illegal markup declaration \"$decl\""]
        }
    }
    }

    return {}
}

}

namespace ::sgml {

ret  {::sgml::ParseEvent:DocTypeDecl} (type opts , type docEl , type pubId , type sysId , type intSSet) {
array set options {}
    array set options $opts

    set code [catch {uplevel #0 $options(-doctypecommand) [list $docEl $pubId $sysId $intSSet]} err]
    switch $code {
    3 {
        # break
        return {}
    }
    0 -
    4 {
        # continue
    }
    default {
        return -code $code $err
    }
    }

    # Otherwise we'll parse the DTD and report it piecemeal

    # The internal DTD subset is processed first (XML 2.8)
    # During this stage, parameter entities are only allowed
    # between markup declarations

    ParseDTD:Internal [array get options] $intSSet

    # The external DTD subset is processed last (XML 2.8)
    # During this stage, parameter entities may occur anywhere

    # We must resolve the external identifier to obtain the
    # DTD data.  The application may supply its own resolver.

    if {[string length $pubId] || [string length $sysId]} {
    uplevel #0 $options(-externalentitycommand) [list $options(-cmd) $options(-baseuri) $sysId $pubId]
    }

    return {}
}

}

namespace ::sgml {

ret  {::sgml::ParseEvent:ElementClose} (type tag , type opts , type args) {
array set options $opts
    upvar #0 $options(-statevariable) state
    array set cfg {-empty 0}
    array set cfg $args

    # WF check
    if {[string compare $tag [lindex $state(stack) end]]} {
    uplevel #0 $options(-errorcommand) [list illegalendtag "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"]
    return
    }

    # Check whether this element has an expanded name
    upvar #0 $options(namespaces) namespaces
    set ns {}
    if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
    set nsuri $namespaces([lindex [lsort -dictionary -decreasing [array names namespaces $prefix,*]] 0])
    set ns [list -namespace $nsuri]
    } elseif {[llength $state(defaultNSURI)]} {
    set ns [list -namespace [lindex $state(defaultNSURI) end]]
    }

    # Pop namespace stacks, if any
    if {[llength $state(defaultNS)]} {
    if {[llength $state(stack)] == [lindex $state(defaultNS) end]} {
        set state(defaultNS) [lreplace $state(defaultNS) end end]
    }
    }
    foreach nsspec [array names namespaces *,[llength $state(stack)]] {
    unset namespaces($nsspec)
    }

    # Update state
    set state(stack) [lreplace $state(stack) end end]

    set empty {}
    if {$cfg(-empty) && $options(-reportempty)} {
    set empty {-empty 1}
    }

    # Invoke callback
    # Mats: Shall be same as sgml::ParseEvent:ElementOpen to handle exceptions in callback.
    set code [catch {uplevel #0 $options(-elementendcommand) [list $tag] $empty $ns} msg]
    return -code $code -errorinfo $::errorInfo $msg
}

}

namespace ::sgml {

ret  {::sgml::ParseEvent:ElementOpen} (type tag , type attr , type opts , type args) {
variable Name
    variable Wsp

    array set options $opts
    upvar #0 $options(-statevariable) state
    array set cfg {-empty 0}
    array set cfg $args
    set handleEmpty 0

    if {$options(-normalize)} {
    set tag [string toupper $tag]
    }

    # Update state
    lappend state(stack) $tag

    # Parse attribute list into a key-value representation
    if {[string compare $options(-parseattributelistcommand) {}]} {
    if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $opts $attr]} attr]} {
        if {[string compare [lindex $attr 0] "unterminated attribute value"]} {
        uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
        set attr {}
        } else {

        # It is most likely that a ">" character was in an attribute value.
        # This manifests itself by ">" appearing in the element's text.
        # In this case the callback should return a three element list;
        # the message "unterminated attribute value", the attribute list it
        # did manage to parse and the remainder of the attribute list.

        foreach {msg attlist brokenattr} $attr break

        upvar text elemText
        if {[string first > $elemText] >= 0} {

            # Now piece the attribute list back together
            regexp [cl $Wsp]*($Name)[cl $Wsp]*=[cl $Wsp]*("|')(.*) $brokenattr discard attname delimiter attvalue
            regexp (.*)>([cl ^>]*)\$ $elemText discard remattlist elemText
            regexp ([cl ^$delimiter]*)${delimiter}(.*) $remattlist discard remattvalue remattlist

            # Gotcha: watch out for empty element syntax
            if {[string match */ [string trimright $remattlist]]} {
            set remattlist [string range $remattlist 0 end-1]
            set handleEmpty 1
            set cfg(-empty) 1
            }

            append attvalue >$remattvalue
            lappend attlist $attname $attvalue

            # Complete parsing the attribute list
            if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $options(-statevariable) $remattlist]} attr]} {
            uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
            set attr {}
            set attlist {}
            } else {
            eval lappend attlist $attr
            }

            set attr $attlist

        } else {
            uplevel #0 $options(-errorcommand) [list unterminatedattribute "$attr around line $state(line)"]
            set attr {}
        }
        }
    }
    }

    set empty {}
    if {$cfg(-empty) && $options(-reportempty)} {
    set empty {-empty 1}
    }

    # Check for namespace declarations
    upvar #0 $options(namespaces) namespaces
    set nsdecls {}
    if {[llength $attr]} {
    array set attrlist $attr
    foreach {attrName attrValue} [array get attrlist xmlns*] {
        unset attrlist($attrName)
        set colon [set prefix {}]
        if {[regexp {^xmlns(:(.+))?$} $attrName discard colon prefix]} {
        switch -glob [string length $colon],[string length $prefix] {
            0,0 {
            # default NS declaration
            lappend state(defaultNSURI) $attrValue
            lappend state(defaultNS) [llength $state(stack)]
            lappend nsdecls $attrValue {}
            }
            0,* {
            # Huh?
            }
            *,0 {
            # Error
            uplevel #0 $state(-warningcommand) "no prefix specified for namespace URI \"$attrValue\" in element \"$tag\""
            }
            default {
            set namespaces($prefix,[llength $state(stack)]) $attrValue
            lappend nsdecls $attrValue $prefix
            }
        }
        }
    }
    if {[llength $nsdecls]} {
        set nsdecls [list -namespacedecls $nsdecls]
    }
    set attr [array get attrlist]
    }

    # Check whether this element has an expanded name
    set ns {}
    if {[regexp {([^:]+):(.*)$} $tag discard prefix tag]} {
    set nsspec [lsort -dictionary -decreasing [array names namespaces $prefix,*]]
    if {[llength $nsspec]} {
        set nsuri $namespaces([lindex $nsspec 0])
        set ns [list -namespace $nsuri]
    } else {
        uplevel #0 $options(-errorcommand) [list namespaceundeclared "no namespace declared for prefix \"$prefix\" in element $tag"]
    }
    } elseif {[llength $state(defaultNSURI)]} {
    set ns [list -namespace [lindex $state(defaultNSURI) end]]
    }

    # Invoke callback
    set code [catch {uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty $ns $nsdecls} msg]

    # Sometimes empty elements must be handled here (see above)
    if {$code == 0 && $handleEmpty} {
    ParseEvent:ElementClose $tag $opts -empty 1
    }

    return -code $code -errorinfo $::errorInfo $msg
}

}

namespace ::sgml {

ret  {::sgml::ParserDelete} (type var) {
upvar #0 $var state

    if {![info exists state]} {
    return -code error "unknown parser"
    }

    catch {unset $state(entities)}
    catch {unset $state(parameterentities)}
    catch {unset $state(elementdecls)}
    catch {unset $state(attlistdecls)}
    catch {unset $state(notationdecls)}
    catch {unset $state(namespaces)}

    unset state

    return {}
}

}

namespace ::sgml {

ret  {::sgml::ResolveEntity} (type cmd , type base , type sysId , type pubId) {
variable ParseEventNum

    if {[catch {uri::resolve $base $sysId} url]} {
    return -code error "unable to resolve system identifier \"$sysId\""
    }
    if {[catch {uri::geturl $url} token]} {
    return -code error "unable to retrieve external entity \"$url\" for system identifier \"$sysId\""
    }

    upvar #0 $token data

    set parser [uplevel #0 $cmd entityparser]

    set body {}
    catch {set body $data(body)}
    catch {set body $data(data)}
    if {[string length $body]} {
    uplevel #0 $parser parse [list $body] -dtdsubset external
    }
    $parser free

    return {}
}

}

namespace ::sgml {

ret  {::sgml::TraverseDepth1st} (type state , type t , type leaf , type nonTerm) {
upvar #0 $state var

    set nullable {}
    set firstpos {}
    set lastpos {}

    switch -- [lindex [lindex $t 1] 0] {
    :seq -
    :choice {
        set rep [lindex $t 0]
        set cs [lindex [lindex $t 1] 0]

        foreach child [lrange [lindex $t 1] 1 end] {
        foreach {childNullable childFirstpos childLastpos}  [TraverseDepth1st $state $child $leaf $nonTerm] break
        lappend nullable $childNullable
        lappend firstpos $childFirstpos
        lappend lastpos  $childLastpos
        }

        eval $nonTerm
    }
    default {
        incr var(number)
        set rep [lindex [lindex $t 0] 0]
        set name [lindex [lindex $t 1] 0]
        eval $leaf
    }
    }

    return [list $nullable $firstpos $lastpos]
}

}

namespace ::sgml {

ret  {::sgml::cl} (type x) {
return "\[$x\]"
}

}

namespace ::sgml {

ret  {::sgml::firstpos} (type cs , type firstpos , type nullable) {
switch -- $cs {
    :seq {
        set result [lindex [lindex $firstpos 0] 1]
        for {set i 0} {$i < [llength $nullable]} {incr i} {
            if {[lindex [lindex $nullable $i] 1]} {
                eval lappend result [lindex [lindex $firstpos [expr $i + 1]] 1]
        } else {
            break
        }
        }
    }
    :choice {
        foreach child $firstpos {
        eval lappend result $child
        }
    }
    }

    return [list $firstpos [makeSet $result]]
}

}

namespace ::sgml {

ret  {::sgml::followpos} (type state , type st , type firstpos , type lastpos) {
upvar #0 $state var

    switch -- [lindex [lindex $st 1] 0] {
    :seq {
        for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
            followpos $state [lindex [lindex $st 1] $i]          [lindex [lindex $firstpos 0] [expr $i - 1]]     [lindex [lindex $lastpos 0] [expr $i - 1]]
            foreach pos [lindex [lindex [lindex $lastpos 0] [expr $i - 1]] 1] {
            eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
            set var($pos) [makeSet $var($pos)]
            }
        }
    }
    :choice {
        for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
        followpos $state [lindex [lindex $st 1] $i]          [lindex [lindex $firstpos 0] [expr $i - 1]]     [lindex [lindex $lastpos 0] [expr $i - 1]]
        }
    }
    default {
        # No action at leaf nodes
    }
    }

    switch -- [lindex $st 0] {
    ? {
        # We having nothing to do here ! Doing the same as
        # for * effectively converts this qualifier into the other.
    }
    * {
        foreach pos [lindex $lastpos 1] {
        eval lappend var($pos) [lindex $firstpos 1]
        set var($pos) [makeSet $var($pos)]
        }
    }
    }
}

}

namespace ::sgml {

ret  {::sgml::identity} (type a) {
return $a
}

}

namespace ::sgml {

ret  {::sgml::lastpos} (type cs , type lastpos , type nullable) {
switch -- $cs {
    :seq {
        set result [lindex [lindex $lastpos end] 1]
        for {set i [expr [llength $nullable] - 1]} {$i >= 0} {incr i -1} {
        if {[lindex [lindex $nullable $i] 1]} {
            eval lappend result [lindex [lindex $lastpos $i] 1]
        } else {
            break
        }
        }
    }
    :choice {
        foreach child $lastpos {
        eval lappend result $child
        }
    }
    }

    return [list $lastpos [makeSet $result]]
}

}

namespace ::sgml {

ret  {::sgml::makeSet} (type s) {
foreach r $s {
    if {[llength $r]} {
        set unique($r) {}
    }
    }
    return [array names unique]
}

}

namespace ::sgml {

ret  {::sgml::noop} (type args) {
return 0
}

}

namespace ::sgml {

ret  {::sgml::nullable} (type nodeType , type rep , type name , optional subtree ={)} {
switch -glob -- $rep:$nodeType {
    :leaf -
    +:leaf {
        return [list {} 0]
    }
    \\*:leaf -
    \\?:leaf {
        return [list {} 1]
    }
    \\*:nonterm -
    \\?:nonterm {
        return [list $subtree 1]
    }
    :nonterm -
    +:nonterm {
        switch -- $name {
        :choice {
            set result 0
            foreach child $subtree {
            set result [expr $result || [lindex $child 1]]
            }
        }
        :seq {
            set result 1
            foreach child $subtree {
            set result [expr $result && [lindex $child 1]]
            }
        }
        }
        return [list $subtree $result]
    }
    }
}

}

namespace ::sgml {

ret  {::sgml::parseEvent} (type sgml , type args) {
variable Wsp
    variable noWsp
    variable Nmtoken
    variable Name
    variable ParseEventNum
    variable StdOptions

    array set options [array get StdOptions]
    catch {array set options $args}

    # Mats:
    # If the data is not final then there must be a variable to persistently store the parse state.
    if {!$options(-final) && ![info exists options(-statevariable)]} {
    return -code error {option "-statevariable" required if not final}
    }
    
    foreach {opt value} [array get options *command] {
    if {[string compare $opt "-externalentitycommand"] && ![string length $value]} {
        set options($opt) [namespace current]::noop
    }
    }

    if {![info exists options(-statevariable)]} {
    set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum]
    }
    if {![info exists options(entities)]} {
    set options(entities) [namespace current]::Entities$ParseEventNum
    array set $options(entities) [array get [namespace current]::EntityPredef]
    }
    if {![info exists options(extentities)]} {
    set options(extentities) [namespace current]::ExtEntities$ParseEventNum
    }
    if {![info exists options(parameterentities)]} {
    set options(parameterentities) [namespace current]::ParamEntities$ParseEventNum
    }
    if {![info exists options(externalparameterentities)]} {
    set options(externalparameterentities) [namespace current]::ExtParamEntities$ParseEventNum
    }
    if {![info exists options(elementdecls)]} {
    set options(elementdecls) [namespace current]::ElementDecls$ParseEventNum
    }
    if {![info exists options(attlistdecls)]} {
    set options(attlistdecls) [namespace current]::AttListDecls$ParseEventNum
    }
    if {![info exists options(notationdecls)]} {
    set options(notationdecls) [namespace current]::NotationDecls$ParseEventNum
    }
    if {![info exists options(namespaces)]} {
    set options(namespaces) [namespace current]::Namespaces$ParseEventNum
    }

    # For backward-compatibility
    catch {set options(-baseuri) $options(-baseurl)}

    # Choose an external entity resolver

    if {![string length $options(-externalentitycommand)]} {
    if {$options(-validate)} {
        set options(-externalentitycommand) [namespace code ResolveEntity]
    } else {
        set options(-externalentitycommand) [namespace code noop]
    }
    }

    upvar #0 $options(-statevariable) state
    upvar #0 $options(entities) entities

    # Mats:
    # The problem is that the state is not maintained when -final 0 !
    # I've switched back to an older version here. 
    
    if {![info exists state(line)]} {
    # Initialise the state variable
    array set state {
        mode normal
        haveXMLDecl 0
        haveDocElement 0
        inDTD 0
        context {}
        stack {}
        line 0
        defaultNS {}
        defaultNSURI {}
    }
    }

    foreach {tag close param text} $sgml {

    # Keep track of lines in the input
    incr state(line) [regsub -all \n $param {} discard]
    incr state(line) [regsub -all \n $text {} discard]

    # If the current mode is cdata or comment then we must undo what the
    # regsub has done to reconstitute the data

    set empty {}
    switch $state(mode) {
        comment {
        # This had "[string length $param] && " as a guard -
        # can't remember why :-(
        if {[regexp ([cl ^-]*)--\$ $tag discard comm1]} {
            # end of comment (in tag)
            set tag {}
            set close {}
            set state(mode) normal
            DeProtect1 $options(-commentcommand) $state(commentdata)<$comm1
            unset state(commentdata)
        } elseif {[regexp ([cl ^-]*)--\$ $param discard comm1]} {
            # end of comment (in attributes)
            DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag>$comm1
            unset state(commentdata)
            set tag {}
            set param {}
            set close {}
            set state(mode) normal
        } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm1 text]} {
            # end of comment (in text)
            DeProtect1 $options(-commentcommand) $state(commentdata)<$close$tag$param>$comm1
            unset state(commentdata)
            set tag {}
            set param {}
            set close {}
            set state(mode) normal
        } else {
            # comment continues
            append state(commentdata) <$close$tag$param>$text
            continue
        }
        }
        cdata {
        if {[string length $param] && [regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} {
            # end of CDATA (in tag)
            PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$cdata1]
            set text [subst -novariable -nocommand $text]
            set tag {}
            unset state(cdata)
            set state(mode) normal
        } elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
            # end of CDATA (in attributes)
            PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$cdata1]
            set text [subst -novariable -nocommand $text]
            set tag {}
            set param {}
            unset state(cdata)
            set state(mode) normal
        } elseif {[regexp (.*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
            # end of CDATA (in text)
            PCDATA [array get options] $state(cdata)<[subst -nocommand -novariable $close$tag$param>$cdata1]
            set text [subst -novariable -nocommand $text]
            set tag {}
            set param {}
            set close {}
            unset state(cdata)
            set state(mode) normal
        } else {
            # CDATA continues
            append state(cdata) [subst -nocommand -novariable <$close$tag$param>$text]
            continue
        }
        }
        continue {
        # We're skipping elements looking for the close tag
        switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close {
            0,* {
            continue
            }
            *,0, {
            if {![string compare $tag $state(continue:tag)]} {
                set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
                if {![string length $empty]} {
                incr state(continue:level)
                }
            }
            continue
            }
            *,0,/ {
            if {![string compare $tag $state(continue:tag)]} {
                incr state(continue:level) -1
            }
            if {!$state(continue:level)} {
                unset state(continue:tag)
                unset state(continue:level)
                set state(mode) {}
            }
            }
            default {
            continue
            }
        }
        }
        default {
        # The trailing slash on empty elements can't be automatically separated out
        # in the RE, so we must do it here.
        regexp (.*)(/)[cl $Wsp]*$ $param discard param empty
        }
    }

    # default: normal mode

    # Bug: if the attribute list has a right angle bracket then the empty
    # element marker will not be seen

    set empty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]

    switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {

        0,0,, {
        # Ignore empty tag - dealt with non-normal mode above
        }
        *,0,, {

        # Start tag for an element.

        # Check if the internal DTD entity is in an attribute value
        regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param

        set code [catch {ParseEvent:ElementOpen $tag $param [array get options]} msg]
        set state(haveDocElement) 1
        switch $code {
            0 {# OK}
            3 {
            # break
            return {}
            }
            4 {
            # continue
            # Remember this tag and look for its close
            set state(continue:tag) $tag
            set state(continue:level) 1
            set state(mode) continue
            continue
            }
            default {
            return -code $code -errorinfo $::errorInfo $msg
            }
        }

        }

        *,0,/, {

        # End tag for an element.

        set code [catch {ParseEvent:ElementClose $tag [array get options]} msg]
        switch $code {
            0 {# OK}
            3 {
            # break
            return {}
            }
            4 {
            # continue
            # skip sibling nodes
            set state(continue:tag) [lindex $state(stack) end]
            set state(continue:level) 1
            set state(mode) continue
            continue
            }
            default {
            return -code $code -errorinfo $::errorInfo $msg
            }
        }

        }

        *,0,,/ {

        # Empty element

        # The trailing slash sneaks through into the param variable
        regsub -all /[cl $::sgml::Wsp]*\$ $param {} param

        set code [catch {ParseEvent:ElementOpen $tag $param [array get options] -empty 1} msg]
        set state(haveDocElement) 1
        switch $code {
            0 {# OK}
            3 {
            # break
            return {}
            }
            4 {
            # continue
            # Pretty useless since it closes straightaway
            }
            default {
            return -code $code -errorinfo $::errorInfo $msg
            }
        }
        set code [catch {ParseEvent:ElementClose $tag [array get options] -empty 1} msg]
        switch $code {
            0 {# OK}
            3 {
            # break
            return {}
            }
            4 {
            # continue
            # skip sibling nodes
            set state(continue:tag) [lindex $state(stack) end]
            set state(continue:level) 1
            set state(mode) continue
            continue
            }
            default {
            return -code $code -errorinfo $::errorInfo $msg
            }
        }

        }

        *,1,* {
        # Processing instructions or XML declaration
        switch -glob -- $tag {

            {\?xml} {
            # XML Declaration
            if {$state(haveXMLDecl)} {
                uplevel #0 $options(-errorcommand) [list illegalcharacter "unexpected characters \"<$tag\" around line $state(line)"]
            } elseif {![regexp {\?$} $param]} {
                uplevel #0 $options(-errorcommand) [list missingcharacters "XML Declaration missing characters \"?>\" around line $state(line)"]
            } else {

                # We can do the parsing in one step with Tcl 8.1 RE's
                # This has the benefit of performing better WF checking

                set adv_re [format {^[%s]*version[%s]*=[%s]*("|')(-+|[a-zA-Z0-9_.:]+)\1([%s]+encoding[%s]*=[%s]*("|')([A-Za-z][-A-Za-z0-9._]*)\4)?([%s]*standalone[%s]*=[%s]*("|')(yes|no)\7)?[%s]*\?$} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp]

                if {[catch {regexp $adv_re $param discard delimiter version discard delimiter encoding discard delimiter standalone} matches]} {
                # Otherwise we must fallback to 8.0.
                # This won't detect certain well-formedness errors

                # Get the version number
                if {[regexp [format {[%s]*version[%s]*=[%s]*"(-+|[a-zA-Z0-9_.:]+)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version] || [regexp [format {[%s]*version[%s]*=[%s]*'(-+|[a-zA-Z0-9_.:]+)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard version]} {
                    if {[string compare $version "1.0"]} {
                    # Should we support future versions?
                    # At least 1.X?
                    uplevel #0 $options(-errorcommand) [list versionincompatibility "document XML version \"$version\" is incompatible with XML version 1.0"]
                    }
                } else {
                    uplevel #0 $options(-errorcommand) [list missingversion "XML Declaration missing version information around line $state(line)"]
                }

                # Get the encoding declaration
                set encoding {}
                regexp [format {[%s]*encoding[%s]*=[%s]*"([A-Za-z]([A-Za-z0-9._]|-)*)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding
                regexp [format {[%s]*encoding[%s]*=[%s]*'([A-Za-z]([A-Za-z0-9._]|-)*)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard encoding

                # Get the standalone declaration
                set standalone {}
                regexp [format {[%s]*standalone[%s]*=[%s]*"(yes|no)"[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone
                regexp [format {[%s]*standalone[%s]*=[%s]*'(yes|no)'[%s]*} $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp $::sgml::Wsp] $param discard standalone

                # Invoke the callback
                uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]

                } elseif {$matches == 0} {
                uplevel #0 $options(-errorcommand) [list illformeddeclaration "XML Declaration not well-formed around line $state(line)"]
                } else {

                # Invoke the callback
                uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]

                }

            }

            }

            {\?*} {
            # Processing instruction
            set tag [string range $tag 1 end]
            if {[regsub {\?$} $tag {} tag]} {
                if {[string length [string trim $param]]} {
                uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$param\" in processing instruction around line $state(line)"]
                }
            } elseif {![regexp ^$Name\$ $tag]} {
                uplevel #0 $options(-errorcommand) [list illegalcharacter "illegal character in processing instruction target \"$tag\""]
            } elseif {[regexp {[xX][mM][lL]} $tag]} {
                uplevel #0 $options(-errorcommand) [list illegalcharacters "characters \"xml\" not permitted in processing instruction target \"$tag\""]
            } elseif {![regsub {\?$} $param {} param]} {
                uplevel #0 $options(-errorcommand) [list missingquestion "PI: expected '?' character around line $state(line)"]
            }
            set code [catch {uplevel #0 $options(-processinginstructioncommand) [list $tag [string trimleft $param]]} msg]
            switch $code {
                0 {# OK}
                3 {
                # break
                return {}
                }
                4 {
                # continue
                # skip sibling nodes
                set state(continue:tag) [lindex $state(stack) end]
                set state(continue:level) 1
                set state(mode) continue
                continue
                }
                default {
                return -code $code -errorinfo $::errorInfo $msg
                }
            }
            }

            !DOCTYPE {
            # External entity reference
            # This should move into xml.tcl
            # Parse the params supplied.  Looking for Name, ExternalID and MarkupDecl
            set matched [regexp ^[cl $Wsp]*($Name)[cl $Wsp]*(.*) $param x state(doc_name) param]
            set state(doc_name) [Normalize $state(doc_name) $options(-normalize)]
            set externalID {}
            set pubidlit {}
            set systemlit {}
            set externalID {}
            if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} {
                switch [string toupper $id] {
                SYSTEM {
                    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
                    set externalID [list SYSTEM $systemlit] ;# "
                    } else {
                    uplevel #0 $options(-errorcommand) {syntaxerror {syntax error: SYSTEM identifier not followed by literal}}
                    }
                }
                PUBLIC {
                    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
                    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
                        set externalID [list PUBLIC $pubidlit $systemlit]
                    } else {
                        uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"]
                    }
                    } else {
                    uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: PUBLIC identifier not followed by literal around line $state(line)"]
                    }
                }
                }
                if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($Name)(.*) $param x notation param]} {
                lappend externalID $notation
                }
            }

            set state(inDTD) 1

            ParseEvent:DocTypeDecl [array get options] $state(doc_name) $pubidlit $systemlit $options(-internaldtd)

            set state(inDTD) 0

            }

            !--* {

            # Start of a comment
            # See if it ends in the same tag, otherwise change the
            # parsing mode

            regexp {!--(.*)} $tag discard comm1
            if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
                # processed comment (end in tag)
                uplevel #0 $options(-commentcommand) [list $comm1_1]
            } elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
                # processed comment (end in attributes)
                uplevel #0 $options(-commentcommand) [list $comm1$comm2]
            } elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
                # processed comment (end in text)
                uplevel #0 $options(-commentcommand) [list $comm1$param$empty>$comm2]
            } else {
                # start of comment
                set state(mode) comment
                set state(commentdata) "$comm1$param$empty>$text"
                continue
            }
            }

            {!\[CDATA\[*} {

            regexp {!\[CDATA\[(.*)} $tag discard cdata1
            if {[regexp {(.*)]]$} $cdata1 discard cdata2]} {
                # processed CDATA (end in tag)
                PCDATA [array get options] [subst -novariable -nocommand $cdata2]
                set text [subst -novariable -nocommand $text]
            } elseif {[regexp {(.*)]]$} $param discard cdata2]} {
                # processed CDATA (end in attribute)
                # Backslashes in param are quoted at this stage
                PCDATA [array get options] $cdata1[subst -novariable -nocommand $cdata2]
                set text [subst -novariable -nocommand $text]
            } elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
                # processed CDATA (end in text)
                # Backslashes in param and text are quoted at this stage
                PCDATA [array get options] $cdata1[subst -novariable -nocommand $param]$empty>[subst -novariable -nocommand $cdata2]
                set text [subst -novariable -nocommand $text]
            } else {
                # start CDATA
                set state(cdata) "$cdata1$param>$text"
                set state(mode) cdata
                continue
            }

            }

            !ELEMENT -
            !ATTLIST -
            !ENTITY -
            !NOTATION {
            uplevel #0 $options(-errorcommand) [list illegaldeclaration "[string range $tag 1 end] declaration not expected in document instance around line $state(line)"]
            }

            default {
            uplevel #0 $options(-errorcommand) [list unknowninstruction "unknown processing instruction \"<$tag>\" around line $state(line)"]
            }
        }
        }
        *,1,* -
        *,0,/,/ {
        # Syntax error
            uplevel #0 $options(-errorcommand) [list syntaxerror "syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)"]
        }
    }

    # Process character data

    if {$state(haveDocElement) && [llength $state(stack)]} {

        # Check if the internal DTD entity is in the text
        regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text

        # Look for entity references
        if {([array size entities] ||  [string length $options(-entityreferencecommand)]) &&  $options(-defaultexpandinternalentities) &&  [regexp {&[^;]+;} $text]} {

        # protect Tcl specials
        # NB. braces and backslashes may already be protected
        regsub -all {\\({|}|\\)} $text {\1} text
        regsub -all {([][$\\{}])} $text {\\\1} text

        # Mark entity references
        regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity [array get options] $options(-entityreferencecommand) [namespace code [list PCDATA [array get options]]] $options(entities)]] [namespace code [list DeProtect [namespace code [list PCDATA [array get options]]]]] \{\{] text
        set text "uplevel #0 [namespace code [list DeProtect1 [namespace code [list PCDATA [array get options]]]]] {{$text}}"
        eval $text
        } else {

        # Restore protected special characters
        regsub -all {\\([][{}\\])} $text {\1} text
        PCDATA [array get options] $text
        }
    } elseif {[string length [string trim $text]]} {
        uplevel #0 $options(-errorcommand) [list unexpectedtext "unexpected text \"$text\" in document prolog around line $state(line)"]
    }

    }

    # If this is the end of the document, close all open containers
    if {$options(-final) && [llength $state(stack)]} {
    eval $options(-errorcommand) [list unclosedelement "element [lindex $state(stack) end] remains unclosed around line $state(line)"]
    }

    return {}
}

}

namespace ::sgml {

ret  {::sgml::tokenise} (type sgml , type elemExpr , type elemSub , type args) {
array set options {-final 1}
    array set options $args
    set options(-final) [Boolean $options(-final)]

    # If the data is not final then there must be a variable to store
    # unused data.
    if {!$options(-final) && ![info exists options(-statevariable)]} {
    return -code error {option "-statevariable" required if not final}
    }

    # Pre-process stage
    #
    # Extract the internal DTD subset, if any

    catch {upvar #0 $options(-internaldtdvariable) dtd}
    if {[regexp {<!DOCTYPE[^[<]+\[([^]]+)\]} $sgml discard dtd]} {
    regsub {(<!DOCTYPE[^[<]+)(\[[^]]+\])} $sgml {\1\&xml:intdtd;} sgml
    }

    # Protect Tcl special characters
    regsub -all {([{}\\])} $sgml {\\\1} sgml

    # Do the translation

    if {[info exists options(-statevariable)]} {
    # Mats: Several rewrites here to handle -final 0 option.
    # If any cached unparsed xml (state(leftover)), prepend it.
    upvar #0 $options(-statevariable) state
    if {[string length $state(leftover)]} {
        regsub -all $elemExpr $state(leftover)$sgml $elemSub sgml
        set state(leftover) {}
    } else {
        regsub -all $elemExpr $sgml $elemSub sgml
    }
    set sgml "{} {} {} \{$sgml\}"

    # Performance note (Tcl 8.0):
    #   Use of lindex, lreplace will cause parsing to list object

    # This RE only fixes chopped inside tags, not chopped text.
    if {[regexp {^([^<]*)(<[^>]*$)} [lindex $sgml end] x text rest]} {
        set sgml [lreplace $sgml end end $text]
        # Mats: unmatched stuff means that it is chopped off. Cache it for next round.
        set state(leftover) $rest
    }

    # Patch from bug report #596959, Marshall Rose
    if {[string compare [lindex $sgml 4] ""]} {
        set sgml [linsert $sgml 0 {} {} {} {} {}]
    }

    } else {

    # Performance note (Tcl 8.0):
    #   In this case, no conversion to list object is performed

    # Mats: This fails if not -final and $sgml is chopped off right in a tag.   
    regsub -all $elemExpr $sgml $elemSub sgml
    set sgml "{} {} {} \{$sgml\}"
    }

    return $sgml
}

}

namespace ::sgml {

ret  {::sgml::zapWhite} (type data) {
regsub -all "\[ \t\r\n\]+" $data { } data
    return $data
}

}

namespace ::uri {

ret  {::uri::GetHostPort} (type urlvar) {
# @c Parse host and port out of the url stored in variable <a urlvar>.
    # @d Side effect: The extracted information is removed from the given url.
    # @r List containing the extracted information in a format suitable for
    # @r 'array set'.
    # @a urlvar: Name of the variable containing the url to parse.

    upvar #0 [namespace current]::basic::hostname   hostname
    upvar #0 [namespace current]::basic::hostnumber hostnumber
    upvar #0 [namespace current]::basic::port       port

    upvar $urlvar url

    set pattern "^(${hostname}|${hostnumber})(:(${port}))?"

    if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
    set fromHost    [lindex $host 0]
    set toHost  [lindex $host 1]

    set fromPort    [lindex $thePort 0]
    set toPort  [lindex $thePort 1]

    set parts(host) [string range $url $fromHost $toHost]
    set parts(port) [string range $url $fromPort $toPort]

    set  matchEnd   [lindex $match 1]
    incr matchEnd

    set url [string range $url $matchEnd end]
    }

    return [array get parts]
}

}

namespace ::uri {

ret  {::uri::GetUPHP} (type urlvar) {
# @c Parse user, password host and port out of the url stored in
    # @c variable <a urlvar>.
    # @d Side effect: The extracted information is removed from the given url.
    # @r List containing the extracted information in a format suitable for
    # @r 'array set'.
    # @a urlvar: Name of the variable containing the url to parse.

    upvar \#0 [namespace current]::basic::user      user
    upvar \#0 [namespace current]::basic::password  password
    upvar \#0 [namespace current]::basic::hostname  hostname
    upvar \#0 [namespace current]::basic::hostnumber    hostnumber
    upvar \#0 [namespace current]::basic::port      port

    upvar $urlvar url

    array set parts {user {} pwd {} host {} port {}}

    # syntax
    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
    # "//" already cut off by caller

    set upPattern "^(${user})(:(${password}))?@"

    if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} {
    set fu  [lindex $theUser 0]
    set tu  [lindex $theUser 1]

    set fp  [lindex $thePassword 0]
    set tp  [lindex $thePassword 1]

    set parts(user) [string range $url $fu $tu]
    set parts(pwd)  [string range $url $fp $tp]

    set  matchEnd   [lindex $match 1]
    incr matchEnd

    set url [string range $url $matchEnd end]
    }

    set hpPattern "^($hostname|$hostnumber)(:($port))?"

    if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
    set fh  [lindex $theHost 0]
    set th  [lindex $theHost 1]

    set fp  [lindex $thePort 0]
    set tp  [lindex $thePort 1]

    set parts(host) [string range $url $fh $th]
    set parts(port) [string range $url $fp $tp]

    set  matchEnd   [lindex $match 1]
    incr matchEnd

    set url [string range $url $matchEnd end]
    }

    return [array get parts]
}

}

namespace ::uri {

ret  {::uri::JoinFile} (type args) {
array set components {
    host {} port {} path {}
    }
    array set components $args

    switch -exact -- $::tcl_platform(platform) {
    windows {
        if {[string length $components(host)]} {
        return file://$components(host):$components(path)
        } else {
        return file://$components(path)
        }
    }
    default {
        return file://$components(host)$components(path)
    }
    }
}

}

namespace ::uri {

ret  {::uri::JoinFtp} (type args) {
array set components {
    user {} pwd {} host {} port {}
    path {} type {}
    }
    array set components $args

    set userPwd {}
    if {[string length $components(user)] || [string length $components(pwd)]} {
    set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@
    }

    set port {}
    if {[string length $components(port)]} {
    set port :$components(port)
    }

    set type {}
    if {[string length $components(type)]} {
    set type \;type=$components(type)
    }

    return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type
}

}

namespace ::uri {

ret  {::uri::JoinHttp} (type args) {
return [eval [linsert $args 0 ::uri::JoinHttpInner http 80]]
}

}

namespace ::uri {

ret  {::uri::JoinHttpInner} (type scheme , type defport , type args) {
array set components {host {} path {} query {}}
    set       components(port) $defport
    array set components $args

    set port {}
    if {[string length $components(port)] && $components(port) != $defport} {
    set port :$components(port)
    }

    set query {}
    if {[string length $components(query)]} {
    set query ?$components(query)
    }

    regsub -- {^/} $components(path) {} components(path)

    if { [info exists components(fragment)] && $components(fragment) != "" } {
    set components(fragment) "#$components(fragment)"
    } else {
    set components(fragment) ""
    }

    return $scheme://$components(host)$port/$components(path)$components(fragment)$query
}

}

namespace ::uri {

ret  {::uri::JoinHttps} (type args) {
return [eval [linsert $args 0 ::uri::JoinHttpInner https 443]]
}

}

namespace ::uri {

ret  {::uri::JoinLdap} (type args) {
return [eval [linsert $args 0 ::uri::JoinLdapInner ldap 389]]
}

}

namespace ::uri {

ret  {::uri::JoinLdapInner} (type scheme , type defport , type args) {
array set components {host {} port {} dn {} attrs {} scope {} filter {} extensions {}}
    set       components(port) $defport
    array set components $args

    set port {}
    if {[string length $components(port)] && $components(port) != $defport} {
    set port :$components(port)
    }

    set url "$scheme://$components(host)$port"

    set components(attrs) [::join $components(attrs) ","]

    set s ""
    foreach c {dn attrs scope filter extensions} {
    if {[string equal $c "dn"]} then {
        append s "/"
    } else {
        append s "?"
    }
    if {! [string equal $components($c) ""]} then {
        append url "${s}$components($c)"
        set s ""
    }
    }

    return $url
}

}

namespace ::uri {

ret  {::uri::JoinLdaps} (type args) {
return [eval [linsert $args 0 ::uri::JoinLdapInner ldaps 636]]
}

}

namespace ::uri {

ret  {::uri::JoinMailto} (type args) {
array set components {
    user {} host {}
    }
    array set components $args

    return mailto:$components(user)@$components(host)
}

}

namespace ::uri {

ret  {::uri::JoinNews} (type args) {
array set components {
    message-id {} newsgroup-name {}
    }
    array set components $args
    return news:$components(message-id)$components(newsgroup-name)
}

}

namespace ::uri {

ret  {::uri::SplitFile} (type url) {
# @c Splits the given file-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    upvar #0 [namespace current]::basic::hostname   hostname
    upvar #0 [namespace current]::basic::hostnumber hostnumber

    if {[string match "//*" $url]} {
    set url [string range $url 2 end]

    set hostPattern "^($hostname|$hostnumber)"
    switch -exact -- $::tcl_platform(platform) {
        windows {
        # Catch drive letter
        append hostPattern :?
        }
        default {
        # Proceed as usual
        }
    }

    if {[regexp -indices -- $hostPattern $url match host]} {
        set fh  [lindex $host 0]
        set th  [lindex $host 1]

        set parts(host) [string range $url $fh $th]

        set  matchEnd   [lindex $match 1]
        incr matchEnd

        set url [string range $url $matchEnd end]
    }
    }

    set parts(path) $url

    return [array get parts]
}

}

namespace ::uri {

ret  {::uri::SplitFtp} (type url) {
# @c Splits the given ftp-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    # general syntax:
    # //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
    #
    # additional rules:
    #
    # <user>:<password> are optional, detectable by presence of @.
    # <password> is optional too.
    #
    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
    #   <cwd1> "/" ..."/" <cwdN> "/" <name> [";type=" <typecode>]

    upvar \#0 [namespace current]::ftp::typepart ftptype

    array set parts {user {} pwd {} host {} port {} path {} type {}}

    # slash off possible type specification

    if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {

    set from    [lindex $ftype 0]
    set to      [lindex $ftype 1]

    set parts(type) [string range   $url $from $to]

    set from    [lindex $dummy 0]
    set url     [string replace $url $from end]
    }

    # Handle user, password, host and port

    if {[string match "//*" $url]} {
    set url [string range $url 2 end]

    array set parts [GetUPHP url]
    }

    set parts(path) [string trimleft $url /]

    return [array get parts]
}

}

namespace ::uri {

ret  {::uri::SplitHttp} (type url) {
# @c Splits the given http-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    # general syntax:
    # //<host>:<port>/<path>?<searchpart>
    #
    #   where <host> and <port> are as described in Section 3.1. If :<port>
    #   is omitted, the port defaults to 80.  No user name or password is
    #   allowed.  <path> is an HTTP selector, and <searchpart> is a query
    #   string. The <path> is optional, as is the <searchpart> and its
    #   preceding "?". If neither <path> nor <searchpart> is present, the "/"
    #   may also be omitted.
    #
    #   Within the <path> and <searchpart> components, "/", ";", "?" are
    #   reserved.  The "/" character may be used within HTTP to designate a
    #   hierarchical structure.
    #
    # path == <cwd1> "/" ..."/" <cwdN> "/" <name> ["#" <fragment>]

    upvar #0 [namespace current]::http::search  search
    upvar #0 [namespace current]::http::segment segment

    array set parts {host {} port {} path {} query {}}

    set searchPattern   "\\?(${search})\$"
    set fragmentPattern "#(${segment})\$"

    # slash off possible query. the 'search' regexp, while official,
    # is not good enough. We have apparently lots of urls in the wild
    # which contain unquoted urls with queries in a query. The RE
    # finds the embedded query, not the actual one. Using string first
    # now instead of a RE

    if {[set pos [string first ? $url]] >= 0} {
    incr pos
    set parts(query) [string range   $url $pos end]
    incr pos -1
    set url          [string replace $url $pos end]
    }

    # slash off possible fragment

    if {[regexp -indices -- $fragmentPattern $url match fragment]} {
    set from [lindex $fragment 0]
    set to   [lindex $fragment 1]

    set parts(fragment) [string range $url $from $to]

    set url [string replace $url [lindex $match 0] end]
    }

    if {[string match "//*" $url]} {
    set url [string range $url 2 end]

    array set parts [GetUPHP url]
    }

    set parts(path) [string trimleft $url /]

    return [array get parts]
}

}

namespace ::uri {

ret  {::uri::SplitHttps} (type url) {
return [SplitHttp $url]
}

}

namespace ::uri {

ret  {::uri::SplitLdap} (type url) {
# @c Splits the given Ldap-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    # general syntax:
    # //<host>:<port>/<dn>?<attrs>?<scope>?<filter>?<extensions>
    #
    #   where <host> and <port> are as described in Section 5 of RFC 1738.
    #   No user name or password is allowed.
    #   If omitted, the port defaults to 389 for ldap, 636 for ldaps
    #   <dn> is the base DN for the search
    #   <attrs> is a comma separated list of attributes description
    #   <scope> is either "base", "one" or "sub".
    #   <filter> is a RFC 2254 filter specification
    #   <extensions> are documented in RFC 2255
    #

    array set parts {host {} port {} dn {} attrs {} scope {} filter {} extensions {}}

    #          host        port           dn          attrs       scope               filter     extns
    set re {//([^:?/]+)(?::([0-9]+))?(?:/([^?]+)(?:\?([^?]*)(?:\?(base|one|sub)?(?:\?([^?]*)(?:\?(.*))?)?)?)?)?}

    if {! [regexp $re $url match parts(host) parts(port)  parts(dn) parts(attrs) parts(scope) parts(filter)  parts(extensions)]} then {
    return -code error "unable to match URL \"$url\""
    }

    set parts(attrs) [::split $parts(attrs) ","]

    return [array get parts]
}

}

namespace ::uri {

ret  {::uri::SplitLdaps} (type url) {
::uri::SplitLdap $url
}

}

namespace ::uri {

ret  {::uri::SplitMailto} (type url) {
# @c Splits the given mailto-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    if {[string match "*@*" $url]} {
    set url [::split $url @]
    return [list user [lindex $url 0] host [lindex $url 1]]
    } else {
    return [list user $url]
    }
}

}

namespace ::uri {

ret  {::uri::SplitNews} (type url) {
if { [string first @ $url] >= 0 } {
    return [list message-id $url]
    } else {
    return [list newsgroup-name $url]
    }
}

}

namespace ::uri {

ret  {::uri::canonicalize} (type uri) {
# Make uri canonical with respect to dots (path changing commands)
    #
    # Remove single dots (.)  => pwd not changing
    # Remove double dots (..) => gobble previous segment of path
    #
    # Fixes for this command:
    #
    # * Ignore any url which cannot be split into components by this
    #   module. Just assume that such urls do not have a path to
    #   canonicalize.
    #
    # * Ignore any url which could be split into components, but does
    #   not have a path component.
    #
    # In the text above 'ignore' means
    # 'return the url unchanged to the caller'.

    if {[catch {array set u [::uri::split $uri]}]} {
    return $uri
    }
    if {![info exists u(path)]} {
    return $uri
    }

    set uri $u(path)

    # Remove leading "./" "../" "/.." (and "/../")
    regsub -all -- {^(\./)+}    $uri {}  uri
    regsub -all -- {^/(\.\./)+} $uri {/} uri
    regsub -all -- {^(\.\./)+}  $uri {}  uri

    # Remove inner /./ and /../
    while {[regsub -all -- {/\./}         $uri {/} uri]} {}
    while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {}
    while {[regsub -all -- {^[^/]+/\.\./} $uri {}  uri]} {}
    # Munge trailing /..
    while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {}
    if { $uri == ".." } { set uri "/" }

    set u(path) $uri
    set uri [eval [linsert [array get u] 0 ::uri::join]]

    return $uri
}

}

namespace ::uri {

ret  {::uri::file_geturl} (type url , type args) {
variable file:counter

    set var [namespace current]::file[incr file:counter]
    upvar #0 $var state
    array set state {data {}}

    array set parts [split $url]

    set ch [open $parts(path)]
    # Could determine text/binary from file extension,
    # except on Macintosh
    # fconfigure $ch -translation binary
    set state(data) [read $ch]
    close $ch

    return $var
}

}

namespace ::uri {

ret  {::uri::geturl} (type url , type args) {
array set urlparts [split $url]

    switch -- $urlparts(scheme) {
    file {
        return [eval [linsert $args 0 file_geturl $url]]
    }
    default {
        # Load a geturl package for the scheme first and only if
        # that fails the scheme package itself. This prevents
        # cyclic dependencies between packages.
        if {[catch {package require $urlparts(scheme)::geturl}]} {
        package require $urlparts(scheme)
        }
        return [eval [linsert $args 0 $urlparts(scheme)::geturl $url]]
    }
    }
}

}

namespace ::uri {

ret  {::uri::isrelative} (type url) {
return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
}

}

namespace ::uri {

ret  {::uri::join} (type args) {
array set components $args

    return [eval [linsert $args 0 Join[string totitle $components(scheme)]]]
}

}

namespace ::uri {

ret  {::uri::register} (type schemeList , type script) {
variable schemes
    variable schemePattern
    variable url
    variable url2part

    # Check scheme and its aliases for existence.
    foreach scheme $schemeList {
    if {[lsearch -exact $schemes $scheme] >= 0} {
        return -code error  "trying to register scheme (\"$scheme\") which is already known"
    }
    }

    # Get the main scheme
    set scheme  [lindex $schemeList 0]

    if {[catch {namespace eval $scheme $script} msg]} {
    catch {namespace delete $scheme}
    return -code error  "error while evaluating scheme script: $msg"
    }

    if {![info exists ${scheme}::schemepart]} {
    namespace delete $scheme
    return -code error  "Variable \"schemepart\" is missing."
    }

    # Now we can extend the variables which keep track of the registered schemes.

    eval [linsert $schemeList 0 lappend schemes]
    set schemePattern   "([::join $schemes |]):"

    foreach s $schemeList {
    # FRINK: nocheck
    set url2part($s) "${s}:[set ${scheme}::schemepart]"
    # FRINK: nocheck
    append url "(${s}:[set ${scheme}::schemepart])|"
    }
    set url [string trimright $url |]
    return
}

}

namespace ::uri {

ret  {::uri::resolve} (type base , type url) {
if {[string length $url]} {
    if {[isrelative $url]} {

        array set baseparts [split $base]

        switch -- $baseparts(scheme) {
        http -
        https -
        ftp -
        file {
            array set relparts [split $url]
            if { [string match /* $url] } {
            catch { set baseparts(path) $relparts(path) }
            } elseif { [string match */ $baseparts(path)] } {
            set baseparts(path) "$baseparts(path)$relparts(path)"
            } else {
            if { [string length $relparts(path)] > 0 } {
                set path [lreplace [::split $baseparts(path) /] end end]
                set baseparts(path) "[::join $path /]/$relparts(path)"
            }
            }
            catch { set baseparts(query) $relparts(query) }
            catch { set baseparts(fragment) $relparts(fragment) }
            return [eval [linsert [array get baseparts] 0 join]]
        }
        default {
            return -code error "unable to resolve relative URL \"$url\""
        }
        }

    } else {
        return $url
    }
    } else {
    return $base
    }
}

}

namespace ::uri {

ret  {::uri::split} (type url , optional defaultscheme =http) {
set url [string trim $url]
    set scheme {}

    # RFC 1738: scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
    regexp -- {^([a-z0-9+.-][a-z0-9+.-]*):} $url dummy scheme

    if {$scheme == {}} {
    set scheme $defaultscheme
    }

    # ease maintenance: dynamic dispatch, able to handle all schemes
    # added in future!

    if {[::info procs Split[string totitle $scheme]] == {}} {
    error "unknown scheme '$scheme' in '$url'"
    }

    regsub -- "^${scheme}:" $url {} url

    set       parts(scheme) $scheme
    array set parts [Split[string totitle $scheme] $url]

    # should decode all encoded characters!

    return [array get parts]
}

}

namespace ::xml {

ret  {::xml::cl} (type x) {
return "\[$x\]"
}

}

namespace ::xml {

ret  {::xml::qnamesplit} (type qname) {
variable NCName
    variable Name

    set prefix {}
    set localname $qname
    if {[regexp : $qname]} {
    if {![regexp ^($NCName)?:($NCName)\$ $qname discard prefix localname]} {
        return -code error "name \"$qname\" is not a valid QName"
    }
    } elseif {![regexp ^$Name\$ $qname]} {
    return -code error "name \"$qname\" is not a valid Name"
    }

    return [list $prefix $localname]
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::NormalizeAttValue} (type opts , type value) {
# sgmlparser already has backslashes protected
    # Protect Tcl specials
    regsub -all {([][$])} $value {\\\1} value

    # Deal with white space
    regsub -all "\[$::xml::Wsp\]" $value { } value

    # Find entity refs
    regsub -all {&([^;]+);} $value {[NormalizeAttValue:DeRef $opts {\1}]} value

    return [subst $value]
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::NormalizeAttValue:DeRef} (type opts , type ref) {
switch -glob -- $ref {
    #x* {
        scan [string range $ref 2 end] %x value
        set char [format %c $value]
        # Check that the char is legal for XML
        if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
        return $char
        } else {
        return -code error "illegal character"
        }
    }
    #* {
        scan [string range $ref 1 end] %d value
        set char [format %c $value]
        # Check that the char is legal for XML
        if {[regexp [format {^[%s]$} $::xml::Char] $char]} {
        return $char
        } else {
        return -code error "illegal character"
        }
    }
    lt -
    gt -
    amp -
    quot -
    apos {
        array set map {lt < gt > amp & quot \" apos '}
        return $map($ref)
    }
    default {
        # A general entity.  Must resolve to a text value - no element structure.

        array set options $opts
        upvar #0 $options(entities) map

        if {[info exists map($ref)]} {

        if {[regexp < $map($ref)]} {
            return -code error "illegal character \"<\" in attribute value"
        }

        if {![regexp & $map($ref)]} {
            # Simple text replacement
            return $map($ref)
        }

        # There are entity references in the replacement text.
        # Can't use child entity parser since must catch element structures

        return [NormalizeAttValue $opts $map($ref)]

        } elseif {[string compare $options(-entityreferencecommand) "::sgml::noop"]} {

        set result [uplevel #0 $options(-entityreferencecommand) [list $ref]]

        return $result

        } else {
        return -code error "unable to resolve entity reference \"$ref\""
        }
    }
    }
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::ParseAttrs} (type opts , type attrs) {
set result {}

    while {[string length [string trim $attrs]]} {
    if {[regexp [::sgml::cl $::xml::Wsp]*($::xml::Name)[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')([::sgml::cl ^<]*?)\\2(.*) $attrs discard attrName delimiter value attrs]} {
        lappend result $attrName [NormalizeAttValue $opts $value]
    } elseif {[regexp [::sgml::cl $::xml::Wsp]*$::xml::Name[::sgml::cl $::xml::Wsp]*=[::sgml::cl $::xml::Wsp]*("|')[::sgml::cl ^<]*\$ $attrs]} {
        return -code error [list {unterminated attribute value} $result $attrs]
    } else {
        return -code error "invalid attribute list"
    }
    }

    return $result
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::ParseEmpty} (type tag , type attr , type e) {
switch -glob [string length $e],[regexp "/[::xml::cl $::xml::Wsp]*$" $attr] {
    0,0 {
        return {}
    }
    0,* {
        return /
    }
    default {
        return $e
    }
    }
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::ParseEntity} (type data) {
set data [string trim $data]
    if {[regexp $::sgml::ExternalEntityExpr $data discard type delimiter1 id1 discard delimiter2 id2 optNDATA ndata]} {
    switch $type {
        PUBLIC {
        return [list external $id2 $id1 $ndata]
        }
        SYSTEM {
        return [list external $id1 {} $ndata]
        }
    }
    } elseif {[regexp {^("|')(.*?)\1$} $data discard delimiter value]} {
    return [list internal $value]
    } else {
    return -code error "badly formed entity declaration"
    }
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::configure} (type name , type args) {
upvar \#0 [namespace current]::$name parser

    # BUG: very crude, no checks for illegal args
    # Mats: Should be synced with sgmlparser.tcl
    set options {-elementstartcommand -elementendcommand  -characterdatacommand -processinginstructioncommand  -externalentitycommand -xmldeclcommand  -doctypecommand -commentcommand  -entitydeclcommand -unparsedentitydeclcommand  -parameterentitydeclcommand -notationdeclcommand  -elementdeclcommand -attlistdeclcommand  -paramentityparsing -defaultexpandinternalentities  -startdoctypedeclcommand -enddoctypedeclcommand  -entityreferencecommand -warningcommand  -defaultcommand -unknownencodingcommand -notstandalonecommand  -startcdatasectioncommand -endcdatasectioncommand  -errorcommand -final  -validate -baseuri -baseurl  -name -cmd -emptyelement  -parseattributelistcommand -parseentitydeclcommand  -normalize -internaldtd -dtdsubset  -reportempty -ignorewhitespace  -reportempty  }
    set usage [join $options ", "]
    regsub -all -- - $options {} options
    set pat ^-([join $options |])$
    foreach {flag value} $args {
    if {[regexp $pat $flag]} {
        # Validate numbers
        if {[info exists parser($flag)] &&  [string is integer -strict $parser($flag)] &&  ![string is integer -strict $value]} {
        return -code error "Bad value for $flag ($value), must be integer"
        }
        set parser($flag) $value
    } else {
        return -code error "Unknown option $flag, can be: $usage"
    }
    }

    # Backward-compatibility: -baseuri is a synonym for -baseurl
    catch {set parser(-baseuri) $parser(-baseurl)}

    return {}
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::create} (type name) {
# Initialise state variable
    upvar \#0 [namespace current]::$name parser
    array set parser [list -name $name           -cmd [uplevel 3 namespace current]::$name   -final 1                    -validate 0                     -statevariable [namespace current]::$name   -baseuri {}                     internaldtd {}                  entities [namespace current]::Entities$name     extentities [namespace current]::ExtEntities$name   parameterentities [namespace current]::PEntities$name   externalparameterentities [namespace current]::ExtPEntities$name    elementdecls [namespace current]::ElDecls$name  attlistdecls [namespace current]::AttlistDecls$name     notationdecls [namespace current]::NotDecls$name    depth 0                         leftover {}                                      ]

    # Initialise entities with predefined set
    array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]

    return $parser(-cmd)
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::createentityparser} (type parent , type name) {
upvar #0 [namespace current]::$parent p

    # Initialise state variable
    upvar \#0 [namespace current]::$name external
    array set external [array get p]

    regsub $parent $p(-cmd) {} parentns

    array set external [list -name $name         -cmd $parentns$name                 -statevariable [namespace current]::$name   internaldtd {}                  line 0                      ]
    incr external(depth)

    return $external(-cmd)
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::delete} (type name) {
upvar \#0 [namespace current]::$name parser
    catch {::sgml::ParserDelete $parser(-statevariable)}
    catch {unset parser}
    return {}
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::get} (type name , type method , type args) {
upvar #0 [namespace current]::$name parser

    switch -- $method {

    elementdecl {
        switch [llength $args] {

        0 {
            # Return all element declarations
            upvar #0 $parser(elementdecls) elements
            return [array get elements]
        }

        1 {
            # Return specific element declaration
            upvar #0 $parser(elementdecls) elements
            if {[info exists elements([lindex $args 0])]} {
            return [array get elements [lindex $args 0]]
            } else {
            return -code error "element \"[lindex $args 0]\" not declared"
            }
        }

        default {
            return -code error "wrong number of arguments: should be \"elementdecl ?element?\""
        }
        }
    }

    attlist {
        if {[llength $args] != 1} {
        return -code error "wrong number of arguments: should be \"get attlist element\""
        }

        upvar #0 $parser(attlistdecls)

        return {}
    }

    entitydecl {
    }

    parameterentitydecl {
    }

    notationdecl {
    }

    default {
        return -code error "unknown method \"$method\""
    }
    }

    return {}
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::parse} (type name , type xml , type args) {
array set options $args
    upvar \#0 [namespace current]::$name parser
    variable tokExpr
    variable substExpr

    # Mats:
    if {[llength $args]} {
    eval {configure $name} $args
    }

    set parseOptions [list  -emptyelement [namespace code ParseEmpty]  -parseattributelistcommand [namespace code ParseAttrs]  -parseentitydeclcommand [namespace code ParseEntity]  -normalize 0]
    eval lappend parseOptions  [array get parser -*command]  [array get parser -reportempty]  [array get parser -ignorewhitespace]  [array get parser -name]  [array get parser -cmd]  [array get parser -baseuri]  [array get parser -validate]  [array get parser -final]  [array get parser -defaultexpandinternalentities]  [array get parser entities]  [array get parser extentities]  [array get parser parameterentities]  [array get parser externalparameterentities]  [array get parser elementdecls]  [array get parser attlistdecls]  [array get parser notationdecls]

    # Mats:
    # If -final 0 we also need to maintain the state with a -statevariable !
    if {!$parser(-final)} {
    eval lappend parseOptions [array get parser -statevariable]
    }

    set dtdsubset no
    catch {set dtdsubset $options(-dtdsubset)}
    switch -- $dtdsubset {
    internal {
        # Bypass normal parsing
        lappend parseOptions -statevariable $parser(-statevariable)
        array set intOptions [array get ::sgml::StdOptions]
        array set intOptions $parseOptions
        ::sgml::ParseDTD:Internal [array get intOptions] $xml
        return {}
    }
    external {
        # Bypass normal parsing
        lappend parseOptions -statevariable $parser(-statevariable)
        array set intOptions [array get ::sgml::StdOptions]
        array set intOptions $parseOptions
        ::sgml::ParseDTD:External [array get intOptions] $xml
        return {}
    }
    default {
        # Pass through to normal processing
    }
    }

    lappend tokenOptions   -internaldtdvariable [namespace current]::${name}(internaldtd)
    
    # Mats: If -final 0 we also need to maintain the state with a -statevariable !
    if {!$parser(-final)} {
    eval lappend tokenOptions [array get parser -statevariable]  [array get parser -final]
    }
    
    # Mats:
    # Why not the first four? Just padding? Lrange undos \n interp.
    # It is necessary to have the first four as well if chopped off in
    # middle of pcdata.
    set tokenised [lrange  [eval {::sgml::tokenise $xml $tokExpr $substExpr} $tokenOptions]  0 end]

    lappend parseOptions -internaldtd [list $parser(internaldtd)]
    eval ::sgml::parseEvent [list $tokenised] $parseOptions

    return {}
}

}

namespace ::xml::tclparser {

ret  {::xml::tclparser::reset} (type name) {
upvar \#0 [namespace current]::$name parser

    # Has this parser object been properly initialised?
    if {![info exists parser] ||  ![info exists parser(-name)]} {
    return [create $name]
    }

    array set parser {
    -final 1
    depth 0
    leftover {}
    }

    foreach var {Entities ExtEntities PEntities ExtPEntities ElDecls AttlistDecls NotDecls} {
    catch {unset [namespace current]::${var}$name}
    }

    # Initialise entities with predefined set
    array set [namespace current]::Entities$name [array get ::sgml::EntityPredef]

    return {}
}

}

namespace ::xml {

ret  {::xml::zapWhite} (type data) {
regsub -all "\[ \t\r\n\]+" $data { } data
    return $data
}

}

ret  {Draw_comm} (optional unitd =all) {
# Raffiche les connexions d'un composant (entrantes ou sortantes)
# ou toutes les connexions (unitd == "all")

    #** global variables
    global liste_cnx_in  dico_cnx_out  dico_caract_cnx dico_units
    global viewcommcheck
    #** Variables specifiques pour le dessin
    global plot
    global coord_points_X coord_points_Y

    global coordunit
    global DRAW
    global zoomfactor

    set w $DRAW(window)
    set info .gui.pr.tools.infolabel
    set ray $DRAW(ray)

#================================================================
#=== destruction des communications
#================================================================

    if {$unitd == "all"} {
        $w delete COMM_tag(all)
        $w dtag COMM_tag(all)
    } else {
        $w delete COMM_tag($unitd)
        $w dtag COMM_tag($unitd)
    }
    # S'il ne faut pas dessiner les connexions, c'est fini
    if {$viewcommcheck == 0} {return}

#================================================================
#===  Etablissement de la liste des couples de composants
#===  et établissement de la liste des communications de chaque couple
#================================================================

    set liste_couples {}

    foreach clef_cnx $liste_cnx_in {
        set appli_source $dico_caract_cnx($clef_cnx.app_source)
        set appli_cible  $dico_caract_cnx($clef_cnx.app_cible)
        set comp_source $dico_caract_cnx($clef_cnx.comp_source)
        set comp_cible  $dico_caract_cnx($clef_cnx.comp_cible)

        set clef_comp_source $appli_source.$comp_source
        set clef_comp_cible  $appli_cible.$comp_cible

        if {$unitd != "all"} {if {$unitd != $clef_comp_source && $unitd != $clef_comp_cible } {continue}}

        # Si on n'a pas encore vu ce couple de composants
        if { ! [info exists nbcom_parcouple_unite($clef_comp_source.$clef_comp_cible)] } {
            # Ajoute le couple à la liste
            lappend liste_couples $clef_comp_source.$clef_comp_cible
            # Initialise le nb de comm total
            set nbcom_parcouple_unite($clef_comp_source.$clef_comp_cible) 0
        }
        # Ajoute la connexion à la liste pour ce couple
        lappend table_liste_cnx($clef_comp_source.$clef_comp_cible) $clef_cnx
    }

    # Pour tous les couples d'unités
    foreach couple $liste_couples {
        # Compte le nombre total de connexions
        set nbcom_parcouple_unite($couple) [llength table_liste_cnx($couple)]
    }

#================================================================
#===  établissement de la liste des paires de composants
#===  et établissement de la liste des communications de chaque paire dans chaque sens (montant ou descendant)
#================================================================

    # Un couple : (a,b) est différent de (b,a)
    # Une paire : (a,b) similaire à (b,a)
    set liste_paires {}

    # Pour tous les couples de composants
    foreach couple $liste_couples {
        # Si le couple n'a pas déjà été traité
        if { [info exists table_liste_cnx($couple)] } {
            # Enregistre la paire dans la liste
            lappend liste_paires $couple
            
            # Crée la liste des connexions pour cette paire : cnx dans un sens et dans l'autre
            # ---------------------------------------------
            
            # Regarde la première connexion
            set clef_cnx [lindex $table_liste_cnx($couple) 0]
            set appli_source $dico_caract_cnx($clef_cnx.app_source)
            set appli_cible  $dico_caract_cnx($clef_cnx.app_cible)
            set comp_source $dico_caract_cnx($clef_cnx.comp_source)
            set comp_cible  $dico_caract_cnx($clef_cnx.comp_cible)
            set clef_comp_source $appli_source.$comp_source
            set clef_comp_cible  $appli_cible.$comp_cible
    
            # Regarde quelle unité est le plus bas dans le graphe
            set y_source $dico_units($clef_comp_source.coor_y)
            set y_cible  $dico_units($clef_comp_cible.coor_y)
    
            # Si l'unité source est la plus haute
            if { $y_source < $y_cible } {
                # Mémorise le sens
                set sens descend
                set sens_inverse monte
            } else {
                set sens monte
                set sens_inverse descend
            }
            # Mémorise la liste des cnx dans une nouvelle table
            set liste_cnx($clef_comp_source.$clef_comp_cible.$sens) $table_liste_cnx($clef_comp_source.$clef_comp_cible)
            # Elimine la liste des cnx dans ce sens
            unset table_liste_cnx($clef_comp_source.$clef_comp_cible)
                        
            # S'il existe des connexions dans l'autre sens
            if { [info exists table_liste_cnx($clef_comp_cible.$clef_comp_source)] } {                
                # Mémorise la liste des cnx dans une nouvelle table
                set liste_cnx($clef_comp_source.$clef_comp_cible.$sens_inverse) $table_liste_cnx($clef_comp_cible.$clef_comp_source)
                # Elimine la liste des cnx dans le sens inverse
                unset table_liste_cnx($clef_comp_cible.$clef_comp_source)
            } else {
                # Aucune connexion dans l'autre sens
                set liste_cnx($clef_comp_source.$clef_comp_cible.$sens_inverse) {}
            }
        }
    }
    array unset table_liste_cnx
    
#================================================================
# Determine le point milieu de chaque fil de communication
#================================================================

    # Pour toutes les paires d'unités
    foreach paire $liste_paires {
        # 1ère étape : étudier l'espace total occcupé par tous les points milieu
        # ----------------------------------------------------------------------
        
        # Détermine le nombre max de pictogrammes de transformations dans chaque sens
        set nbmax_transfo(descend) 0
        set nbmax_transfo(monte) 0

        # Pour les sens montant et descendant
        foreach sens {monte descend} {
            # Nombre de connexions dans ce sens entre les deux composants de la paire
            set nb_cnx($sens) [llength $liste_cnx($paire.$sens)]
            
            # Pour toutes les connexions dans ce sens entre les deux composants de la paire
            foreach clef_cnx $liste_cnx($paire.$sens) {
                # Transformations de la connexions
                set src_time_op  $dico_caract_cnx($clef_cnx.src_time_op)
                set src_add_val  $dico_caract_cnx($clef_cnx.src_add_val)
                set src_mult_val $dico_caract_cnx($clef_cnx.src_mult_val)
                set tgt_time_op  $dico_caract_cnx($clef_cnx.tgt_time_op)
                set tgt_add_val  $dico_caract_cnx($clef_cnx.tgt_add_val)
                set tgt_mult_val $dico_caract_cnx($clef_cnx.tgt_mult_val)
                set remail       $dico_caract_cnx($clef_cnx.remail)
    
                # Détermine la liste des pictogrammes de transformations 
                # dans l'ordre où elles sont effectivement appliquées :
                #    -1- source local transf.  -2- middle transf. -3- target local transf.
                
                set liste_transfo($clef_cnx) {}
                if { $src_add_val != 0 } { lappend liste_transfo($clef_cnx) add }
                if { $src_mult_val != 1 } { lappend liste_transfo($clef_cnx) multiply }
                switch $src_time_op {
                    taverage {lappend liste_transfo($clef_cnx) average}
                    accumul {lappend liste_transfo($clef_cnx) accumulate}
                }
                if { $remail != "" } { lappend liste_transfo($clef_cnx) remaillage }
                if { $tgt_time_op == "time_linear"} { lappend liste_transfo($clef_cnx) interpol }
                if { $tgt_add_val != 0 } { lappend liste_transfo($clef_cnx) add }
                if { $tgt_mult_val != 1 } { lappend liste_transfo($clef_cnx) multiply }
                # Calcule le nombre total de pictogrammes de transformations
                set nb_transfo($clef_cnx) [llength $liste_transfo($clef_cnx)]
            
                # Détermine le nombre max de pictogrammes de transformations dans chaque sens
                if { $nb_transfo($clef_cnx) > $nbmax_transfo($sens) } {
                    set nbmax_transfo($sens) $nb_transfo($clef_cnx)
                }
            }
        }
            
        # Les pictogrammes de transformations des cnx descendantes sont alignés horizontalement
        # Ceux des connexions montantes sont alignés verticalement
        
        # Hauteur totale de la zone des points milieu : 
        #   hauteur des pictogrm alignés verticalement plus nbre de lignes
        set hauteur [expr ($nbmax_transfo(monte) + $nb_cnx(descend)) * 30]
        # Largeur totale de la zone des points milieu
        #   largeur des pictogrm alignés horizontalement plus nbre de colonnes
        set largeur [expr ($nbmax_transfo(descend) + $nb_cnx(monte)) * 25] 
        # 30 et 25 pixels  sont les dimensions d'un pictogramme

        # 2ème étape : définir la position de tous les points milieu
        # ----------------------------------------------------------

        # Indicateur d'initialisation
        set initial 1

        # Pour toutes les connexions descendantes entre les deux composants de la paire
        foreach clef_cnx $liste_cnx($paire.descend) {

            # Si première cnx de la liste
            if  { $initial } {
                set initial 0

                # Lit les données de la connexion
                set appli_source $dico_caract_cnx($clef_cnx.app_source)
                set appli_cible  $dico_caract_cnx($clef_cnx.app_cible)
                set comp_source $dico_caract_cnx($clef_cnx.comp_source)
                set comp_cible  $dico_caract_cnx($clef_cnx.comp_cible)
                set clef_comp_source $appli_source.$comp_source
                set clef_comp_cible  $appli_cible.$comp_cible
    
                # Si un des deux composants est rétréci
                if {   $dico_units($clef_comp_source.expand) == 0
                    || $dico_units($clef_comp_cible.expand) == 0} {
                    # Rien à calculer car on ne dessinera pas les connexions une à une
                    break;
                }    
                # Détermine le milieu du composant source
                set mil_source_x [expr $dico_units($clef_comp_source.coor_x) + $dico_units($clef_comp_source.largeur) / 2]
                set mil_source_y [expr $dico_units($clef_comp_source.coor_y) + $DRAW(heigthunit) / 2]
                # Détermine le milieu du composant cible
                set mil_cible_x [expr $dico_units($clef_comp_cible.coor_x) + $dico_units($clef_comp_cible.largeur) / 2]
                set mil_cible_y [expr $dico_units($clef_comp_cible.coor_y) + $DRAW(heigthunit) / 2]

                # Détermine le milieu géométrique entre les deux composants
                set milieu_comp_x [expr ($mil_source_x + $mil_cible_x) / 2]
                set milieu_comp_y [expr ($mil_source_y + $mil_cible_y) / 2]
                
                # Ordonnée du point milieu pour la 1ère connexion : tout en haut
                #  mais en dessous des pictogrammes des connexions montantes
                set point_milieu_y [expr round( $milieu_comp_y - ($hauteur - 30) / 2 + 30 * $nbmax_transfo(monte) )]
                # Abscisse du point milieu pour toutes les connexions descendantes : à gauche des connexions montantes
                set point_milieu_x_general [expr round( $milieu_comp_x + ($largeur - 25) / 2 - 25 * $nb_cnx(monte) )]
            }
            
            # Abscisse du point milieu pour cette connexion : à gauche du point milieu general
            set point_milieu_x [expr round( $point_milieu_x_general - 25 * $nb_transfo($clef_cnx) / 2 )]
            
            # Mémorise les coordonnées du point milieu de la cnx
            set table_points_milieu($clef_cnx.x) $point_milieu_x
            set table_points_milieu($clef_cnx.y) $point_milieu_y

            # Calcule l'ordonnée du point milieu pour la connexion suivante
            incr point_milieu_y 30
        }

        # Indicateur d'initialisation
        set initial 1

        # Pour toutes les connexions montantes entre les deux composants de la paire
        foreach clef_cnx $liste_cnx($paire.monte) {

            # Si première cnx de la liste
            if  { $initial } {
                set initial 0

                # Lit les données de la connexion
                set appli_source $dico_caract_cnx($clef_cnx.app_source)
                set appli_cible  $dico_caract_cnx($clef_cnx.app_cible)
                set comp_source $dico_caract_cnx($clef_cnx.comp_source)
                set comp_cible  $dico_caract_cnx($clef_cnx.comp_cible)
                set clef_comp_source $appli_source.$comp_source
                set clef_comp_cible  $appli_cible.$comp_cible
    
                # Si un des deux composants est rétréci
                if {   $dico_units($clef_comp_source.expand) == 0
                    || $dico_units($clef_comp_cible.expand) == 0} {
                    # Rien à calculer car on ne dessinera pas les connexions une à une
                    break;
                }    
                # Détermine le milieu du composant source
                set mil_source_x [expr $dico_units($clef_comp_source.coor_x) + $dico_units($clef_comp_source.largeur) / 2]
                set mil_source_y [expr $dico_units($clef_comp_source.coor_y) + $DRAW(heigthunit) / 2]
                # Détermine le milieu du composant cible
                set mil_cible_x [expr $dico_units($clef_comp_cible.coor_x) + $dico_units($clef_comp_cible.largeur) / 2]
                set mil_cible_y [expr $dico_units($clef_comp_cible.coor_y) + $DRAW(heigthunit) / 2]

                # Détermine le milieu géométrique entre les deux composants
                set milieu_comp_x [expr ($mil_source_x + $mil_cible_x) / 2]
                set milieu_comp_y [expr ($mil_source_y + $mil_cible_y) / 2]
                
                # Abscisse du point milieu pour la 1ère connexion : tout à fait à gauche
                #  mais à droite des pictogrammes des connexions descendantes
                set point_milieu_x [expr round( $milieu_comp_x - ($largeur - 25) / 2 + 25 * $nbmax_transfo(descend))]
                # Ordonnée du point milieu pour toutes les connexions montantes : au dessus des connexions descendantes
                set point_milieu_y_general [expr round( $milieu_comp_y + ($hauteur - 30) / 2 - 30 * $nb_cnx(descend) )]
            }
            
            # Ordonnée du point milieu pour cette connexion : au dessous du point milieu general
            set point_milieu_y [expr round( $point_milieu_y_general - 30 * $nb_transfo($clef_cnx) / 2 )]
            
            # Mémorise les coordonnées du point milieu de la cnx
            set table_points_milieu($clef_cnx.x) $point_milieu_x
            set table_points_milieu($clef_cnx.y) $point_milieu_y

            # Calcule l'abscisse du point milieu pour la connexion suivante
            incr point_milieu_x 25
        }

    }

#================================================================
#=== affichage des communications
#================================================================

    # Pour toutes les paires de composants
    foreach paire $liste_paires {

        # Pour les sens montant et descendant
        foreach sens {monte descend} {
            # Pour toutes les connexions entre les deux composants de la paire
            foreach clef_cnx $liste_cnx($paire.$sens) {
    
                set appli_source $dico_caract_cnx($clef_cnx.app_source)
                set appli_cible  $dico_caract_cnx($clef_cnx.app_cible)
                set comp_source $dico_caract_cnx($clef_cnx.comp_source)
                set comp_cible  $dico_caract_cnx($clef_cnx.comp_cible)
                set clef_comp_source $appli_source.$comp_source
                set clef_comp_cible  $appli_cible.$comp_cible
    
                # Determine la clef des points de couplage source et cible
                set champ_source $dico_caract_cnx($clef_cnx.champ_source)
                set champ_cible  $dico_caract_cnx($clef_cnx.champ_cible)
                set clef_point_source $clef_comp_source.$champ_source.o
                set clef_point_cible  $clef_comp_cible.$champ_cible.i
    
                # Si un des deux composants est rétréci
                if {   $dico_units($clef_comp_source.expand) == 0
                    || $dico_units($clef_comp_cible.expand) == 0} {
    
                    # Si les deux composants sont rétrécis
                    if {   $dico_units($clef_comp_source.expand) == 0
                        && $dico_units($clef_comp_cible.expand) == 0} {
    
                        set x1 [expr $coord_points_X($clef_point_source)+$dico_units($clef_comp_source.coor_x)]
                        set y1 [expr $coord_points_Y($clef_point_source)+$ray+$dico_units($clef_comp_source.coor_y)]
                        set x2 [expr $coord_points_X($clef_point_cible)+$dico_units($clef_comp_cible.coor_x)]
                        set y2 [expr $coord_points_Y($clef_point_cible)-$ray+$dico_units($clef_comp_cible.coor_y)]
                        if {$y1 < $y2 } {
                            set x3 [expr $x1+($x2-$x1)/10 ]
                            set x4 [expr $x2-($x2-$x1)/10 ]
                            set y3 [expr $y1+($y2-$y1)/10 +12]
                            set y4 [expr $y2-($y2-$y1)/10 -12]
                            set midleX [expr $x3+($x4-$x3)/3]
                            set midleY [expr $y3+($y4-$y3)/3]
                        } else {
                            set midleX [expr ($x1+$x2)/2]
                            set midleY [expr ($y1+$y2)/2]
                        }
                        if {[distming $x1 $y1 $x2 $y2]} {
                            set itemcom [$w create line [chemin $x1 $y1 $x2 $y2] -smooth 1 -fill grey80 -width 3]
                            $w addtag COMM_tag(all) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                            set itemcom [$w create rectangle [expr $midleX-8] [expr $midleY-6] [expr $midleX+8] [expr $midleY+5] -fill white  -outline white ]
                            $w addtag COMM_tag(all) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                            set itemcom [$w create text $midleX $midleY -text "$nbcom_parcouple_unite($clef_comp_source.$clef_comp_cible)" -font {helvetica -10 bold} -fill black  ]
                            $w addtag COMM_tag(all) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                        }
                    } else {
    
                        # Un seul des deux composants est rétréci
                        # --> on n'affiche aucun fil de connexion
                    }
                    # Ne traite pas les autres cnx de la paire
                    break
    
                } else {
                    # Aucun des deux composants n'est rétréci
                    #=====affichage liaison
    
                    #===type de trait
                    set dash {2 2}
                    #===epaisseur
                    set wid 1
                    #====couleur
                    set colorcom [color_rgb 128 80 0]
    
                    # Point de départ de la liaison
                    set x1 [expr $coord_points_X($clef_point_source)+$dico_units($clef_comp_source.coor_x)]
                    set y1 [expr $coord_points_Y($clef_point_source)+$ray+$dico_units($clef_comp_source.coor_y)]
    
                    # Point d'arrivée
                    set x2 [expr $coord_points_X($clef_point_cible)+$dico_units($clef_comp_cible.coor_x)]
                    set y2 [expr $coord_points_Y($clef_point_cible)-$ray+$dico_units($clef_comp_cible.coor_y)]
    
                    # Si liaison entre deux points du même composant
                    if {$clef_comp_source == $clef_comp_cible} {
                        set itemcom [$w create line $x1 [expr $y1-2*$ray] $x2 [expr $y2+2*$ray] -fill  $colorcom -width $wid -dash $dash]
                        $w addtag COMM_tag(all) withtag $itemcom
                        $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                        $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                        $w addtag tag_connexions($clef_cnx) withtag $itemcom
                        $w addtag tag_fils_connexions($clef_cnx) withtag $itemcom
    
                    } else {
    
                        # Si la distance entre le départ et l'arrivée n'est pas trop grande
                        if {[distmin $x1 $y1 $x2 $y2]} {

                            # Si la cnx a des transformations
                            if { $nb_transfo($clef_cnx) != "0" } {
                                # Affiche la liaison en deux morceaux :
                                #    1 :   du composant source au point milieu
                                #    2 :   du point milieu au composant cible
        
                                # Si on va de source dessus à cible dessous
                                # if  $y2 > $y1 
                                if { $dico_units($clef_comp_source.coor_y) < $dico_units($clef_comp_cible.coor_y) } {
                                    # On traverse le point milieu par l'horizontale
                                    # demi-largeur de l'ensemble des pictogrammes des transformations
                                    set demi_largeur [expr 25 * $nb_transfo($clef_cnx) / 2]
                                    set agauche_milieu_x [expr $table_points_milieu($clef_cnx.x) - $demi_largeur]
                                    set adroite_milieu_x [expr $table_points_milieu($clef_cnx.x) + $demi_largeur]
                                    # Si on va de gauche à droite
                                    if { $x1 < $x2 } {
                                        set cote_approche gauche
                                        set avant_milieu_x $agauche_milieu_x
                                        set apres_milieu_x $adroite_milieu_x
                                    } else {
                                        set cote_approche droit
                                        set avant_milieu_x $adroite_milieu_x
                                        set apres_milieu_x $agauche_milieu_x
                                    }
                                    set avant_milieu_y $table_points_milieu($clef_cnx.y)
                                    set apres_milieu_y $table_points_milieu($clef_cnx.y)
                                } else {
                                    set cote_approche bas
                                    # On traverse le point milieu par la verticale (et par dessous)                            
                                    # demi-hauteur de l'ensemble des pictogrammes des transformations
                                    set demi_hauteur [expr 30 * $nb_transfo($clef_cnx) / 2]
                                    set avant_milieu_y [expr $table_points_milieu($clef_cnx.y) + $demi_hauteur]
                                    set apres_milieu_y [expr $table_points_milieu($clef_cnx.y) - $demi_hauteur]
                                    
                                    set avant_milieu_x $table_points_milieu($clef_cnx.x)
                                    set apres_milieu_x $table_points_milieu($clef_cnx.x)
                                }
        
                                # 1er morceau  :   du composant source au point milieu
                                # ----------------------------------------------------
        
                                set demi_chemin [demi_chemin_1 $x1 $y1 $avant_milieu_x $avant_milieu_y $cote_approche $clef_comp_source]
                                set itemcom [$w create line $demi_chemin -smooth 1 -fill $colorcom -width $wid -dash $dash]
                                $w addtag COMM_tag(all) withtag $itemcom
                                $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                                $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                                $w addtag tag_connexions($clef_cnx) withtag $itemcom
                                $w addtag tag_fils_connexions($clef_cnx) withtag $itemcom
        
                                # 2ème morceau  :   du point milieu au composant cible
                                # ----------------------------------------------------
        
                                set demi_chemin [demi_chemin_2 $apres_milieu_x $apres_milieu_y $x2 $y2 $cote_approche $clef_comp_cible]
                                set itemcom [$w create line $demi_chemin -smooth 1 -fill $colorcom -width $wid -dash $dash]
                                $w addtag COMM_tag(all) withtag $itemcom
                                $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                                $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                                $w addtag tag_connexions($clef_cnx) withtag $itemcom
                                $w addtag tag_fils_connexions($clef_cnx) withtag $itemcom
        
                                # 3eme : Affiche les symboles (pictogrammes) des transformations
                                # --------------------------------------------------------------
                                
                                # Si la connexion est "montante"
                                if { $cote_approche == "bas" } {
                                    # Dispose les pictogrammes sur une colonne en partant du bas
                                    set offset_1ere_tranfo_y [expr 30 * ($nb_transfo($clef_cnx) - 1) / 2]
                                    set pos_tranfo_y [expr $table_points_milieu($clef_cnx.y) + $offset_1ere_tranfo_y]
                                    set increment_y -30
                                    set pos_tranfo_x $table_points_milieu($clef_cnx.x)
                                    set increment_x 0
                                } else {
                                    # Dispose les pictogrammes sur une ligne
                                    set offset_1ere_tranfo_x [expr 25 * ($nb_transfo($clef_cnx) - 1) / 2]
                                    # Si on va de source à gauche à cible à droite
                                    if { $x1 < $x2 } {
                                        # Dispose les pictogrammes sur une ligne en partant de la gauche
                                        set pos_tranfo_x [expr $table_points_milieu($clef_cnx.x) - $offset_1ere_tranfo_x]
                                        set increment_x 25
                                    } else {
                                        # Dispose les pictogrammes sur une ligne en partant de la droite
                                        set pos_tranfo_x [expr $table_points_milieu($clef_cnx.x) + $offset_1ere_tranfo_x]
                                        set increment_x -25
                                    }
                                    set pos_tranfo_y $table_points_milieu($clef_cnx.y)
                                    set increment_y 0
                                }
                                
                                # Pour toutes les tranformations existantes
                                foreach transfo $liste_transfo($clef_cnx) {
                                    # Met un pictogramme dans le graphe
                                    set itemcom [$w create image $pos_tranfo_x $pos_tranfo_y -image img_$transfo]
                                    $w addtag COMM_tag(all) withtag $itemcom
                                    $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                                    $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                                    $w addtag tag_connexions($clef_cnx) withtag $itemcom
                                    # Calcule les coordonnées de la transfo suivante
                                    incr pos_tranfo_x $increment_x
                                    incr pos_tranfo_y $increment_y
                                }
                            } else {
                                # S'il y a au moins un pictogramme de transformation dans ce sens
                                if { $nbmax_transfo($sens) > 0 } {
                                    # Affiche la liaison en un seul morceau forcé de passer par le point milieu
                                    set milieu_x $table_points_milieu($clef_cnx.x)
                                    set milieu_y $table_points_milieu($clef_cnx.y)
                                    set itemcom [$w create line [chemin_force $x1 $y1 $x2 $y2 $milieu_x $milieu_y]  -smooth 1 -fill  $colorcom -width $wid -dash $dash]
                                } else {
                                    # Affiche la liaison en un seul morceau
                                    set itemcom [$w create line [chemin $x1 $y1 $x2 $y2]  -smooth 1 -fill  $colorcom -width $wid -dash $dash]
                                }
                                $w addtag COMM_tag(all) withtag $itemcom
                                $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                                $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                                $w addtag tag_connexions($clef_cnx) withtag $itemcom
                                $w addtag tag_fils_connexions($clef_cnx) withtag $itemcom
                            }
                        
                        } else {
                            # Les deux composants sont trop éloignés l'un de l'autre
                            # On trace juste le départ et l'arrivée de la liaison : le milieu est caché

                            set itemcom [$w create line $x1 $y1 $x1 [expr $y1+20]  -fill  $colorcom -width $wid -dash $dash]
                            $w addtag COMM_tag(all) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                            $w addtag tag_connexions($clef_cnx) withtag $itemcom
                            $w addtag tag_fils_connexions($clef_cnx) withtag $itemcom
                            set itemcom [$w create line  $x2 $y2 $x2 [expr $y2-20]  -fill  $colorcom -width $wid -dash $dash]
                            $w addtag COMM_tag(all) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                            $w addtag tag_connexions($clef_cnx) withtag $itemcom
                            $w addtag tag_fils_connexions($clef_cnx) withtag $itemcom
                            # Le fil central qui relie les deux extrémités est caché
                            # Il n'est révélé que lorsque la souris survole l'une des extrémité
                            set itemcom [$w create line  $x1  [expr $y1+20]  $x2 [expr $y2-20]  -fill  $colorcom -width $wid -dash $dash -state hidden]
                            $w addtag COMM_tag(all) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_source) withtag $itemcom
                            $w addtag COMM_tag($clef_comp_cible) withtag $itemcom
                            $w addtag tag_fils_connexions($clef_cnx) withtag $itemcom
                            $w addtag liaison($clef_cnx) withtag $itemcom
                        }
                    }
                    #=====bind evenements comm
                    $w bind tag_connexions($clef_cnx) <Any-Enter> " $w itemconfigure liaison($clef_cnx) -state normal ;help_communication %X %Y $clef_cnx
                                            $info configure -text {Double click to edit the connection}"
                    $w bind tag_connexions($clef_cnx) <Any-Leave> " $w itemconfigure liaison($clef_cnx) -state hidden ;help_object_hide
                                            $info configure -text {}"
                    $w bind tag_connexions($clef_cnx) <Button-1>  " minimenu_comm $clef_cnx"
                    $w bind tag_connexions($clef_cnx) <Double-Button-1>  "control_edit_entity"
                    $w bind tag_connexions($clef_cnx) <Key-Delete>  "control_delete_entity"
                }
            }
        }
    }

#-------------------------------------
#** zoom
#-------------------------------------
    if {$unitd == "all"} {
        $w scale COMM_tag(all) 0 0 $zoomfactor $zoomfactor
    } else {
        $w scale COMM_tag($unitd) 0 0 $zoomfactor $zoomfactor
    }
}

ret  {Draw_drawunit} () {
#
    global dico_applis liste_fichiers
    #** Variables specifiques pour le dessin
    global DRAW

    # Efface toutes les unités affichées
    set w $DRAW(window)
    $w delete UNIT_tag(all)
    $w dtag UNIT_tag(all)
    
    # Détermine la liste des applications chargées en mémoire
    set liste_applis ""
    catch {set liste_applis $dico_applis(lapplis)}
    # Pour toutes les applications chargées en mémoire
    foreach nom_appli $liste_applis {
        # Pour tous les composants de cette application
        foreach nom_composant $dico_applis(app.$nom_appli.lcomp) {
            Draw_one_unit $nom_appli.$nom_composant
        }
    }
    
    # Pour tous les fichiers
    foreach id_fichier $liste_fichiers {
        Draw_one_unit ///file///.$id_fichier
    }
    
    return
}

ret  {Draw_one_unit} (type clef_, type unit) {
# affiche une unité dans le canvas
# clef_unit : 
#  - si c'est un composant d'application : clef du composant, composée ainsi <nom_application>.<nom_composant>
#  - si c'est un fichier NetCDF          : clef du fichier,   composée ainsi ///file///.<id-fichier>
#
# gere les procedures d'evenement

    global dico_applis dico_caract_fichiers
    global dico_units
    global liste_points_i liste_points_o
    global dico_caract_points

    global coord_points_X coord_points_Y
    global plot

    # Renomme le paramètre
    set i $clef_unit

    #** Variables specifiques pour le dessin
    global DRAW
    global zoomfactor
    set w $DRAW(window)
    set ray $DRAW(ray)
    set info .gui.pr.tools.infolabel
    
    $w delete UNIT_tag($i)
    $w dtag UNIT_tag($i)
    $w delete UNIT_texttag($i)
    $w dtag UNIT_texttag($i)
    $w delete UNIT_expand_tag($i)
    $w dtag UNIT_expand_tag($i)

#================================================================
#=== affichage des unites
#================================================================
#================================================================
    set id_unit $dico_units($i)
    # Extrait de la clef le nom de l'appli
    set len_unit [string length $id_unit]
    incr len_unit
    set nom_appli [string range $i 0 end-$len_unit]
    
    # S'il s'agit d'un fichier NetCDF
    if { $nom_appli == "///file///" } {
        set si_fichier 1
        set id_fichier $id_unit
        # Le nom du fichier
        set nom_unit $dico_caract_fichiers($id_fichier.name)
        set nom_long_unit ""
        
    # il s'agit d'un composant d'une application    
    } else {
        set si_fichier 0
        # Nom du composant
        set nom_unit $id_unit
        # Clef d'acces au composant dans le dictionnaire dico_applis
        set clef_comp_2 app.$nom_appli.comp.$nom_unit
        # Nom long du composant
        set nom_long_unit ""
        catch {set nom_long_unit $dico_applis($clef_comp_2.long_name)}
    }
    
    # Titres de l'unité à afficher
    set text1 $nom_unit
    if { [string length $text1] > 20 } {
        set text1 [string range $text1 0 20]
        set text1 "$text1..."
    }
    set text2 $nom_long_unit
    if { [string length $text2] > 30 } {
        set text2 [string range $text2 0 30]
        set text2 "$text2..."
    }

    set coor_x $dico_units($i.coor_x)
    set coor_y $dico_units($i.coor_y)

    # Nombre de points en entrée et en sortie de l'unité
    set liste_clefs_points_i [lsearch -glob -all -inline $liste_points_i "$i.*"]
    set liste_clefs_points_o [lsearch -glob -all -inline $liste_points_o "$i.*"]
    set nbget  [llength $liste_clefs_points_i]
    set nbput  [llength $liste_clefs_points_o]

#== calcul largeur boite
    set nbb $nbput
    if {$nbget > $nbb} {set nbb $nbget}
    set widthtot [expr ($nbb + 2) * $DRAW(widthcombox)]
    set wrefp [expr $nbput * $DRAW(widthcombox)]
    set wrefg [expr $nbget * $DRAW(widthcombox)]
    if {$widthtot < $DRAW(widthminunit)} {set widthtot $DRAW(widthminunit)}
    set widthtex [expr [string length $text1] *8]
    if {$widthtot < $widthtex} {set widthtot $widthtex}
    set widthtex [expr [string length $text2] *6]
    if {$widthtot < $widthtex} {set widthtot $widthtex}

    # Mémorise la largeur de la boite
    set dico_units($i.largeur) $widthtot
    if { $si_fichier } {
        # Tient compte des deux bords verticaux de la boite
        set widthtot [expr $widthtot + 2 * $DRAW(hcont)]
    }
    set midle_x [expr $coor_x + $widthtot/2]
    
#===couleurs de l'unité
    set colorunit $dico_units($i.colour)
    set colortext [color_white_or_black $colorunit]
    set pastel    [color_pastelise $colorunit]
    set fonce [color_fonce $colorunit]


#===boite extérieure

    # Si c'est un fichier NetCDF
    if { $si_fichier } {
        # Dessine deux bandes verticales à gauche et à droite du rectangle principal
        set hauteur [expr $DRAW(heigthunit) + 2 * $DRAW(hcont)]
        set bord_gauche [$w create rectangle $coor_x $coor_y [expr $coor_x + $DRAW(hcont)]  [expr $coor_y + $hauteur] -fill $pastel -outline  $pastel]
        $w addtag unitpoint($i) withtag $bord_gauche
        $w addtag UNIT_tag($i) withtag $bord_gauche
        $w addtag UNIT_tag(all) withtag $bord_gauche
        set bord_droit [$w create rectangle [expr $coor_x + $widthtot - $DRAW(hcont)] $coor_y  [expr $coor_x + $widthtot]  [expr $coor_y + $hauteur] -fill $pastel -outline  $pastel]
        $w addtag unitpoint($i) withtag $bord_droit
        $w addtag UNIT_tag($i) withtag $bord_droit
        $w addtag UNIT_tag(all) withtag $bord_droit
    } else {
        # Dessine deux bandes horizontales au dessus et dessous du rectangle principal
        set containerput [$w create rectangle $coor_x  [expr $coor_y + $DRAW(heigthunit) + $DRAW(hcont)]   [expr $coor_x + $widthtot]  [expr $coor_y + $DRAW(heigthunit) + 2*$DRAW(hcont)] -fill $pastel -outline  $pastel]
        $w addtag unitpoint($i) withtag $containerput
        $w addtag UNIT_tag($i) withtag $containerput
        $w addtag UNIT_tag(all) withtag $containerput
        set containerget [$w create rectangle $coor_x $coor_y  [expr $coor_x + $widthtot]  [expr $coor_y + $DRAW(hcont)] -fill $pastel -outline  $pastel]
        $w addtag unitpoint($i) withtag $containerget
        $w addtag UNIT_tag($i) withtag $containerget
        $w addtag UNIT_tag(all) withtag $containerget
    }
    
#===bouton expand
    set colorbout white
    if {$dico_units($i.expand) == 0} {set colorbout grey80}
    set bexp [$w create rectangle [expr $coor_x+$widthtot -12] [expr $coor_y + $DRAW(hcont) - 2]  [expr $coor_x + $widthtot-2]  [expr $coor_y + $DRAW(hcont) - 9] -fill $colorbout -outline  grey50]
    $w addtag UNIT_tag($i) withtag $bexp
    $w addtag UNIT_tag(all) withtag $bexp
    $w addtag UNIT_expand_tag($i) withtag $bexp
    if {$dico_units($i.expand) == 0} {
        $w bind UNIT_expand_tag($i) <1> "global dico_units; set dico_units($i.expand) 1; Draw_one_unit $i;Draw_comm $i;.gui configure -cursor {}"
        $w bind UNIT_expand_tag($i) <Any-Enter> ".gui configure -cursor sb_h_double_arrow"
        $w bind UNIT_expand_tag($i) <Any-Leave> ".gui configure -cursor {}"
    } else {
        $w bind UNIT_expand_tag($i) <1> "global dico_units; set dico_units($i.expand) 0; Draw_one_unit $i; Draw_comm $i;.gui configure -cursor {}"
        $w bind UNIT_expand_tag($i) <Any-Enter> ".gui configure -cursor sb_left_arrow"
        $w bind UNIT_expand_tag($i) <Any-Leave> ".gui configure -cursor {}"
    }

#===boite intérieure
    
    # Si c'est un fichier NetCDF
    if { $si_fichier } {
        set itemunit [$w create rectangle [expr $coor_x + $DRAW(hcont)] $coor_y  [expr $coor_x + $widthtot - $DRAW(hcont)]  [expr $coor_y + 2 * $DRAW(hcont) + $DRAW(heigthunit)] -fill $colorunit -outline $colorunit]
    } else {
        set itemunit [$w create rectangle $coor_x  [expr $coor_y + $DRAW(hcont)]  [expr $coor_x + $widthtot]  [expr $coor_y + $DRAW(hcont) + $DRAW(heigthunit)] -fill $colorunit -outline $colorunit]
    }
    $w addtag UNIT_tag($i) withtag $itemunit
    $w addtag UNIT_tag(all) withtag $itemunit
    $w addtag unitpoint($i) withtag $itemunit
    $w addtag unitpoint_color($i) withtag $itemunit
    
    if { $text2 == "" } {
        # Un seul texte place au centre de la boite
        set pos_text1   12
    } else {
        set pos_text1   7
    }
    
    set itemunit [$w create text [expr $coor_x+$widthtot/2]  [expr $coor_y + $DRAW(hcont) + $pos_text1] -text $text1 -font "helvetica -[expr int(12*$zoomfactor)] bold" -fill $colortext]
    $w addtag unitpoint($i) withtag $itemunit
    $w addtag UNIT_tag($i) withtag $itemunit
    $w addtag UNIT_tag(all) withtag $itemunit
    $w addtag UNIT_texttag($i) withtag $itemunit
    if { $text2 != "" } {
        set itemunit [$w create text [expr $coor_x+$widthtot/2] [expr $coor_y + $DRAW(hcont) + 19] -text $text2 -font "helvetica -[expr int(10*$zoomfactor)] bold" -fill $colortext]
        $w addtag unitpoint($i) withtag $itemunit
        $w addtag UNIT_tag($i) withtag $itemunit
        $w addtag UNIT_tag(all) withtag $itemunit
        $w addtag UNIT_texttag($i) withtag $itemunit
    }
       
    # Si c'est un composant d'une application
    if { ! $si_fichier } {
        set itemunit [$w create text [expr $coor_x+$widthtot+12] [expr $coor_y + $DRAW(hcont) + 28] -text "0" -font "helvetica -[expr int(12*$zoomfactor)] bold" -fill white -anchor w -state hidden]
        $w addtag unitpoint($i) withtag $itemunit
        $w addtag UNIT_tag($i) withtag $itemunit
        $w addtag UNIT_tag(all) withtag $itemunit
    }
#=======================================
#==== gros rond pour les unites fermees
#=======================================
    if {$dico_units($i.expand) == 0} {
        set x1 $midle_x
        set y1 [expr int([expr $coor_y + $DRAW(hcont)/2])]
        if {$nbget > 0} {
            set item [$w create  oval [expr $x1-2*$ray] [expr $y1 -$ray] [expr $x1+2*$ray] [expr $y1+$ray] -fill grey80]
            $w addtag UNIT_tag($i) withtag $item
            $w addtag UNIT_tag(all) withtag $item
        }
        foreach clef_point $liste_clefs_points_i {
            set coord_points_X($clef_point) [expr $x1 - $coor_x]
            set coord_points_Y($clef_point) [expr $y1 - $coor_y]
        }
        if {$nbput > 0} {
            set y1 [expr int([expr $coor_y+$DRAW(heigthunit) + 3*$DRAW(hcont)/2])]
            set item [$w create  oval [expr $x1-2*$ray] [expr $y1 -$ray] [expr $x1+2*$ray] [expr $y1+$ray] -fill grey80]
            $w addtag UNIT_tag($i) withtag $item
            $w addtag UNIT_tag(all) withtag $item
        }
        foreach clef_point $liste_clefs_points_o {
            set coord_points_X($clef_point)  [expr $x1 - $coor_x]
            set coord_points_Y($clef_point)  [expr $y1 - $coor_y]
        }
    } else {
#=================================
#====les petits ronds  du haut et du bas
#================================
        Draw_points_de_couplage in $liste_clefs_points_i $nom_appli $id_unit $coor_x $coor_y [expr ($wrefg - $widthtot) / 2]
        Draw_points_de_couplage out $liste_clefs_points_o $nom_appli $id_unit $coor_x $coor_y [expr ($wrefp - $widthtot) / 2]
    }         
    set txt1 "{double click to edit the unit, left click to move the unit icon}"


#==== bind evenement unit
    $w bind unitpoint($i) <Any-Enter> "$info configure -text $txt1 "
    $w bind unitpoint($i) <Any-Leave> "$info configure -text {}"

    $w bind unitpoint($i) <Button-1>  "minimenu_unit $i"
    $w bind unitpoint($i) <Button-1> "+ .gui configure -cursor fleur; unitplotdown $w %x %y $i"
    $w bind unitpoint($i) <ButtonRelease-1> ".gui configure -cursor {}; unitplotrelease $w %x %y $i"

    $w bind unitpoint($i) <Double-Button-1>  "unit_edit $i"
    $w bind unitpoint($i) <Key-Delete>  "unit_delete $i"

    $w scale UNIT_tag($i) 0 0 $zoomfactor $zoomfactor
    set plot(lastX)  0
    set plot(lastY)  0
    set plot(firstX) 0
    set plot(firstY) 0
}

ret  {Draw_points_de_couplage} (type direction , type liste_, type clefs_, type points , type nom_, type appli , type nom_, type unit , type coor_, type x , type coor_, type y , type offset) {
# affiche une rangée de points de couplage sous forme de petits ronds
#
# Si points de couplage en entrée : il sont au sommet de la boite
# Si points de couplage en sortie : il sont au fond   de la boite
#
# Paramètres d'entrée :
#   - direction :           "in" ou "out"
#   - liste_clefs_points :  liste des points de couplage a représenter 
#   - nom_appli :           nom de l'application ou "///file///", si c'est un fichier
#   - nom_unit :            nom du composant ou identifiant du fichier
#   - coor_x coor_y :       coordonnées de l'unité (composant ou fichier) 
#   - offset :              offset horizontal du premier petit rond par rapport au milieu de la boite
#
    global DRAW
    global dico_applis dico_caract_fichiers dico_caract_points
    global coord_points_X coord_points_Y

    # wnd : le canevas
    set wnd $DRAW(window)
    set ray $DRAW(ray)
    set info .gui.pr.tools.infolabel

    if { $direction == "in" } {
        set y1 [expr int([expr $coor_y + $DRAW(hcont)/2])]
        # Un point pas connecté apparait plus haut
        set offset_point_pas_connecte -10
        set endpoint_type target
    } else {
        set y1 [expr int($coor_y + $DRAW(heigthunit) + 3*$DRAW(hcont)/2)]
        # Un point pas connecté apparait plus bas
        set offset_point_pas_connecte 10
        set endpoint_type source
    }
        
    # Pour tous les points de couplage
    set j 0
    foreach clef_point $liste_clefs_points {
        set x1 [expr int($coor_x+ ($j+.5)*$DRAW(widthcombox) - $offset)]
        set coord_points_X($clef_point) [expr $x1 - $coor_x]
        set coord_points_Y($clef_point) [expr $y1 - $coor_y]
                
        # Si c'est un fichier NetCDF
        if { $nom_appli == "///file///" } {
            # Identifiant du fichier
            set id_fichier $nom_unit
            # Identifiant du champ
            set id_champ $dico_caract_points($clef_point.champ)
            # Nom du champ
            if { $direction == "in" } {
                # C'est un fichier de sortie : normalement $id_champ vaut "field"
                set nom_champ $dico_caract_fichiers($id_fichier.$id_champ.name)
            } else {
                # C'est un fichier d'entrée (entrée de données pour un composant)
                # L'identifiant est le nom
                set nom_champ $id_champ
            }
            # info bulle
            set txt "{Field:    $nom_champ"

            # Pour tous les parametres du champ, ajoute à l'info bulle
            foreach {name param} {Datatype type Packing packing Scaling scaling Adding adding "Fill value" fill_value} {
                if { [info exists dico_caract_fichiers($id_fichier.$id_champ.$param)] } {
                    set value $dico_caract_fichiers($id_fichier.$id_champ.$param)
                    if { $value != "" } {
                        set txt "$txt\n$name:   $value"
                    }
                }
            }
            # Ajoute une parenthese fermante
            set txt "$txt}"

        # c'est un composant d'une application
        } else {
            # Nom du composant
            set nom_composant $nom_unit
            # Nom du champ
            set nom_champ $dico_caract_points($clef_point.champ)
            # Clef d'accès aux caractéristiques du champ
            set clef_champ "app.$nom_appli.comp.$nom_composant.champ.$nom_champ"
            # Nom long du champ, si présent
            set nom_long ""
            if { [info exists dico_applis($clef_champ.long_name)] } {
                set nom_long $dico_applis($clef_champ.long_name)
            }
            # Type numérique
            set type_num $dico_applis($clef_champ.datatype)
            # Type dimensionel du champ (single ou vector)
            set type_dim $dico_applis($clef_champ.type)
            
            # info bulle
            set txt "{Field:    $nom_champ\nType:     $type_dim\nDatatype:   $type_num\nLong name:  $nom_long}"
        }

        # Liste des connexions à ce point de couplage
        set liste_cnx ""
        if { [info exists dico_caract_points($clef_point.lcnx)] } {
            set liste_cnx $dico_caract_points($clef_point.lcnx)
        }
        
        set coloro \#eeee55
        set bordcolor black

        # Si le point n'est pas connecté
        if { $liste_cnx == "" } {
            set y2 [expr $y1 + $offset_point_pas_connecte]
        } else {
            set y2 $y1
        }
        set item [$wnd create oval [expr $x1-$ray] [expr $y2 -$ray] [expr $x1+$ray] [expr $y2+$ray] -fill $coloro -outline $bordcolor]
        $wnd addtag UNIT_tag($nom_appli.$nom_unit) withtag $item
        $wnd addtag UNIT_tag(all) withtag $item

        $wnd bind  $item <Any-Enter> "help_object %W $txt label %X %Y \; $info configure -text {Click to set the $endpoint_type of a new connection }"
        $wnd bind  $item <Button-1> "comm_new $direction $clef_point"
        $wnd bind  $item <Any-Leave> "help_object_hide;$info configure -text {}"
        incr j 1
    }
}

ret  {Draw_set_init_variables} (optional default =no_default) {
#================================================================
#=== set des variables pour le dessin (valeurs par default)
#================================================================
   global DRAW palm_param

   set DRAW(init) 1
   set DRAW(window) .gui.pr.cpd22.03
   set DRAW(widthminunit) 60

   if {$default == "default"} {
      set oasis_GUI_param(MAXIMUN_LINE_SIZE) 1000
      set oasis_GUI_param(GROUPED_MAXIMUN_LINE_SIZE) 1000
      set oasis_GUI_param(PLUGS_RADIUS) 4
      set oasis_GUI_param(HEIGHT_UNIT) 25
   }
   set DRAW(maxi_line_size) 1000
   set DRAW(grouped_maxi_line_size) 1000
   set DRAW(heigthunit)   25
   set DRAW(heightfile)   50
   set DRAW(ray)          4


   catch {set DRAW(maxi_line_size) $oasis_GUI_param(MAXIMUN_LINE_SIZE)}
   catch {set DRAW(grouped_maxi_line_size) $oasis_GUI_param(GROUPED_MAXIMUN_LINE_SIZE)}
   catch {set DRAW(heigthunit) $oasis_GUI_param(HEIGHT_UNIT)}
   catch {set DRAW(ray) $oasis_GUI_param(PLUGS_RADIUS)}

   set DRAW(widthcombox)  [expr $DRAW(ray)*2+1]
   set DRAW(hcont)        [expr $DRAW(ray)*2+2]
}

ret  {Draw_settings} () {
# boite de dialogue pour gerer les parametres du dessin dans le
# cannevas


    proc resize_draw {w} {
    global DRAW oasis_GUI_param

    set oasis_GUI_param(MAXIMUN_LINE_SIZE)         $DRAW(maxi_line_size)
    set oasis_GUI_param(GROUPED_MAXIMUN_LINE_SIZE) $DRAW(grouped_maxi_line_size)
    set oasis_GUI_param(PLUGS_RADIUS)             $DRAW(ray)
    set oasis_GUI_param(HEIGHT_UNIT)               $DRAW(heigthunit)
    set DRAW(widthcombox)  [expr $DRAW(ray)*2+1]
    set DRAW(hcont)        [expr $DRAW(ray)*2+2]
    drawall
    destroy $w
    }

    global DRAW
    global global_font


    set w .setting
    catch {destroy $w}
    toplevel $w
    wm title $w "Canvas settings"
    wm iconname $w "settings"
    window_position $w 200 200



    frame $w.fr1
    pack $w.fr1 -side bottom -fill x -pady 2m -padx 2m
    button $w.fr1.ok -font $global_font -text ok -command "resize_draw $w"
    pack $w.fr1.ok  -side left -expand 1
    button $w.fr1.defaut -font $global_font -text Default -command "global DRAW; catch {unset DRAW(init)};Draw_set_init_variables default; destroy $w; drawall"
    pack $w.fr1.defaut  -side left -expand 1
    frame $w.sep -width 100 -height 2 -borderwidth 1 -relief sunken
    pack $w.sep -side bottom

    frame $w.fr7 -borderwidth 1 -relief sunken
    pack $w.fr7  -side top -expand 1 -pady 10 -padx 10

    grid [label $w.fr7.v1 -font $global_font -text "Maximun line size for communications:"] -row 0 -column 0 -sticky w
    grid [scale $w.fr7.e1 -variable DRAW(maxi_line_size) -font $global_font -orient horizontal -from 0 -to 2000]   -row 0 -column 1 -sticky w
    grid [label $w.fr7.v5 -font $global_font -text "Maximun line size for grouped communications:"] -row 1 -column 0 -sticky w
    grid [scale $w.fr7.e5 -variable DRAW(grouped_maxi_line_size) -font $global_font -orient horizontal -from 0 -to 2000]   -row 1 -column 1 -sticky w
    grid [label $w.fr7.v2 -font $global_font -text "Radius of plugs:"] -row 2 -column 0 -sticky w
    grid [scale $w.fr7.e2 -variable DRAW(ray) -font $global_font -orient horizontal -from 2 -to 6]   -row 2 -column 1 -sticky w
    grid [label $w.fr7.v3 -font $global_font -text "Unit height:"] -row 3 -column 0 -sticky w
    grid [scale $w.fr7.e3 -variable DRAW(heigthunit) -font $global_font -orient horizontal -from 25 -to 60]   -row 3 -column 1 -sticky w
}

ret  {HOSTOS} () {
# retourne l'operating systeme
    # sert pour le lancement de la bonne version de steplang
    # selon la machine sur laquelle tourne PrePALM

    set machine [string toupper [exec uname -s]]
    switch $machine {
        SunOS  {return "-sun"}
        IRIX64 {return "-sgi"}
        Linux  {return "-i386"}
    }
    puts  "Unknown architecture $machine"
    exit
}

ret  {Help_legend} () {
# affiche la legende du canevas de Prepalm
    # contenue dan le fichier legend.gif

    if {![winfo exists .help_legend]} {
    set w .help_legend
    toplevel $w -background white
    wm title $w "Legend"
    wm iconname $w "Legend"

    frame $w.buttons
    pack $w.buttons -side bottom -fill x -pady 0
    button $w.buttons.dismiss -text Ok -command "destroy $w"
    pack $w.buttons.dismiss
    frame $w.sep -width 100 -height 2 -borderwidth 1 -relief sunken
    pack $w.sep -side bottom -fill x -pady 0

    set win $w.frsc
    frame $win
    scrollbar $win.sbar -command "$win.vport yview"
    pack $win.sbar -side right -fill y
    canvas $win.vport -yscrollcommand "$win.sbar set" -background white -width 590 -height 750 -scrollregion {0 0 0 750}
    pack $win.vport -side left -fill both -expand true
    pack $win -expand yes -fill both -side top
    } else {
    set w .help_legend
    wm deiconify $w
    raise $w
    set win $w.frsc
    $win.vport delete all
    }
    set font1 "helvetica 14 bold"
    set font2 "helvetica 11 bold"
    set font3 "helvetica 12"
    global env
    global OASIS_GUI_DIR

    # creation image et insertion dans le canvas
    set w $win.vport


    image create photo im1 -file [file join $OASIS_GUI_DIR IMAGES legend.gif]
    $w create image 295 375   -image im1
}

ret  {MOD} (type i , type j) {
# retourne le modulo de deux entiers
set mod [expr $i - $j*(int($i/$j))]
return $mod
}

ret  {NetCDF_file_add_new} (optional filename ={)} {
#
    global liste_fichiers dico_caract_fichiers
    global liste_points_i dico_caract_points
    global dico_units

    # Ferme la boite de dialogue précédente
    destroy .load_dir
    
    # Détermine un identifiant automatique pour ce nouveau fichier
    set file_id [NetCDF_file_cree_nouvel_id]
    set clef_unit "///file///.$file_id"
            
    # Choisit une couleur pour le composant
    set dico_units($clef_unit.colour) [color_rgb [expr int(rand()*254)] [expr int(rand()*254)] [expr int(rand()*254)]]
    # Permet la modification de ces attributs        
    NetCDF_file_edit $file_id $filename
    tkwait window .mod_file

    # Si l'utilisateur a validé la saisie
    if { [info exists dico_caract_fichiers($file_id.field.name)] } {
        /*  Met a jour la liste des points de couplage :*/
        /*  le fichier a un seul point de couplage qui est en entrée du fichier*/
         clef = _point $clef_unit.field.i
        lappend liste_points_i $clef_point
         dico = _caract_points($clef_point.appli) "///file///"
         dico = _caract_points($clef_point.comp) $file_id
         dico = _caract_points($clef_point.champ) field
                        
        /*  Tant qu'il n'est pas connecté, le champ a un type numérique inconnu*/
         dico = _caract_fichiers($file_id.field.type) undefined
        /*  Initialise la position du fichier sur le canvas*/
         dico = _units($clef_unit) $file_id
         dico = _units($clef_unit.coor_x) 80
         dico = _units($clef_unit.coor_y) 25
        /*  Met le composant dans l'état "connexions visibles"*/
         dico = _units($clef_unit.expand) 1

        /*  Dessine le fichier */
        Draw_one_unit $clef_unit

        /*  Affiche la liste des fichiers en sélectionnant le dernier créé*/
        /*  et annule la sélection des points de couplage*/
        minimenu_unit $clef_unit
    }
}

ret  {NetCDF_file_cree_nouvel_id} () {
# Détermine automatiquement et retourne un identifiant 
# pour un nouveau fichier NetCDF en output
    
    global liste_fichiers
    # Liste actuelle des identifiants de fichiers en output
    set liste_fic_output [lsearch -glob -all -inline $liste_fichiers "///outNetCDFfile///_*"]
    if { $liste_fic_output != "" } {
        # Numero du dernier identifiant
        set dernier [lindex $liste_fic_output end]
        set dernier_num [string range $dernier [string length ///outNetCDFfile///_] end]
        # Nouvel identifiant
        incr dernier_num
    } else {
        set dernier_num 1
    }
    return "///outNetCDFfile///_$dernier_num"
}

ret  {NetCDF_file_delete} (type clef_, type fichier) {
# Suppression d'un fichier par appui sur la bouton <DELETE>
    global liste_fichiers dico_caract_fichiers dico_units
    global liste_points_i   liste_points_o  dico_caract_points
    global dico_cnx_out dico_caract_cnx
    global DRAW tagselected

    # Identifiant du fichier
    set file_id $dico_units($clef_fichier)
    set clef_fichier ///file///.$file_id
    
    # Supprime toutes les connexions vers ce fichier
    # ----------------------------------------------
     
    # Si le fichier est en "output"
    if { $dico_caract_fichiers($file_id.dir) == "output" } {
        # Point de couplage du champ unique du fichier   
        set clef_point $clef_fichier.field.i
        # Teste si le champ est connecté
        set cnx ""
        catch {set cnx $dico_caract_points($clef_point.lcnx)}

        # Si le champ est connecté
        if { $cnx != ""} {
            # Supprime la connexion
            comm_remove $clef_point
        }
        
    # Le fichier est en "input"    
    } else {
        # Pour tous les champs du fichier
        foreach field_id $dico_caract_fichiers($file_id.lchamps) {
            # Identifiant de ce point de couplage
            set clef_point $clef_fichier.$field_id
            # Teste si le champ est connecté
            set lcnx ""
            catch {set lcnx $dico_caract_points($clef_point.o.lcnx)}
            # Pour toutes les connexions sortant de ce point
            foreach num_cnx $lcnx {
                # Clef de la cnx sortante
                set clef_cnx_out $clef_point.$num_cnx
                # Clef de la connexion : point de couplage cible de la connexion
                set clef_cnx_in $dico_cnx_out($clef_cnx_out)
                # Supprime la connexion
                comm_remove $clef_cnx_in
            }
        }
    }
    
    # Supprime tous les points de couplage de ce fichier
    # --------------------------------------------------
    
    # Points en entrée
    set liste_points_i [lsearch -not -all -inline -glob $liste_points_i "$clef_fichier.*"]
    # Points en sortie
    set liste_points_o [lsearch -not -all -inline -glob $liste_points_o "$clef_fichier.*"]
    # Caractéristiques des points
    array unset dico_caract_points "$clef_fichier.*"
    
    # Supprime le fichier de la liste
    set liste_fichiers [lsearch -not -all -inline $liste_fichiers $file_id]
    # Supprime toutes ses caractéristiques
    array unset dico_caract_fichiers "$file_id.*"

    # Raffraichit l'écran
    # -------------------
    
    # Efface et redessine tous les composants
    Draw_drawunit
    # Efface et redessine toutes les connexions
    Draw_comm all

    # Affiche la liste des fichiers
    control_entity FILE
    
    # Si ce fichier était sélectionné (a priori OUI)
    if {$tagselected == "unitpoint_color($clef_fichier)"} {
        # Oublie l'objet sélectionné
        set tagselected ""
    }
}

ret  {NetCDF_file_edit} (type file_, type id , optional new_filename ={)} {
#
    global liste_fichiers dico_caract_fichiers dico_units

    # Extrait les informations pertinentes
    # ------------------------------------

    # Si le fichier n'existe pas encore
    if { ! [info exists dico_caract_fichiers($file_id.dir)] } {
         io = _direction output
         access = _mode iosingle
         suffix =  no
         fieldname =  ""
        /*  On récupère le nom de fichier de la boite de dialogue précédente*/
         filename =  $new_filename
    
    } else {
         io = _direction $dico_caract_fichiers($file_id.dir)
         access = _mode ""
        catch { access = _mode $dico_caract_fichiers($file_id.io_mode)}
         suffix =  ""
        catch { suffix =  $dico_caract_fichiers($file_id.suffix) }
         fieldname =  ""
        catch { fieldname =  $dico_caract_fichiers($file_id.field.name)}
         filename =  $dico_caract_fichiers($file_id.name)
        
         time = _unit ""
        catch { time = _unit $dico_caract_fichiers($file_id.time_unit)}
         time = _values "unknown"
        catch { time = _values $dico_caract_fichiers($file_id.time_values)}
        if { $suffix == "true" } { suffix =  yes} else { suffix =  no}
    }

    /*  Cree une boite de dialogue*/
    /*  --------------------------*/

     u =  .mod_file
    catch {destroy $u}
    toplevel $u
    wm title $u "Edit NetCDF file"
    wm iconname $u "Mod_NetCDF"
    window_position $u 20 20

     w =  $u.menu
    frame $w
    grid $w -row 2 -column 0
    grid configure $w -columnspan 2 -padx 4 -pady 4

    frame $w.buttons
    pack $w.buttons -side bottom -fill x -pady 2m

    button $w.buttons.dismiss  -text Cancel -command "destroy $u"
    button $w.buttons.ok  -text Ok -command "NetCDF_file_update $u $file_id $io_direction"

    pack $w.buttons.dismiss -side left -expand 1 -padx 10
    pack $w.buttons.ok -side left -expand 1 -padx 10

    frame $w.sep1 -width 200 -height 2 -borderwidth 1 -relief sunken
    pack $w.sep1 -side bottom -fill x -pady 2m -expand 1

     w =  $u.char
    frame $w
    grid $w -row 0 -column 1
    grid configure $w -padx 4 -pady 4
     r =  1

/* == name*/
    label $w.label1 -text "Name :"
    global filename_m
     filename = _m $filename
    entry $w.entry1 -textvariable filename_m -width 40 -background white
    grid  $w.label1 $w.entry1 -row $r -sticky w
    incr r
    /*  Ajoute une bulle d'aide pour 'name'*/
     help = _text {Enter here a file name, without suffix, if any.}
    entry_help_balloon $w.entry1 $help_text

/* == I/O direction*/
    label $w.label12 -text "I/O direction :"
    label $w.label13 -text $io_direction -relief sunken
    grid  $w.label12 $w.label13 -row $r -sticky w
    incr r

/* == access mode*/
    label $w.label2 -text "Access mode :"
    combobox_lim $w.cmb2 {iosingle distributed parallel} {} access_mode_m 30 $access_mode
    grid  $w.label2 $w.cmb2 -row $r -sticky w
    incr r
    /*  Ajoute une bulle d'aide pour 'access mode'*/
     help = _text {The mode iosingle means that the whole file is written or read only by the master ret ess;

distributed means that each process writes or reads its part of the field to a different partial file. Note that if OASIS is linked against the parallel NetCDF library (7), the parallel mode will automatically be used; in this case each process writes its part of the field to one parallel file (see Oasis User Guide on page 26).}
    entry_help_balloon $w.cmb2 $help_text

#== Suffix option
    label $w.label3 -text "Suffix :"
    combobox_lim $w.cmb3 (type yes , type no) {} suffix_m 30 $suffix
    grid  $w.label3 $w.cmb3 -row $r -sticky w
    incr r
    /*  Ajoute une bulle d'aide pour 'suffix'*/
     help = _text {If yes, a suffix is appended to file name.
    
When the file is opened for writing, the suffix will be “ out.<job-startdate>.nc”, where <job-startdate> is the start date of the job.
    
When the file is opened for reading, the suffix should be “ in.<start-date>.nc”, where <start-date> is the date of the first time stamp in that file.
When reading an input from a file, OASIS will automatically match the requested date of the input with the appropiate file if it falls into the time interval covered by that file. The <job-startdate> and <start-date> must be written according to the ISO format yyyy-mm-ddTHH:MM:SS. The date/time string in the file name must have to format yyyy-mmddTHH.MM.SS since the colon is already used in other context for file systems.}
    entry_help_balloon $w.cmb3 $help_text

    grid [ frame $w.sep1 -width 430 -height 2 -borderwidth 1 -relief sunken] -row $r -column 0 -pady 5 -columnspan 2
    incr r
    
    /*  Si fichier en sortie*/
    if { $io_direction == "output" } {
    
    /* == field name*/
        label $w.label4 -text "Field name :" -fg /* ee3333*/
        global fieldname_m
         fieldname = _m $fieldname
        entry $w.entry4 -textvariable fieldname_m -width 40 -background white
        grid  $w.label4 $w.entry4 -row $r -sticky w
        incr r
        /*  Ajoute une bulle d'aide pour 'field name'*/
         help = _text {Enter here the name of NetCDF file variable.}
        entry_help_balloon $w.entry4 $help_text
    } else {
        /*  Fichier en entrée*/
        
    /* == Time axis*/
        label $w.label31 -text "Time values :"
        label $w.label32 -text "$time_values $time_unit" -relief sunken -wraplength 450 -justify left
        grid  $w.label31 $w.label32 -row $r -sticky w
        incr r    
    }

/* == couleur*/
    global color_m
     clef = _comp ///file///.$file_id
     color = _m $dico_units($clef_comp.colour)
    label $w.label5 -text "Color :"
    button $w.entry5 -relief sunken -width 20 -text $color_m -background $color_m  -command {
        global color_m
         color = _m [tk_chooseColor -initialcolor $color_m]
        catch {.mod_file.char.entry5 configure -background $color_m}
        }
    grid  $w.label5 $w.entry5 -row $r -sticky w
    /*  Ajoute une bulle d'aide pour la couleur*/
    global no_help_balloon
    if { $no_help_balloon == 0 } {
         help = _text {Click here to change the color of the component.}
         help = _action "help_object %W [list $help_text] message"
        bind $w.entry5 <Any-Enter> $help_action 
        bind $w.entry5 <FocusIn>   $help_action
        bind $w.entry5 <Any-Leave>    "help_object_hide"
        bind $w.entry5 <FocusOut>     "help_object_hide"
        bind $w.entry5 <ButtonPress>  "help_object_hide"
    }
}

ret  {NetCDF_file_maj} (type file_, type list , type nom_, type dico_, type ajout , type option_, type redraw) {
# Met à jour les données en mémoire avec les fichiers ajoutés : 
#  en particulierm la liste des points de couplage
# Ajoute les fichiers sur le graphe
#
# Tient compte du fait que des fichiers sont en fait chargés pour la deuxième fois en mémoire.
# Les fichiers ne sont alors pas ajoutés mais remis à jour.
# Dans ce cas, on supprime les points de couplage qui n'existent plus et les éventuelles connexions
# qui leur sont attachées.
#

    upvar 1 $nom_dico_ajout dico_ajout
    global liste_fichiers dico_caract_fichiers dico_units
    global liste_points_o dico_cnx_out dico_caract_points dico_caract_cnx
    
    # Position initiale du fichier ajouté sur le graphe : en haut à gauche
    set position_x 80
    set position_y 25

    foreach nom_fichier $file_list {
        set clef_comp ///file///.$nom_fichier
        
        # Si fichier en entrée dont l'attribut 'suffix' n'est pas encore défini
        if {$dico_ajout($nom_fichier.dir) == "input" && 
            ![info exists dico_ajout($nom_fichier.suffix)]} {
            
            # Si le nom du fichier comprend un suffixe _out<date>.nc
            if {[regexp -nocase {_in\.[1-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]T[0-9][0-9][._][0-9][0-9][._][0-9][0-9].nc$} $nom_fichier]} {
                set dico_ajout($nom_fichier.suffix) true
                # Garde le nom sans le suffixe
                set dico_ajout($nom_fichier.name) [string range $dico_ajout($nom_fichier.name) 0 end-26]
            } else {
                set dico_ajout($nom_fichier.suffix) false
            }
        }

        # Si le fichier n'existait pas déja en mémoire (il a bien été ajouté)
        if { [lsearch $liste_fichiers $nom_fichier] == -1 } {
            
            # Ajoute le fichier a la liste
            lappend liste_fichiers $nom_fichier
            # Ajoute toutes ses infos au dictionnaire global des fichiers
            array set dico_caract_fichiers [array get dico_ajout "$nom_fichier.*"]

            # Nouvelle unité sur le graphe de couplage
            set dico_units($clef_comp) $nom_fichier
            # Détermine les coordonnées du fichier sur le graphe
            set dico_units($clef_comp.coor_x) $position_x
            set dico_units($clef_comp.coor_y) $position_y
            incr position_y 80
            # Met le composant dans l'état "connexions visibles"
            set dico_units($clef_comp.expand) 1
            # Choisit une couleur pour le composant
            set dico_units($clef_comp.colour) [color_rgb [expr int(rand()*254)] [expr int(rand()*254)] [expr int(rand()*254)]]
            
            # Pour toutes ses variables
            foreach nom_var $dico_ajout($nom_fichier.lchamps) {
                # Ajoute un point de couplage
                set clef_point $clef_comp.$nom_var.o
                lappend liste_points_o $clef_point
                
                set dico_caract_points($clef_point.appli) ///file///
                set dico_caract_points($clef_point.comp) $nom_fichier
                set dico_caract_points($clef_point.champ) $nom_var
            }
            # Affiche le fichier sur le graphe
            Draw_one_unit $clef_comp
        
        } else {    # Le fichier a été rechargé avec des changements possibles
            
            # Mémorise l'axe des temps
            if {$dico_ajout($nom_fichier.time_name) != ""} {
                array set dico_caract_fichiers [array get dico_ajout "$nom_fichier.time_*"]
            } else {
                array unset dico_caract_fichiers $nom_fichier.time_unit
                array unset dico_caract_fichiers $nom_fichier.time_values
            }
            
            # Vérifie la liste des champs et cherche des champs supprimés ou ajoutés
            # ----------------------------------------------------------------------
            
            # Pour toutes les variables du fichier chargé en mémoire
            foreach nom_var $dico_ajout($nom_fichier.lchamps) {
                # Si la variable n'existait pas auparavant
                if { [lsearch $dico_caract_fichiers($nom_fichier.lchamps) $nom_var] == -1} {
                    # Ajoute un point de couplage
                    set clef_point $clef_comp.$nom_var.o
                    lappend liste_points_o $clef_point
                    
                    set dico_caract_points($clef_point.appli) ///file///
                    set dico_caract_points($clef_point.comp) $nom_fichier
                    set dico_caract_points($clef_point.champ) $nom_var
                }
                # Met a jour en mémoire les attributs de cette var. du fichier
                array set dico_caract_fichiers [array get dico_ajout "$nom_fichier.$nom_var.*"]
            }
            
            # Init liste des composants touchés par les conexions supprimées
            set liste_comp_touches {}
            # Pour toutes les variables qui existaient auparavant
            foreach nom_var $dico_caract_fichiers($nom_fichier.lchamps) {
                # Si la variable n'existe plus
                if { [lsearch $dico_ajout($nom_fichier.lchamps) $nom_var] == -1} {
                    # Identifiant de ce point de couplage
                    set clef_point $clef_comp.$nom_var
                    # Teste si le champ est connecté
                    set lcnx ""
                    catch {set lcnx $dico_caract_points($clef_point.o.lcnx)}
                    # Pour toutes les connexions sortant de ce point
                    foreach num_cnx $lcnx {
                        # Clef de la cnx sortante
                        set clef_cnx_out $clef_point.$num_cnx
                        # Clef de la connexion : point de couplage cible de la connexion
                        set clef_cnx_in $dico_cnx_out($clef_cnx_out)
                        # Memorise le composant cible de la connexion
                        set appli_cible $dico_caract_cnx($clef_cnx_in.app_cible)
                        set comp_cible  $dico_caract_cnx($clef_cnx_in.comp_cible)
                        lappend liste_comp_touches $appli_cible.$comp_cible
                        # Supprime la connexion
                        comm_remove $clef_cnx_in
                    }

                    # Met a jour la liste des points en sortie
                    set liste_points_o [lsearch -not -all -inline -glob $liste_points_o "$clef_point.o"]
                    # Supprime les caractéristiques du point
                    array unset dico_caract_points "$clef_point.o.*"
                    # Supprime les infos concernant ce champ
                    array unset dico_caract_fichiers "$nom_fichier.$nom_var.*"
                }
            }
            
            # Met a jour en mémoire la liste des champs du fichier
            set dico_caract_fichiers($nom_fichier.lchamps) $dico_ajout($nom_fichier.lchamps)

            if {$option_redraw} {
                # Pour tous les composants touchés
                foreach composant $liste_comp_touches {
                    # Redessine le composant
                    Draw_one_unit $composant
                }
    
                # Affiche le fichier sur le graphe
                Draw_one_unit $clef_comp
                # Redessine les connexions du fichier
                Draw_comm $clef_comp
            }
        }
    }
}

ret  {NetCDF_file_read} (type nom_, type dico_, type ajout , type nom_, type fichier) {
# Lit les caracteristiques d'un fichier NetCDF
# et les enregistre dans le dictionnaire "nom_dico_ajout"
#
# Retourne le nom court du fichier si ce fichier a été lu correctement
#
    upvar 1 $nom_dico_ajout dico_ajout

    # Ecriture de l'en-tete du fichier netCDF dans un autre ficher
    exec ncdump -h $nom_fichier > ".dmp"
    
    
    # Lecture et stockage des informations de l'en-tete
    #--------------------------------------------------
    
    set status "rien"
    
    if { [file exists .dmp] } {
        set f [open .dmp r]
        
        # Mémorise le fichier sans son chemin
        set nom_fichier [file tail $nom_fichier]
        set dico_ajout($nom_fichier.dir) input
        # Le nom du fichier est editable : par défaut, c'est celui du fichier lu
        set dico_ajout($nom_fichier.name) $nom_fichier
        # Initialise certains attributs du fichier
        set dico_ajout($nom_fichier.io_mode) iosingle

        set time_dim_var ""
        set unlimited_dim ""
        while {![eof $f]} {
            gets $f line
            set line [string trim $line]
            # On regarde dans quelle partie declarative on se trouve
            if {$line == "dimensions:"} {
                set status "on_dim"
                continue
            }
            if {$line == "variables:"} {
                set status "on_var"
                continue
            }
            if {$line == "// global attributes:"} {
                set status "on_ga"
                continue
            }
            # On collecte les donnees en fonction du statut courant
            # GESTION DES DIMENSIONS
            if {$status == "on_dim"} {
                set dim [lindex $line 0]
                # Recherche la dimension "temps" : par son nom (time)
                if {[string toupper $dim] == "TIME"} {
                    set time_dim_var $dim
                }
                # Recherche la dimension dont la taille n'est pas fixe
                set valeur [lindex $line 2]
                if {$valeur == "UNLIMITED"} {
                    # Memorise la variable
                    set unlimited_dim $dim
                }
                continue
            }    
            # GESTION DES VARIABLES
            if {$status == "on_var"} {
                set item1 [lindex $line 0]
                # gestion des attributs des variables 
                if { $item1 == "double" || $item1 == "float" || $item1 == "int" || $item1 == "short" || $item1 == "char" || $item1 == "byte"} {
                    set type_var $item1
                    set debut_nom_var [string length $type_var]
                    incr debut_nom_var
                    set par_ouv [string first "(" $line]
                    set par_fer [string first ")" $line]
                    set nom_var [string range $line $debut_nom_var [expr $par_ouv -1 ]] 
                    set dim_var [string range $line [expr $par_ouv+1] [expr $par_fer-1]]
                    
                    # Si la variable porte le nom de ses dimensions, c'est que c'est une dimension
                    # On ne l'ajoutera pas à la liste
                    if { $nom_var != $dim_var } {
                        lappend dico_ajout($nom_fichier.lchamps) $nom_var
                        set dico_ajout($nom_fichier.$nom_var.type) $type_var
                    }
                } else {
                    if { $item1 == "$nom_var:_FillValue" } {
                        set fill_value [lindex $line 2]
                        set dico_ajout($nom_fichier.$nom_var.fill_value) $fill_value
                    }
                    if { $item1 == "$nom_var:long_name" } {
                        set long_name [lindex $line 2]
                        set dico_ajout($nom_fichier.$nom_var.long_name) $long_name
                    }
                }
                continue
            }
            # GESTION DES ATTRIBUTS GLOBAUX
            if {$status == "on_ga"} {continue}
        }

        # On ferme le fichier .dump dont on a lu le nécessaire
        close $f
        file delete .dmp
        
        # Si la dimension 'temps' n'est pas connue
        if {$time_dim_var == ""} {
            # La dimension temps est a priori celle qui est de taille illimitée
            set time_dim_var $unlimited_dim
            # A ce stade, il se peut que la dimension temps soit encore inconue
        }
        set dico_ajout($nom_fichier.time_name) $time_dim_var
        
        return $nom_fichier
    } else {
        notice_show "'ncdump' not found !\nPlease, install NetCDF support utilities." error
        return ""
    }
}

ret  {NetCDF_file_read_time} (type nom_, type dico_, type ajout , type nom_, type fichier , type nom_, type axe_, type temps) {
# Lit les caractéristiques de l'axe des temps d'un fichier NetCDF
# et les enregistre dans le dictionnaire "nom_dico_ajout"
#
    upvar 1 $nom_dico_ajout dico_ajout

    # Ecriture de l'en-tête du fichier netCDF suivie des données de la dimension temps
    # dans un autre ficher de type texte
    exec ncdump -v $nom_axe_temps $nom_fichier > ".dmp"


    # Lecture et stockage des informations du fichier texte
    #------------------------------------------------------
    
    set status "rien"

    if { [file exists .dmp] } {
        set f [open .dmp r]
        
        # Mémorise le fichier sans son chemin
        set nom_fichier [file tail $nom_fichier]
        # Lit toutes les lignes du fichier une à une
        while {![eof $f]} {
            gets $f line
            set line [string trim $line]
            # On regarde dans quelle partie declarative on se trouve
            if {$line == "dimensions:"} {
                set status "on_dim"
                continue
            }
            if {$line == "variables:"} {
                set status "on_var"
                continue
            }
            if {$line == "// global attributes:"} {
                set status "on_ga"
                continue
            }
            if {$line == "data:"} {
                set status "on_data"
                continue
            }
            # On collecte les donnees en fonction du statut courant
            # GESTION DES DIMENSIONS
            if {$status == "on_dim"} {continue}
            
            # GESTION DES VARIABLES
            if {$status == "on_var"} {
                set item1 [lindex $line 0]
                # si attribut 'units' de la dimension temps
                if { $item1 == "$nom_axe_temps:units" } {
                    set units [lindex $line 2]
                    set dico_ajout($nom_fichier.time_unit) $units
                }
                continue
            }
            # GESTION DES ATTRIBUTS GLOBAUX
            if {$status == "on_ga"} {continue}
            
            # GESTION DES données de l'axe des temps : 1ère ligne
            if {$status == "on_data"} {
                set item1 [lindex $line 0]
                # Si première ligne des données de la dimension temps
                if { $item1 == "$nom_axe_temps" } {
                    # Lit les premières données
                    set liste_valeurs [lrange $line 2 end]
                    # Si la ligne finit par un point-virgule
                    if {[lindex $liste_valeurs end] == ";"} {
                        set status "end"
                    } else {
                        set status "on_time"
                    }
                }
                continue
            }
            # GESTION DES données de l'axe des temps : lignes suivantes
            if {$status == "on_time"} {
                # Lit les données
                set liste_valeurs [concat $liste_valeurs $line]
                # Si la ligne finit par un point-virgule
                if {[lindex $liste_valeurs end] == ";"} {
                    set status "end"
                }
                continue
            }
        }

        # On ferme le fichier .dump dont on a lu le nécessaire
        close $f
        file delete .dmp
        
        # Memrise les attributs de l'axe des temps
        set dico_ajout($nom_fichier.time_values) [lrange $liste_valeurs 0 end-1]
    
    } else {
        notice_show "'ncdump' not found !\nPlease, install NetCDF support utilities." error
    }
}

ret  {NetCDF_file_read_files} (type file_, type list) {
global tagselected oldcolor
    
    # Dictionnaire des fichiers ajoutés
    array set dico_ajout {}
    # Init de la liste des fichiers ajoutés
    set liste_fic_ajoutes {}
    
    foreach file $file_list {
        if {$file != ""} {
            set fic_ajoute [NetCDF_file_read dico_ajout $file]
            if {$fic_ajoute != ""} {
                lappend liste_fic_ajoutes $fic_ajoute
                set nom_fichier [file tail $file]
                # Si le fichier comporte une dimension "temps" clairement reconnaissable
                set nom_axe_temps $dico_ajout($nom_fichier.time_name)
                if {$nom_axe_temps != ""} {
                    # Lit les caractéristiques de l'axe des temps
                    NetCDF_file_read_time dico_ajout $file $nom_axe_temps
                }
            }
        }
    }
    # Met à jour les données et le graphe avec les fichiers ajoutés
    NetCDF_file_maj $liste_fic_ajoutes dico_ajout 1

    # Affiche la liste des fichiers
    control_entity "FILE"
    
    # S'il n'y a qu'un seul fichier ajouté
    if { [llength $file_list] == 1 } {
        set nom_fichier [lindex $file_list 0]
        # Permet la modification des attributs de ce fichier
        set file_id [file tail $nom_fichier]
        NetCDF_file_edit $file_id
        tkwait window .mod_file
    
        # Raffiche le fichier sur le graphe
        set clef ///file///.$file_id
        Draw_one_unit $clef

        # Si ce fichier était sélectionné
        if {$tagselected == "unitpoint_color($clef)"} {
            # Change la couleur de l'objet sélectionné
            set w .gui.pr.cpd22.03
            set oldcolor [$w itemcget $tagselected  -fill ]
            $w itemconfigure $tagselected -fill red
        }
    }
}

ret  {NetCDF_file_update} (type win , type file_, type id , type io_, type direction) {
# Procedure appelee lors de la validation de la boite de dialogue de saisie des parametres
# d'un fichier NetCDF.
#
    # Variables globales
    global liste_fichiers dico_caract_fichiers dico_units
    # Varaibles globales des champs saisis
    global filename_m access_mode_m suffix_m fieldname_m

    # Validation du nom de fichier
    if { $filename_m == "" } {
        notice_show "File name not filled !" error
        focus .mod_file.char.entry1
        return error
    }

    # Si le fichier est un fichier en sortie
    if { $io_direction == "output" } {
        # Validation du nom de champ
        if { $fieldname_m == "" } {
            notice_show "Field name not filled !" error
            focus .mod_file.char.entry4
            return error
        }
    }

    # Réinterprète les booléens
    if {$suffix_m == "yes"} {set suffix_m true} else {set suffix_m false}

    # Si le fichier n'existe pas encore en mémoire
    if { ! [info exists dico_caract_fichiers($file_id.dir)] } {
        # Ajoute l'identifiant à la liste
        lappend liste_fichiers $file_id
        
        # Saisit les caracteristiques du nouveau fichier
        set dico_caract_fichiers($file_id.dir) output
        set dico_caract_fichiers($file_id.lchamps) field
    }   

    # Enregistre les attributs du fichier
    set dico_caract_fichiers($file_id.suffix) $suffix_m
    set dico_caract_fichiers($file_id.io_mode) $access_mode_m
    unset suffix_m access_mode_m
    # Enregistre le nom du fichier
    set dico_caract_fichiers($file_id.name) $filename_m
    unset filename_m
    
    # Si le fichier est un fichier en sortie
    if { $io_direction == "output"} {
        # Enregistre le nom du champ        
        set dico_caract_fichiers($file_id.field.name) $fieldname_m
        unset fieldname_m
        # Enregistre les attributs du champ NetCDF
        # set dico_caract_fichiers($filename_m.$fieldname_m.....) ....
    }

    # Met a jour la couleur
    global color_m
    set clef_comp ///file///.$file_id
    set dico_units($clef_comp.colour) $color_m
    unset color_m
    
    destroy $win
}

ret  {application_edit} (type nom_, type appli) {
##################################################
# menu d'edition d'une application
##################################################
    global dico_applis
    
    # Extrait les informations concernant l'application
    global exe_name_m args_m redirect_m
    
    set exe_name_m ""
    catch { set exe_name_m $dico_applis(app.$nom_appli.executable_name) }
    set args_m ""
    catch { set args_m $dico_applis(app.$nom_appli.args) }
    set redirect_m "true"
    catch { set redirect_m $dico_applis(app.$nom_appli.redirect) }
    if { $redirect_m == "true" } {
        set redirect_m "yes"
    } else {
        set redirect_m "no"
    }
    
    #== number of processes
    set min_proc $dico_applis(app.$nom_appli.proc.min_value)
    set max_proc $dico_applis(app.$nom_appli.proc.max_value)
    set increment $dico_applis(app.$nom_appli.proc.increment)
    
    # Start mode
    set start_mode $dico_applis(app.$nom_appli.start_mode)
    array set translation_dict { spawn Spawn notspawn {Not spawn} notspawn_or_spawn {Either spawn or not spawn}}
    set start_mode $translation_dict($start_mode)
    
    # Recopie les infos concernant les ordinateurs hosts de l'application
    global hosts_m
    array set hosts_m {}
    if { [info exists dico_applis(app.$nom_appli.lhosts)] && $dico_applis(app.$nom_appli.lhosts) != "" } {
        set hosts_m(lhosts) $dico_applis(app.$nom_appli.lhosts)
        foreach id_host $dico_applis(app.$nom_appli.lhosts) {
            set clef app.$nom_appli.host.$id_host
            set hosts_m(host.$id_host.name) $dico_applis($clef.name)
            set hosts_m(host.$id_host.nb_procs) $dico_applis($clef.nb_procs)
        }    
    } else {
        # Definit un "host" arbitraire avec N processus
        set hosts_m(lhosts) "1"
        set hosts_m(host.1.name) "Enter name..."
        set hosts_m(host.1.nb_procs) $max_proc
        if {$max_proc == 0} {inc hosts_m(host.1.nb_procs)}
    }
    
    # un toplevel
    set u .mod_appli
    catch {destroy $u}
    toplevel $u
    wm title $u "Edit Application"
    wm iconname $u "Mod_Appli"
    window_position $u 100 100
    
    set w $u.menu
    frame $w
    grid $w -row 2 -column 0
    grid configure $w -columnspan 2 -padx 4 -pady 4

    frame $w.buttons
    pack $w.buttons -side bottom -fill x -pady 2m

    button $w.buttons.dismiss  -text Cancel -command "destroy $u"
    button $w.buttons.ok  -text Ok -command "application_update $u $nom_appli \$exe_name_m \$args_m \$redirect_m hosts_m"

    pack $w.buttons.dismiss -side left -expand 1 -padx 10
    pack $w.buttons.ok -side left -expand 1 -padx 10

    frame $w.sep1 -width 200 -height 2 -borderwidth 1 -relief sunken
    pack $w.sep1 -side bottom -fill x -pady 2m -expand 1

    set w $u.char
    frame $w
    grid $w -row 0 -column 1
    grid configure $w -padx 4 -pady 4
    set r 1

#== nom
    label $w.label1 -text "Name: "
    label $w.label11 -relief sunken -text $nom_appli
    grid  $w.label1 $w.label11 -row $r -sticky w
    incr r

#== number of processes
    label $w.label2 -text "Number of processes : "
    label $w.label21 -relief sunken -text "$min_proc to $max_proc step $increment"
    grid  $w.label2 $w.label21 -row $r -sticky w
    incr r

#== start mode
    label $w.label20 -text "Allowed start mode : "
    label $w.label201 -relief sunken -text "$start_mode"
    grid  $w.label20 $w.label201 -row $r -sticky w
    incr r

    # Séparateur
    frame $w.sep1 -width 200 -height 2 -borderwidth 1 -relief sunken
    grid  $w.sep1 -row $r -columnspan 2 -pady 5
    incr r

#== executable
    label $w.label3 -text "Executable name : " -fg #ee3333
    entry $w.entry3 -textvariable exe_name_m -width 25 -background white
    grid  $w.label3 $w.entry3 -row $r -sticky w
    incr r

    # Ajoute une bulle d'aide pour 'Executable name'
    set help_text {Enter here the application executable name, defined by the compiling environment (used only in spawn mode as argument of the MPI_Comm_Spawn_Multiple).}
    entry_help_balloon $w.entry3 $help_text

#== Executable arguments
    label $w.label4 -text "Executable args : "
    entry $w.entry4 -textvariable args_m -width 25 -background white
    grid  $w.label4 $w.entry4 -row $r -sticky w
    incr r

    # Ajoute une bulle d'aide pour 'Executable args'
    set help_text {Enter here a list of launching arguments for the application executable}
    entry_help_balloon $w.entry4 $help_text

#== redirect stdout
    label $w.label5 -text "Redirect stdout : " 
    combobox_lim $w.cmb5 {yes no} {} redirect_m 10 $redirect_m
    grid  $w.label5 $w.cmb5 -row $r -sticky w
    incr r

    # Ajoute une bulle d'aide pour 'redirect stdout'
    set help_text {Enter here whether the application stdout shall be redirected or not.}
    entry_help_balloon $w.cmb5 $help_text

    # Séparateur
    frame $w.sep2 -width 200 -height 2 -borderwidth 1 -relief sunken
    grid  $w.sep2 -row $r -columnspan 2 -pady 5
    incr r

#== Hosts
    label $w.label6 -text "Hosts : "
    scrollform_create $w.sform
    set form [scrollform_interior $w.sform]
    button $w.insert_host -text "Add" -command "host_insert $form"
    grid  $w.label6 $w.insert_host -row $r -sticky w
    incr r

    # une frame et un label pour le titre
    frame $w.fr2 
    grid $w.fr2 -row $r -sticky w -columnspan 2
    label $w.fr2.title1 -text "     Name                            Nb processes " -borderwidth 1 -justify left
    pack $w.fr2.title1 -anchor w
    incr r
    
    # une frame scrollable pour les "hosts"
    grid $w.sform -row $r -columnspan 2 -sticky ew
    $form configure -borderwidth 1 -relief sunken
    # grid columnconfigure $form 0 -minsize 15 -weight 15
    # grid columnconfigure $form 1 -minsize 10 -weight 10

   # insertion des boutons pour les hosts existant
    set nb_hosts 0
    foreach id_host $hosts_m(lhosts) {
        host_boutons_insert $form $id_host $nb_hosts
        incr nb_hosts
    }

    # Ajoute une bulle d'aide pour le bouton 'Add Host'
    global no_help_balloon
    if { $no_help_balloon == 0 } {
        set help_text {Click here to add a host to the list.}
        set help_action "help_object %W [list $help_text] message"
        bind $w.insert_host <Any-Enter> $help_action
        bind $w.insert_host <FocusIn>   $help_action
        bind $w.insert_host <Any-Leave>    "help_object_hide"
        bind $w.insert_host <FocusOut>     "help_object_hide"
        bind $w.insert_host <ButtonPress>  "help_object_hide"
    }
    
    # Ajoute une bulle d'aide pour la liste des 'hosts'
    set help_text {Enter here a list of hosts; for each host:
   
   1) the host name (used only in spawn mode as argument of the MPI_Comm_Spawn_Multiple).

   2) the number of processes to run this host (used in the not spawn method to split the global communicator; for the spawn method, used as argument in MPI_Comm_Spawn_Multiple ).}
    entry_help_balloon $w.sform $help_text

    # Si fermeture de la fenêtre, cache la bulle d'aide    
    bind $u <Destroy> "help_object_hide"
}

ret  {application_update} (type win , type nom_, type appli , type exe_, type name , type args , type redirect , type hosts_, type list) {
# Validation de saisie des parametres d'une application
    global dico_applis
    
    upvar 1 $hosts_list hosts

    # Si l'application doit être lancée par OASIS
    set start_mode $dico_applis(app.$nom_appli.start_mode)
    if {$start_mode != "notspawn"} {
        # Vérifie le nom du prog. exe
        if { $exe_name == "" } {
            notice_show "Please, enter an executable file name !" error
            focus .mod_appli.char.entry3
            return error
        }
    }
        
    # Vérifie le nombre des ordinateurs hosts de l'application
    # --------------------------------------------------------

    if { [llength $hosts(lhosts)] != 0 } {
        
        set nb_proc_total 0
        foreach id_host $hosts(lhosts) {
            # Si le nom ou le nombre de processus de l'ordinateur host est defini
            if {$hosts(host.$id_host.name) != "" || $hosts(host.$id_host.nb_procs) != ""} {
                # Si le nbre de processus est défini
                if { [regexp {^[0-9]+$} $hosts(host.$id_host.nb_procs)] } {
                    # Additionne au total
                    incr nb_proc_total $hosts(host.$id_host.nb_procs)
                }
            }
        }
        
        # Verifie que le nombre de processus est dans la fourchette acceptable pour l'appli
        set min_proc $dico_applis(app.$nom_appli.proc.min_value)
        set max_proc $dico_applis(app.$nom_appli.proc.max_value)
        set increment $dico_applis(app.$nom_appli.proc.increment)
        if {$max_proc != 0} {
            if { $nb_proc_total >= $min_proc && $nb_proc_total <= $max_proc } {
            
                # Vérifie que le nombre est un multiple attendu
                if {[expr ($nb_proc_total - $min_proc) % $increment] == 0} {
                    # OK
                } else {
                    notice_show "Total number of processes ($nb_proc_total) out of the arithmetic series : \[$min_proc to $max_proc\] step $increment !" error
                    return error
                }
            } else {
                notice_show "Total number of processes ($nb_proc_total) out of the range \[$min_proc, $max_proc\]!" error
                return error
            }
        }
        
        # Recopie les infos concernant l'application
        set dico_applis(app.$nom_appli.executable_name) $exe_name
        set dico_applis(app.$nom_appli.args) $args
        if { $redirect == "yes" } {
            set redirect "true"
        } else {
            set redirect "false"
        }
        set dico_applis(app.$nom_appli.redirect) $redirect
        
        # Recopie les infos concernant les ordinateurs hosts de l'application
        set dico_applis(app.$nom_appli.lhosts) {}
        array unset dico_applis app.$nom_appli.host.*
        foreach id_host $hosts(lhosts) {
            # Si le nom de l'ordinateur host est defini
            if {$hosts(host.$id_host.name) != ""} {
                # Si le nbre de processus est défini
                if { [regexp {^[0-9]+$} $hosts(host.$id_host.nb_procs)] } {
                    lappend dico_applis(app.$nom_appli.lhosts) $id_host
                    set clef app.$nom_appli.host.$id_host
                    set dico_applis($clef.name) $hosts(host.$id_host.name)
                    set dico_applis($clef.nb_procs) $hosts(host.$id_host.nb_procs)
                }
            }
        }
        destroy $win
    } else {
        notice_show "Please, enter some host on which the application will run !" error
        return error
    }
}

ret  {chemin} (type x1 , type y1 , type x2 , type y2) {
#=========de dessus a dessous
        if { $y1 < $y2 } {
            set y10 [expr $y1 +12 ]
            set y11 [expr $y2 -12]
            set y3 [expr $y1+($y2-$y1)/10 +12]
            set y4 [expr $y2-($y2-$y1)/10 -12]
            set x3 [expr $x1+($x2-$x1)/10 ]
            set x4 [expr $x2-($x2-$x1)/10 ]
            return "$x1 $y1 $x1 $y10 $x3 $y3 $x4 $y4  $x2 $y11 $x2 $y2"
        #=========de dessous a dessus
        } else {
            set y3 [expr $y1 +12]
            set y4 [expr $y2 -12]
            set x3 [expr ($x1+$x2)/2]
            return "$x1 $y1 $x1 $y3 $x3 $y3 $x3 $y4 $x2 $y4 $x2 $y2"
        }
}

ret  {chemin_force} (type x1 , type y1 , type x2 , type y2 , optional milieu_x ={) {milieu_y {}}} {
/*  Chemin forcé : de passer par un point milieu, s'il est donné*/
        /* =========de dessus a dessous*/
        if { $y1 < $y2 } {
             y10 =  [expr $y1 +12 ]
             y11 =  [expr $y2 -12]
             y3 =  [expr $y1+($y2-$y1)/10 +12]
             y4 =  [expr $y2-($y2-$y1)/10 -12]
             x3 =  [expr $x1+($x2-$x1)/10 ]
             x4 =  [expr $x2-($x2-$x1)/10 ]
            if { $milieu_x != ""} {
                return "$x1 $y1 $x1 $y10 $x3 $y3 $milieu_x $milieu_y $x4 $y4  $x2 $y11 $x2 $y2"
            } else {
                return "$x1 $y1 $x1 $y10 $x3 $y3 $x4 $y4  $x2 $y11 $x2 $y2"
            }
        /* =========de dessous a dessus*/
        } else {
             y3 =  [expr $y1 +12]
             y4 =  [expr $y2 -12]
             x3 =  [expr ($x1+$x2)/2]
            if { $milieu_x != ""} {
                if { $milieu_y > $y3 } {
                     y3 =  [expr $milieu_y +12]
                }
                if { $milieu_y < $y4 } {
                     y4 =  [expr $milieu_y -12]
                }
                return "$x1 $y1 $x1 $y3 $milieu_x $y3 $milieu_x $milieu_y $milieu_x $y4 $x2 $y4 $x2 $y2"
            } else {
                return "$x1 $y1 $x1 $y3 $x3 $y3 $x3 $y4 $x2 $y4 $x2 $y2"
            }
        }
}

ret  {choose_font} (optional choose_init ={helvetica 12) texttoedit colortext just} {
set w .choose_font
    global dxf
    set dxf(text) $texttoedit
    set dxf(choose_font_cb_color) $colortext
    set dxf(choose_font_cb_justify) $just
    set tmp [get_actual_font $choose_init]

    window.font $choose_init $texttoedit
    update

    catch {.choose_font.view delete 0.0 end}
    catch {.choose_font.view insert 0.0 $texttoedit}
    catch {.choose_font.view configure -foreground $colortext}
    catch {.choose_font.view configure -justify $just}
    update
    catch {grab $w}
    focus -force $w
    wm deiconify $w
    tkwait window $w

    grab release $w
    return [list $dxf(tmp) $dxf(text) $dxf(choose_font_cb_color) $dxf(choose_font_cb_justify)]
}

ret  {color_fonce} (type color) {
set r 0
set g 0
set b 0
scan $color "\#%2x%2x%2x" r g b
set r [expr $r*7/8]
set g [expr $g*7/8]
set b [expr $b*7/8]

return [color_rgb $r $g $b]
}

ret  {color_melange} (type color1 , type color2) {
set r 0
set g 0
set b 0
set r1 0
set g1 0
set b1 0


scan $color1 "\#%2x%2x%2x" r g b
scan $color2 "\#%2x%2x%2x" r1 g1 b1
set r [expr ($r+$r1)/2]
set g [expr ($g+$g1)/2]
set b [expr ($b+$b1)/2]
return [color_rgb $r $g $b]
}

ret  {color_pastelise} (type color) {
set r 0
set g 0
set b 0


scan $color "\#%2x%2x%2x" r g b
set r [expr ($r+127)/3*2]
set g [expr ($g+127)/3*2]
set b [expr ($b+127)/3*2]
return [color_rgb $r $g $b]
}

ret  {color_rgb} (type r , type g , type b) {
set rgb \#[format "%.2X%.2X%.2X" $r $g $b]
return $rgb
}

ret  {color_tresclair} (type color) {
set r 0
set g 0
set b 0
scan $color "\#%2x%2x%2x" r g b

while {[expr $r+$g+$b] < 712} {
  set r [expr ($r+127)/3*2]
  set g [expr ($g+127)/3*2]
  set b [expr ($b+127)/3*2]
}
return [color_rgb $r $g $b]
}

ret  {color_white_or_black} (type color) {
set r 0
set g 0
set b 0

scan $color "\#%2x%2x%2x" r g b
set colorreturn white
if {[expr $r + $g + $b] > 300 } {set colorreturn black}

return $colorreturn
}

ret  {combobox_init} () {
# Copyright (c) 1998-2002, Bryan Oakley
# All Rights Reservered
#
# Bryan Oakley
# oakley@bardo.clearlight.com
#
# combobox v2.2.1 September 22, 2002
#
# a combobox / dropdown listbox (pick your favorite name) widget
# written in pure tcl
#
# this code is freely distributable without restriction, but is
# provided as-is with no warranty expressed or implied.
#
# thanks to the following people who provided beta test support or
# patches to the code (in no particular order):
#
# Scott Beasley     Alexandre Ferrieux      Todd Helfter
# Matt Gushee       Laurent Duperval        John Jackson
# Fred Rapp         Christopher Nelson
# Eric Galluzzo     Jean-Francois Moine
#
# A special thanks to Martin M. Hunt who provided several good ideas,
# and always with a patch to implement them. Jean-Francois Moine,
# Todd Helfter and John Jackson were also kind enough to send in some
# code patches.
#
# ... and many others over the years.

package require Tk 8.0
package provide combobox 2.2.1

namespace eval ::combobox {

    # this is the public interface
    namespace export combobox

    # these contain references to available options
    variable widgetOptions

    # these contain references to available commands and subcommands
    variable widgetCommands
    variable scanCommands
    variable listCommands
}

# ::combobox::combobox --
#
#     This is the command that gets exported. It creates a new
#     combobox widget.
#
# Arguments:
#
#     w        path of new widget to create
#     args     additional option/value pairs (eg: -background white, etc.)
#
# Results:
#
#     It creates the widget and sets up all of the default bindings
#
# Returns:
#
#     The name of the newly create widget

proc ::combobox::combobox {w args} {
    variable widgetOptions
    variable widgetCommands
    variable scanCommands
    variable listCommands

    # perform a one time initialization
    if {![info exists widgetOptions]} {
    Init
    }

    # build it...
    eval Build $w $args

    # set some bindings...
    SetBindings $w

    # and we are done!
    return $w
}


# ::combobox::Init --
#
#     Initialize the namespace variables. This should only be called
#     once, immediately prior to creating the first instance of the
#     widget
#
# Arguments:
#
#    none
#
# Results:
#
#     All state variables are set to their default values; all of
#     the option database entries will exist.
#
# Returns:
#
#     empty string

proc ::combobox::Init {} {
    variable widgetOptions
    variable widgetCommands
    variable scanCommands
    variable listCommands
    variable defaultEntryCursor

    array set widgetOptions [list  -background          {background          Background}  -bd                  -borderwidth  -bg                  -background  -borderwidth         {borderWidth         BorderWidth}  -command             {command             Command}  -commandstate        {commandState        State}  -cursor              {cursor              Cursor}  -disabledbackground  {disabledBackground  DisabledBackground}  -disabledforeground  {disabledForeground  DisabledForeground}  -dropdownwidth       {dropdownWidth       DropdownWidth}  -editable            {editable            Editable}  -fg                  -foreground  -font                {font                Font}  -foreground          {foreground          Foreground}  -height              {height              Height}  -highlightbackground {highlightBackground HighlightBackground}  -highlightcolor      {highlightColor      HighlightColor}  -highlightthickness  {highlightThickness  HighlightThickness}  -image               {image               Image}  -maxheight           {maxHeight           Height}  -opencommand         {opencommand         Command}  -relief              {relief              Relief}  -selectbackground    {selectBackground    Foreground}  -selectborderwidth   {selectBorderWidth   BorderWidth}  -selectforeground    {selectForeground    Background}  -state               {state               State}  -takefocus           {takeFocus           TakeFocus}  -textvariable        {textVariable        Variable}  -value               {value               Value}  -width               {width               Width}  -xscrollcommand      {xScrollCommand      ScrollCommand}  ]


    set widgetCommands [list  bbox      cget     configure    curselection  delete    get      icursor      index         insert    list     scan         selection     xview     select   toggle       open          close      ]

    set listCommands [list  delete       get       index        insert       size  ]

    set scanCommands [list mark dragto]

    # why check for the Tk package? This lets us be sourced into
    # an interpreter that doesn't have Tk loaded, such as the slave
    # interpreter used by pkg_mkIndex. In theory it should have no
    # side effects when run
    if {[lsearch -exact [package names] "Tk"] != -1} {

    ##################################################################
    #- this initializes the option database. Kinda gross, but it works
    #- (I think).
    ##################################################################

    # the image used for the button...
    if {$::tcl_platform(platform) == "windows"} {
        image create bitmap ::combobox::bimage -data {
        #define down_arrow_width 12
        #define down_arrow_height 12
        static char down_arrow_bits[] = {
            0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00,
            0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0,
            0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00;
        }
        }
    } else {
        image create bitmap ::combobox::bimage -data  {
        #define down_arrow_width 15
        #define down_arrow_height 15
        static char down_arrow_bits[] = {
            0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80,
            0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83,
            0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80,
            0x00,0x80,0x00,0x80,0x00,0x80
        }
        }
    }

    # compute a widget name we can use to create a temporary widget
    set tmpWidget ".__tmp__"
    set count 0
    while {[winfo exists $tmpWidget] == 1} {
        set tmpWidget ".__tmp__$count"
        incr count
    }

    # get the scrollbar width. Because we try to be clever and draw our
    # own button instead of using a tk widget, we need to know what size
    # button to create. This little hack tells us the width of a scroll
    # bar.
    #
    # NB: we need to be sure and pick a window  that doesn't already
    # exist...
    scrollbar $tmpWidget
    set sb_width [winfo reqwidth $tmpWidget]
    destroy $tmpWidget

    # steal options from the entry widget
    # we want darn near all options, so we'll go ahead and do
    # them all. No harm done in adding the one or two that we
    # don't use.
    entry $tmpWidget
    foreach foo [$tmpWidget configure] {
        # the cursor option is special, so we'll save it in
        # a special way
        if {[lindex $foo 0] == "-cursor"} {
        set defaultEntryCursor [lindex $foo 4]
        }
        if {[llength $foo] == 5} {
        set option [lindex $foo 1]
        set value [lindex $foo 4]
        option add *Combobox.$option $value widgetDefault

        # these options also apply to the dropdown listbox
        if {[string compare $option "foreground"] == 0  || [string compare $option "background"] == 0  || [string compare $option "font"] == 0} {
            option add *Combobox*ComboboxListbox.$option $value  widgetDefault
        }
        }
    }
    destroy $tmpWidget

    # these are unique to us...
    option add *Combobox.dropdownWidth       {}     widgetDefault
    option add *Combobox.openCommand         {}     widgetDefault
    option add *Combobox.cursor              {}     widgetDefault
    option add *Combobox.commandState        normal widgetDefault
    option add *Combobox.editable            1      widgetDefault
    option add *Combobox.maxHeight           10     widgetDefault
    option add *Combobox.height              0
    }

    # set class bindings
    SetClassBindings
}

# ::combobox::SetClassBindings --
#
#    Sets up the default bindings for the widget class
#
#    this proc exists since it's The Right Thing To Do, but
#    I haven't had the time to figure out how to do all the
#    binding stuff on a class level. The main problem is that
#    the entry widget must have focus for the insertion cursor
#    to be visible. So, I either have to have the entry widget
#    have the Combobox bindtag, or do some fancy juggling of
#    events or some such. What a pain.
#
# Arguments:
#
#    none
#
# Returns:
#
#    empty string

proc ::combobox::SetClassBindings {} {

    # make sure we clean up after ourselves...
    bind Combobox <Destroy> [list ::combobox::DestroyHandler %W]

    # this will (hopefully) close (and lose the grab on) the
    # listbox if the user clicks anywhere outside of it. Note
    # that on Windows, you can click on some other app and
    # the listbox will still be there, because tcl won't see
    # that button click
    set this {[::combobox::convert %W -W]}
    bind Combobox <Any-ButtonPress>   "$this close"
    bind Combobox <Any-ButtonRelease> "$this close"

    # this helps (but doesn't fully solve) focus issues. The general
    # idea is, whenever the frame gets focus it gets passed on to
    # the entry widget
    bind Combobox <FocusIn> {::combobox::tkTabToWindow [::combobox::convert %W -W].entry}

    # this closes the listbox if we get hidden
    bind Combobox <Unmap> {[::combobox::convert %W -W] close}

    return ""
}

# ::combobox::SetBindings --
#
#    here's where we do most of the binding foo. I think there's probably
#    a few bindings I ought to add that I just haven't thought
#    about...
#
#    I'm not convinced these are the proper bindings. Ideally all
#    bindings should be on "Combobox", but because of my juggling of
#    bindtags I'm not convinced thats what I want to do. But, it all
#    seems to work, its just not as robust as it could be.
#
# Arguments:
#
#    w    widget pathname
#
# Returns:
#
#    empty string

proc ::combobox::SetBindings {w} {
    upvar ::combobox::${w}::widgets  widgets
    upvar ::combobox::${w}::options  options

    # juggle the bindtags. The basic idea here is to associate the
    # widget name with the entry widget, so if a user does a bind
    # on the combobox it will get handled properly since it is
    # the entry widget that has keyboard focus.
    bindtags $widgets(entry)  [concat $widgets(this) [bindtags $widgets(entry)]]

    bindtags $widgets(button)  [concat $widgets(this) [bindtags $widgets(button)]]

    # override the default bindings for tab and shift-tab. The
    # focus procs take a widget as their only parameter and we
    # want to make sure the right window gets used (for shift-
    # tab we want it to appear as if the event was generated
    # on the frame rather than the entry.
    bind $widgets(entry) <Tab>  "::combobox::tkTabToWindow \[tk_focusNext $widgets(entry)\]; break"
    bind $widgets(entry) <Shift-Tab>  "::combobox::tkTabToWindow \[tk_focusPrev $widgets(this)\]; break"

    # this makes our "button" (which is actually a label)
    # do the right thing
    bind $widgets(button) <ButtonPress-1> [list $widgets(this) toggle]

    # this lets the autoscan of the listbox work, even if they
    # move the cursor over the entry widget.
    bind $widgets(entry) <B1-Enter> "break"

    bind $widgets(listbox) <ButtonRelease-1>  "::combobox::Select [list $widgets(this)]  \[$widgets(listbox) nearest %y\]; break"

    bind $widgets(vsb) <ButtonPress-1>   {continue}
    bind $widgets(vsb) <ButtonRelease-1> {continue}

    bind $widgets(listbox) <Any-Motion> {
    %W selection clear 0 end
    %W activate @%x,%y
    %W selection anchor @%x,%y
    %W selection set @%x,%y @%x,%y
    # need to do a yview if the cursor goes off the top
    # or bottom of the window... (or do we?)
    }

    # these events need to be passed from the entry widget
    # to the listbox, or otherwise need some sort of special
    # handling.
    foreach event [list <Up> <Down> <Tab> <Return> <Escape>  <Next> <Prior> <Double-1> <1> <Any-KeyPress>  <FocusIn> <FocusOut>] {
    bind $widgets(entry) $event  [list ::combobox::HandleEvent $widgets(this) $event]
    }

    # like the other events, <MouseWheel> needs to be passed from
    # the entry widget to the listbox. However, in this case we
    # need to add an additional parameter
    catch {
    bind $widgets(entry) <MouseWheel>  [list ::combobox::HandleEvent $widgets(this) <MouseWheel> %D]
    }
}

# ::combobox::Build --
#
#    This does all of the work necessary to create the basic
#    combobox.
#
# Arguments:
#
#    w        widget name
#    args     additional option/value pairs
#
# Results:
#
#    Creates a new widget with the given name. Also creates a new
#    namespace patterened after the widget name, as a child namespace
#    to ::combobox
#
# Returns:
#
#    the name of the widget

proc ::combobox::Build {w args } {
    variable widgetOptions

    if {[winfo exists $w]} {
    error "window name \"$w\" already exists"
    }

    # create the namespace for this instance, and define a few
    # variables
    namespace eval ::combobox::$w {

    variable ignoreTrace 0
    variable oldFocus    {}
    variable oldGrab     {}
    variable oldValue    {}
    variable options
    variable this
    variable widgets

    set widgets(foo) foo  ;# coerce into an array
    set options(foo) foo  ;# coerce into an array

    unset widgets(foo)
    unset options(foo)
    }

    # import the widgets and options arrays into this proc so
    # we don't have to use fully qualified names, which is a
    # pain.
    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    # this is our widget -- a frame of class Combobox. Naturally,
    # it will contain other widgets. We create it here because
    # we need it in order to set some default options.
    set widgets(this)   [frame  $w -class Combobox -takefocus 0]
    set widgets(entry)  [entry  $w.entry -takefocus 1]
    set widgets(button) [label  $w.button -takefocus 0]

    # this defines all of the default options. We get the
    # values from the option database. Note that if an array
    # value is a list of length one it is an alias to another
    # option, so we just ignore it
    foreach name [array names widgetOptions] {
    if {[llength $widgetOptions($name)] == 1} continue

    set optName  [lindex $widgetOptions($name) 0]
    set optClass [lindex $widgetOptions($name) 1]

    set value [option get $w $optName $optClass]
    set options($name) $value
    }

    # a couple options aren't available in earlier versions of
    # tcl, so we'll set them to sane values. For that matter, if
    # they exist but are empty, set them to sane values.
    if {[string length $options(-disabledforeground)] == 0} {
        set options(-disabledforeground) $options(-foreground)
    }
    if {[string length $options(-disabledbackground)] == 0} {
        set options(-disabledbackground) $options(-background)
    }

    # if -value is set to null, we'll remove it from our
    # local array. The assumption is, if the user sets it from
    # the option database, they will set it to something other
    # than null (since it's impossible to determine the difference
    # between a null value and no value at all).
    if {[info exists options(-value)]  && [string length $options(-value)] == 0} {
    unset options(-value)
    }

    # we will later rename the frame's widget proc to be our
    # own custom widget proc. We need to keep track of this
    # new name, so we'll define and store it here...
    set widgets(frame) ::combobox::${w}::$w

    # gotta do this sooner or later. Might as well do it now
    pack $widgets(entry)  -side left  -fill both -expand yes
    pack $widgets(button) -side right -fill y    -expand no

    # I should probably do this in a catch, but for now it's
    # good enough... What it does, obviously, is put all of
    # the option/values pairs into an array. Make them easier
    # to handle later on...
    array set options $args

    # now, the dropdown list... the same renaming nonsense
    # must go on here as well...
    set widgets(dropdown)   [toplevel  $w.top]
    set widgets(listbox) [listbox   $w.top.list]
    set widgets(vsb)     [scrollbar $w.top.vsb]

    pack $widgets(listbox) -side left -fill both -expand y

    # fine tune the widgets based on the options (and a few
    # arbitrary values...)

    # NB: we are going to use the frame to handle the relief
    # of the widget as a whole, so the entry widget will be
    # flat. This makes the button which drops down the list
    # to appear "inside" the entry widget.

    $widgets(vsb) configure  -command "$widgets(listbox) yview"  -highlightthickness 0

    $widgets(button) configure  -highlightthickness 0  -borderwidth 1  -relief raised  -width [expr {[winfo reqwidth $widgets(vsb)] - 2}]

    $widgets(entry) configure  -borderwidth 0  -relief flat  -highlightthickness 0

    $widgets(dropdown) configure  -borderwidth 1  -relief sunken

    $widgets(listbox) configure  -selectmode browse  -background [$widgets(entry) cget -bg]  -yscrollcommand "$widgets(vsb) set"  -exportselection false  -borderwidth 0


#    trace variable ::combobox::${w}::entryTextVariable w  #        [list ::combobox::EntryTrace $w]
    
    # do some window management foo on the dropdown window
    wm overrideredirect $widgets(dropdown) 1
    wm transient        $widgets(dropdown) [winfo toplevel $w]
    wm group            $widgets(dropdown) [winfo parent $w]
    wm resizable        $widgets(dropdown) 0 0
    wm withdraw         $widgets(dropdown)

    # this moves the original frame widget proc into our
    # namespace and gives it a handy name
    rename ::$w $widgets(frame)

    # now, create our widget proc. Obviously (?) it goes in
    # the global namespace. All combobox widgets will actually
    # share the same widget proc to cut down on the amount of
    # bloat.
    proc ::$w {command args}  "eval ::combobox::WidgetProc $w \$command \$args"


    # ok, the thing exists... let's do a bit more configuration.
    if {[catch "::combobox::Configure [list $widgets(this)] [array get options]" error]} {
    catch {destroy $w}
    error "internal error: $error"
    }

    return ""

}

# ::combobox::HandleEvent --
#
#    this proc handles events from the entry widget that we want
#    handled specially (typically, to allow navigation of the list
#    even though the focus is in the entry widget)
#
# Arguments:
#
#    w       widget pathname
#    event   a string representing the event (not necessarily an
#            actual event)
#    args    additional arguments required by particular events

proc ::combobox::HandleEvent {w event args} {
    upvar ::combobox::${w}::widgets  widgets
    upvar ::combobox::${w}::options  options
    upvar ::combobox::${w}::oldValue oldValue

    # for all of these events, if we have a special action we'll
    # do that and do a "return -code break" to keep additional
    # bindings from firing. Otherwise we'll let the event fall
    # on through.
    switch $event {

        "<MouseWheel>" {
        if {[winfo ismapped $widgets(dropdown)]} {
                set D [lindex $args 0]
                # the '120' number in the following expression has
                # it's genesis in the tk bind manpage, which suggests
                # that the smallest value of %D for mousewheel events
                # will be 120. The intent is to scroll one line at a time.
                $widgets(listbox) yview scroll [expr {-($D/120)}] units
            }
        }

    "<Any-KeyPress>" {
        # if the widget is editable, clear the selection.
        # this makes it more obvious what will happen if the
        # user presses <Return> (and helps our code know what
        # to do if the user presses return)
        if {$options(-editable)} {
        $widgets(listbox) see 0
        $widgets(listbox) selection clear 0 end
        $widgets(listbox) selection anchor 0
        $widgets(listbox) activate 0
        }
    }

    "<FocusIn>" {
        set oldValue [$widgets(entry) get]
    }

    "<FocusOut>" {
        if {![winfo ismapped $widgets(dropdown)]} {
        # did the value change?
        set newValue [$widgets(entry) get]
        if {$oldValue != $newValue} {
            CallCommand $widgets(this) $newValue
        }
        }
    }

    "<1>" {
        set editable [::combobox::GetBoolean $options(-editable)]
        if {!$editable} {
        if {[winfo ismapped $widgets(dropdown)]} {
            $widgets(this) close
            return -code break;

        } else {
            if {$options(-state) != "disabled"} {
            $widgets(this) open
            return -code break;
            }
        }
        }
    }

    "<Double-1>" {
        if {$options(-state) != "disabled"} {
        $widgets(this) toggle
        return -code break;
        }
    }

    "<Tab>" {
        if {[winfo ismapped $widgets(dropdown)]} {
        ::combobox::Find $widgets(this) 0
        return -code break;
        } else {
        ::combobox::SetValue $widgets(this) [$widgets(this) get]
        }
    }

    "<Escape>" {
#       $widgets(entry) delete 0 end
#       $widgets(entry) insert 0 $oldValue
        if {[winfo ismapped $widgets(dropdown)]} {
        $widgets(this) close
        return -code break;
        }
    }

    "<Return>" {
        # did the value change?
        set newValue [$widgets(entry) get]
        if {$oldValue != $newValue} {
        CallCommand $widgets(this) $newValue
        }

        if {[winfo ismapped $widgets(dropdown)]} {
        ::combobox::Select $widgets(this)  [$widgets(listbox) curselection]
        return -code break;
        }

    }

    "<Next>" {
        $widgets(listbox) yview scroll 1 pages
        set index [$widgets(listbox) index @0,0]
        $widgets(listbox) see $index
        $widgets(listbox) activate $index
        $widgets(listbox) selection clear 0 end
        $widgets(listbox) selection anchor $index
        $widgets(listbox) selection set $index

    }

    "<Prior>" {
        $widgets(listbox) yview scroll -1 pages
        set index [$widgets(listbox) index @0,0]
        $widgets(listbox) activate $index
        $widgets(listbox) see $index
        $widgets(listbox) selection clear 0 end
        $widgets(listbox) selection anchor $index
        $widgets(listbox) selection set $index
    }

    "<Down>" {
        if {[winfo ismapped $widgets(dropdown)]} {
        ::combobox::tkListboxUpDown $widgets(listbox) 1
        return -code break;

        } else {
        if {$options(-state) != "disabled"} {
            $widgets(this) open
            return -code break;
        }
        }
    }
    "<Up>" {
        if {[winfo ismapped $widgets(dropdown)]} {
        ::combobox::tkListboxUpDown $widgets(listbox) -1
        return -code break;

        } else {
        if {$options(-state) != "disabled"} {
            $widgets(this) open
            return -code break;
        }
        }
    }
    }

    return ""
}

# ::combobox::DestroyHandler {w} --
#
#    Cleans up after a combobox widget is destroyed
#
# Arguments:
#
#    w    widget pathname
#
# Results:
#
#    The namespace that was created for the widget is deleted,
#    and the widget proc is removed.

proc ::combobox::DestroyHandler {w} {

    # if the widget actually being destroyed is of class Combobox,
    # crush the namespace and kill the proc. Get it? Crush. Kill.
    # Destroy. Heh. Danger Will Robinson! Oh, man! I'm so funny it
    # brings tears to my eyes.
    if {[string compare [winfo class $w] "Combobox"] == 0} {
    upvar ::combobox::${w}::widgets  widgets
    upvar ::combobox::${w}::options  options

    # delete the namespace and the proc which represents
    # our widget
    namespace delete ::combobox::$w
    rename $w {}
    }

    return ""
}

# ::combobox::Find
#
#    finds something in the listbox that matches the pattern in the
#    entry widget and selects it
#
#    N.B. I'm not convinced this is working the way it ought to. It
#    works, but is the behavior what is expected? I've also got a gut
#    feeling that there's a better way to do this, but I'm too lazy to
#    figure it out...
#
# Arguments:
#
#    w      widget pathname
#    exact  boolean; if true an exact match is desired
#
# Returns:
#
#    Empty string

proc ::combobox::Find {w {exact 0}} {
    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    ## *sigh* this logic is rather gross and convoluted. Surely
    ## there is a more simple, straight-forward way to implement
    ## all this. As the saying goes, I lack the time to make it
    ## shorter...

    # use what is already in the entry widget as a pattern
    set pattern [$widgets(entry) get]

    if {[string length $pattern] == 0} {
    # clear the current selection
    $widgets(listbox) see 0
    $widgets(listbox) selection clear 0 end
    $widgets(listbox) selection anchor 0
    $widgets(listbox) activate 0
    return
    }

    # we're going to be searching this list...
    set list [$widgets(listbox) get 0 end]

    # if we are doing an exact match, try to find,
    # well, an exact match
    set exactMatch -1
    if {$exact} {
    set exactMatch [lsearch -exact $list $pattern]
    }

    # search for it. We'll try to be clever and not only
    # search for a match for what they typed, but a match for
    # something close to what they typed. We'll keep removing one
    # character at a time from the pattern until we find a match
    # of some sort.
    set index -1
    while {$index == -1 && [string length $pattern]} {
    set index [lsearch -glob $list "$pattern*"]
    if {$index == -1} {
        regsub {.$} $pattern {} pattern
    }
    }

    # this is the item that most closely matches...
    set thisItem [lindex $list $index]

    # did we find a match? If so, do some additional munging...
    if {$index != -1} {

    # we need to find the part of the first item that is
    # unique WRT the second... I know there's probably a
    # simpler way to do this...

    set nextIndex [expr {$index + 1}]
    set nextItem [lindex $list $nextIndex]

    # we don't really need to do much if the next
    # item doesn't match our pattern...
    if {[string match $pattern* $nextItem]} {
        # ok, the next item matches our pattern, too
        # now the trick is to find the first character
        # where they *don't* match...
        set marker [string length $pattern]
        while {$marker <= [string length $pattern]} {
        set a [string index $thisItem $marker]
        set b [string index $nextItem $marker]
        if {[string compare $a $b] == 0} {
            append pattern $a
            incr marker
        } else {
            break
        }
        }
    } else {
        set marker [string length $pattern]
    }
    
    } else {
    set marker end
    set index 0
    }

    # ok, we know the pattern and what part is unique;
    # update the entry widget and listbox appropriately
    if {$exact && $exactMatch == -1} {
    # this means we didn't find an exact match
    $widgets(listbox) selection clear 0 end
    $widgets(listbox) see $index

    } elseif {!$exact}  {
    # this means we found something, but it isn't an exact
    # match. If we find something that *is* an exact match we
    # don't need to do the following, since it would merely
    # be replacing the data in the entry widget with itself
    set oldstate [$widgets(entry) cget -state]
    $widgets(entry) configure -state normal
    $widgets(entry) delete 0 end
    $widgets(entry) insert end $thisItem
    $widgets(entry) selection clear
    $widgets(entry) selection range $marker end
    $widgets(listbox) activate $index
    $widgets(listbox) selection clear 0 end
    $widgets(listbox) selection anchor $index
    $widgets(listbox) selection set $index
    $widgets(listbox) see $index
    $widgets(entry) configure -state $oldstate
    }
}

# ::combobox::Select --
#
#    selects an item from the list and sets the value of the combobox
#    to that value
#
# Arguments:
#
#    w      widget pathname
#    index  listbox index of item to be selected
#
# Returns:
#
#    empty string

proc ::combobox::Select {w index} {
    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    # the catch is because I'm sloppy -- presumably, the only time
    # an error will be caught is if there is no selection.
    if {![catch {set data [$widgets(listbox) get [lindex $index 0]]}]} {
    ::combobox::SetValue $widgets(this) $data

    $widgets(listbox) selection clear 0 end
    $widgets(listbox) selection anchor $index
    $widgets(listbox) selection set $index

    }
    $widgets(entry) selection range 0 end

    $widgets(this) close

    return ""
}

# ::combobox::HandleScrollbar --
#
#    causes the scrollbar of the dropdown list to appear or disappear
#    based on the contents of the dropdown listbox
#
# Arguments:
#
#    w       widget pathname
#    action  the action to perform on the scrollbar
#
# Returns:
#
#    an empty string

proc ::combobox::HandleScrollbar {w {action "unknown"}} {
    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    if {$options(-height) == 0} {
    set hlimit $options(-maxheight)
    } else {
    set hlimit $options(-height)
    }       

    switch $action {
    "grow" {
        if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} {
        pack $widgets(vsb) -side right -fill y -expand n
        }
    }

    "shrink" {
        if {$hlimit > 0 && [$widgets(listbox) size] <= $hlimit} {
        pack forget $widgets(vsb)
        }
    }

    "crop" {
        # this means the window was cropped and we definitely
        # need a scrollbar no matter what the user wants
        pack $widgets(vsb) -side right -fill y -expand n
    }

    default {
        if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} {
        pack $widgets(vsb) -side right -fill y -expand n
        } else {
        pack forget $widgets(vsb)
        }
    }
    }

    return ""
}

# ::combobox::ComputeGeometry --
#
#    computes the geometry of the dropdown list based on the size of the
#    combobox...
#
# Arguments:
#
#    w     widget pathname
#
# Returns:
#
#    the desired geometry of the listbox

proc ::combobox::ComputeGeometry {w} {
    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    if {$options(-height) == 0 && $options(-maxheight) != "0"} {
    # if this is the case, count the items and see if
    # it exceeds our maxheight. If so, set the listbox
    # size to maxheight...
    set nitems [$widgets(listbox) size]
    if {$nitems > $options(-maxheight)} {
        # tweak the height of the listbox
        $widgets(listbox) configure -height $options(-maxheight)
    } else {
        # un-tweak the height of the listbox
        $widgets(listbox) configure -height 0
    }
    update idletasks
    }

    # compute height and width of the dropdown list
    set bd [$widgets(dropdown) cget -borderwidth]
    set height [expr {[winfo reqheight $widgets(dropdown)] + $bd + $bd}]
    if {[string length $options(-dropdownwidth)] == 0 ||
        $options(-dropdownwidth) == 0} {
        set width [winfo width $widgets(this)]
    } else {
        set m [font measure [$widgets(listbox) cget -font] "m"]
        set width [expr {$options(-dropdownwidth) * $m}]
    }

    # figure out where to place it on the screen, trying to take into
    # account we may be running under some virtual window manager
    set screenWidth  [winfo screenwidth $widgets(this)]
    set screenHeight [winfo screenheight $widgets(this)]
    set rootx        [winfo rootx $widgets(this)]
    set rooty        [winfo rooty $widgets(this)]
    set vrootx       [winfo vrootx $widgets(this)]
    set vrooty       [winfo vrooty $widgets(this)]

    # the x coordinate is simply the rootx of our widget, adjusted for
    # the virtual window. We won't worry about whether the window will
    # be offscreen to the left or right -- we want the illusion that it
    # is part of the entry widget, so if part of the entry widget is off-
    # screen, so will the list. If you want to change the behavior,
    # simply change the if statement... (and be sure to update this
    # comment!)
    set x  [expr {$rootx + $vrootx}]
    if {0} {
    set rightEdge [expr {$x + $width}]
    if {$rightEdge > $screenWidth} {
        set x [expr {$screenWidth - $width}]
    }
    if {$x < 0} {set x 0}
    }

    # the y coordinate is the rooty plus vrooty offset plus
    # the height of the static part of the widget plus 1 for a
    # tiny bit of visual separation...
    set y [expr {$rooty + $vrooty + [winfo reqheight $widgets(this)] + 1}]
    set bottomEdge [expr {$y + $height}]

    if {$bottomEdge >= $screenHeight} {
    # ok. Fine. Pop it up above the entry widget isntead of
    # below.
    set y [expr {($rooty - $height - 1) + $vrooty}]

    if {$y < 0} {
        # this means it extends beyond our screen. How annoying.
        # Now we'll try to be real clever and either pop it up or
        # down, depending on which way gives us the biggest list.
        # then, we'll trim the list to fit and force the use of
        # a scrollbar

        # (sadly, for windows users this measurement doesn't
        # take into consideration the height of the taskbar,
        # but don't blame me -- there isn't any way to detect
        # it or figure out its dimensions. The same probably
        # applies to any window manager with some magic windows
        # glued to the top or bottom of the screen)

        if {$rooty > [expr {$screenHeight / 2}]} {
        # we are in the lower half of the screen --
        # pop it up. Y is zero; that parts easy. The height
        # is simply the y coordinate of our widget, minus
        # a pixel for some visual separation. The y coordinate
        # will be the topof the screen.
        set y 1
        set height [expr {$rooty - 1 - $y}]

        } else {
        # we are in the upper half of the screen --
        # pop it down
        set y [expr {$rooty + $vrooty +  [winfo reqheight $widgets(this)] + 1}]
        set height [expr {$screenHeight - $y}]

        }

        # force a scrollbar
        HandleScrollbar $widgets(this) crop
    }   
    }

    if {$y < 0} {
    # hmmm. Bummer.
    set y 0
    set height $screenheight
    }

    set geometry [format "=%dx%d+%d+%d" $width $height $x $y]

    return $geometry
}

# ::combobox::DoInternalWidgetCommand --
#
#    perform an internal widget command, then mung any error results
#    to look like it came from our megawidget. A lot of work just to
#    give the illusion that our megawidget is an atomic widget
#
# Arguments:
#
#    w           widget pathname
#    subwidget   pathname of the subwidget
#    command     subwidget command to be executed
#    args        arguments to the command
#
# Returns:
#
#    The result of the subwidget command, or an error

proc ::combobox::DoInternalWidgetCommand {w subwidget command args} {
    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    set subcommand $command
    set command [concat $widgets($subwidget) $command $args]
    if {[catch $command result]} {
    # replace the subwidget name with the megawidget name
    regsub $widgets($subwidget) $result $widgets(this) result

    # replace specific instances of the subwidget command
    # with out megawidget command
    switch $subwidget,$subcommand {
        listbox,index  {regsub "index"  $result "list index"  result}
        listbox,insert {regsub "insert" $result "list insert" result}
        listbox,delete {regsub "delete" $result "list delete" result}
        listbox,get    {regsub "get"    $result "list get"    result}
        listbox,size   {regsub "size"   $result "list size"   result}
    }
    error $result

    } else {
    return $result
    }
}


# ::combobox::WidgetProc --
#
#    This gets uses as the widgetproc for an combobox widget.
#    Notice where the widget is created and you'll see that the
#    actual widget proc merely evals this proc with all of the
#    arguments intact.
#
#    Note that some widget commands are defined "inline" (ie:
#    within this proc), and some do most of their work in
#    separate procs. This is merely because sometimes it was
#    easier to do it one way or the other.
#
# Arguments:
#
#    w         widget pathname
#    command   widget subcommand
#    args      additional arguments; varies with the subcommand
#
# Results:
#
#    Performs the requested widget command

proc ::combobox::WidgetProc {w command args} {
    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options
    upvar ::combobox::${w}::oldFocus oldFocus
    upvar ::combobox::${w}::oldFocus oldGrab

    set command [::combobox::Canonize $w command $command]

    # this is just shorthand notation...
    set doWidgetCommand  [list ::combobox::DoInternalWidgetCommand $widgets(this)]

    if {$command == "list"} {
    # ok, the next argument is a list command; we'll
    # rip it from args and append it to command to
    # create a unique internal command
    #
    # NB: because of the sloppy way we are doing this,
    # we'll also let the user enter our secret command
    # directly (eg: listinsert, listdelete), but we
    # won't document that fact
    set command "list-[lindex $args 0]"
    set args [lrange $args 1 end]
    }

    set result ""

    # many of these commands are just synonyms for specific
    # commands in one of the subwidgets. We'll get them out
    # of the way first, then do the custom commands.
    switch $command {
    bbox -
    delete -
    get -
    icursor -
    index -
    insert -
    scan -
    selection -
    xview {
        set result [eval $doWidgetCommand entry $command $args]
    }
    list-get    {set result [eval $doWidgetCommand listbox get $args]}
    list-index  {set result [eval $doWidgetCommand listbox index $args]}
    list-size   {set result [eval $doWidgetCommand listbox size $args]}

    select {
        if {[llength $args] == 1} {
        set index [lindex $args 0]
        set result [Select $widgets(this) $index]
        } else {
        error "usage: $w select index"
        }
    }

    subwidget {
        set knownWidgets [list button entry listbox dropdown vsb]
        if {[llength $args] == 0} {
        return $knownWidgets
        }

        set name [lindex $args 0]
        if {[lsearch $knownWidgets $name] != -1} {
        set result $widgets($name)
        } else {
        error "unknown subwidget $name"
        }
    }

    curselection {
        set result [eval $doWidgetCommand listbox curselection]
    }

    list-insert {
        eval $doWidgetCommand listbox insert $args
        set result [HandleScrollbar $w "grow"]
    }

    list-delete {
        eval $doWidgetCommand listbox delete $args
        set result [HandleScrollbar $w "shrink"]
    }

    toggle {
        # ignore this command if the widget is disabled...
        if {$options(-state) == "disabled"} return

        # pops down the list if it is not, hides it
        # if it is...
        if {[winfo ismapped $widgets(dropdown)]} {
        set result [$widgets(this) close]
        } else {
        set result [$widgets(this) open]
        }
    }

    open {

        # if this is an editable combobox, the focus should
        # be set to the entry widget
        if {$options(-editable)} {
        focus $widgets(entry)
        $widgets(entry) select range 0 end
        $widgets(entry) icur end
        }

        # if we are disabled, we won't allow this to happen
        if {$options(-state) == "disabled"} {
        return 0
        }

        # if there is a -opencommand, execute it now
        if {[string length $options(-opencommand)] > 0} {
        # hmmm... should I do a catch, or just let the normal
        # error handling handle any errors? For now, the latter...
        uplevel \#0 $options(-opencommand)
        }

        # compute the geometry of the window to pop up, and set
        # it, and force the window manager to take notice
        # (even if it is not presently visible).
        #
        # this isn't strictly necessary if the window is already
        # mapped, but we'll go ahead and set the geometry here
        # since its harmless and *may* actually reset the geometry
        # to something better in some weird case.
        set geometry [::combobox::ComputeGeometry $widgets(this)]
        wm geometry $widgets(dropdown) $geometry
        update idletasks

        # if we are already open, there's nothing else to do
        if {[winfo ismapped $widgets(dropdown)]} {
        return 0
        }

        # save the widget that currently has the focus; we'll restore
        # the focus there when we're done
        set oldFocus [focus]

        # ok, tweak the visual appearance of things and
        # make the list pop up
        $widgets(button) configure -relief sunken
        raise $widgets(dropdown) [winfo parent $widgets(this)]
        wm deiconify $widgets(dropdown)
        raise $widgets(dropdown)

        # force focus to the entry widget so we can handle keypress
        # events for traversal
        focus -force $widgets(entry)

        # select something by default, but only if its an
        # exact match...
        ::combobox::Find $widgets(this) 1

        # save the current grab state for the display containing
        # this widget. We'll restore it when we close the dropdown
        # list
        set status "none"
        set grab [grab current $widgets(this)]
        if {$grab != ""} {set status [grab status $grab]}
        set oldGrab [list $grab $status]
        unset grab status

        # *gasp* do a global grab!!! Mom always told me not to
        # do things like this, but sometimes a man's gotta do
        # what a man's gotta do.
        grab -global $widgets(this)

        # fake the listbox into thinking it has focus. This is
        # necessary to get scanning initialized properly in the
        # listbox.
        event generate $widgets(listbox) <B1-Enter>

        return 1
    }

    close {
        # if we are already closed, don't do anything...
        if {![winfo ismapped $widgets(dropdown)]} {
        return 0
        }

        # restore the focus and grab, but ignore any errors...
        # we're going to be paranoid and release the grab before
        # trying to set any other grab because we really really
        # really want to make sure the grab is released.
        catch {focus $oldFocus} result
        catch {grab release $widgets(this)}
        catch {
        set status [lindex $oldGrab 1]
        if {$status == "global"} {
            grab -global [lindex $oldGrab 0]
        } elseif {$status == "local"} {
            grab [lindex $oldGrab 0]
        }
        unset status
        }

        # hides the listbox
        $widgets(button) configure -relief raised
        wm withdraw $widgets(dropdown)

        # select the data in the entry widget. Not sure
        # why, other than observation seems to suggest that's
        # what windows widgets do.
        set editable [::combobox::GetBoolean $options(-editable)]
        if {$editable} {
        $widgets(entry) selection range 0 end
        $widgets(button) configure -relief raised
        }


        # magic tcl stuff (see tk.tcl in the distribution
        # lib directory)
        ::combobox::tkCancelRepeat

        return 1
    }

    cget {
        if {[llength $args] != 1} {
        error "wrong # args: should be $w cget option"
        }
        set opt [::combobox::Canonize $w option [lindex $args 0]]

        if {$opt == "-value"} {
        set result [$widgets(entry) get]
        } else {
        set result $options($opt)
        }
    }

    configure {
        set result [eval ::combobox::Configure {$w} $args]
    }

    default {
        error "bad option \"$command\""
    }
    }

    return $result
}

# ::combobox::Configure --
#
#    Implements the "configure" widget subcommand
#
# Arguments:
#
#    w      widget pathname
#    args   zero or more option/value pairs (or a single option)
#
# Results:
#
#    Performs typcial "configure" type requests on the widget

proc ::combobox::Configure {w args} {
    variable widgetOptions
    variable defaultEntryCursor

    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    if {[llength $args] == 0} {
    # hmmm. User must be wanting all configuration information
    # note that if the value of an array element is of length
    # one it is an alias, which needs to be handled slightly
    # differently
    set results {}
    foreach opt [lsort [array names widgetOptions]] {
        if {[llength $widgetOptions($opt)] == 1} {
        set alias $widgetOptions($opt)
        set optName $widgetOptions($alias)
        lappend results [list $opt $optName]
        } else {
        set optName  [lindex $widgetOptions($opt) 0]
        set optClass [lindex $widgetOptions($opt) 1]
        set default [option get $w $optName $optClass]
        if {[info exists options($opt)]} {
            lappend results [list $opt $optName $optClass  $default $options($opt)]
        } else {
            lappend results [list $opt $optName $optClass  $default ""]
        }
        }
    }

    return $results
    }

    # one argument means we are looking for configuration
    # information on a single option
    if {[llength $args] == 1} {
    set opt [::combobox::Canonize $w option [lindex $args 0]]

    set optName  [lindex $widgetOptions($opt) 0]
    set optClass [lindex $widgetOptions($opt) 1]
    set default [option get $w $optName $optClass]
    set results [list $opt $optName $optClass  $default $options($opt)]
    return $results
    }

    # if we have an odd number of values, bail.
    if {[expr {[llength $args]%2}] == 1} {
    # hmmm. An odd number of elements in args
    error "value for \"[lindex $args end]\" missing"
    }

    # Great. An even number of options. Let's make sure they
    # are all valid before we do anything. Note that Canonize
    # will generate an error if it finds a bogus option; otherwise
    # it returns the canonical option name
    foreach {name value} $args {
    set name [::combobox::Canonize $w option $name]
    set opts($name) $value
    }

    # process all of the configuration options
    # some (actually, most) options require us to
    # do something, like change the attributes of
    # a widget or two. Here's where we do that...
    #
    # note that the handling of disabledforeground and
    # disabledbackground is a little wonky. First, we have
    # to deal with backwards compatibility (ie: tk 8.3 and below
    # didn't have such options for the entry widget), and
    # we have to deal with the fact we might want to disable
    # the entry widget but use the normal foreground/background
    # for when the combobox is not disabled, but not editable either.

    set updateVisual 0
    foreach option [array names opts] {
    set newValue $opts($option)
    if {[info exists options($option)]} {
        set oldValue $options($option)
    }

    switch -- $option {
        -background {
        set updateVisual 1
        set options($option) $newValue
        }

        -borderwidth {
        $widgets(frame) configure -borderwidth $newValue
        set options($option) $newValue
        }

        -command {
        # nothing else to do...
        set options($option) $newValue
        }

        -commandstate {
        # do some value checking...
        if {$newValue != "normal" && $newValue != "disabled"} {
            set options($option) $oldValue
            set message "bad state value \"$newValue\";"
            append message " must be normal or disabled"
            error $message
        }
        set options($option) $newValue
        }

        -cursor {
        $widgets(frame) configure -cursor $newValue
        $widgets(entry) configure -cursor $newValue
        $widgets(listbox) configure -cursor $newValue
        set options($option) $newValue
        }

        -disabledforeground {
        set updateVisual 1
        set options($option) $newValue
        }

        -disabledbackground {
        set updateVisual 1
        set options($option) $newValue
        }

            -dropdownwidth {
                set options($option) $newValue
            }

        -editable {
        set updateVisual 1
        if {$newValue} {
            # it's editable...
            $widgets(entry) configure  -state normal  -cursor $defaultEntryCursor
        } else {
            $widgets(entry) configure  -state disabled  -cursor $options(-cursor)
        }
        set options($option) $newValue
        }

        -font {
        $widgets(entry) configure -font $newValue
        $widgets(listbox) configure -font $newValue
        set options($option) $newValue
        }

        -foreground {
        set updateVisual 1
        set options($option) $newValue
        }

        -height {
        $widgets(listbox) configure -height $newValue
        HandleScrollbar $w
        set options($option) $newValue
        }

        -highlightbackground {
        $widgets(frame) configure -highlightbackground $newValue
        set options($option) $newValue
        }

        -highlightcolor {
        $widgets(frame) configure -highlightcolor $newValue
        set options($option) $newValue
        }

        -highlightthickness {
        $widgets(frame) configure -highlightthickness $newValue
        set options($option) $newValue
        }
    
        -image {
        if {[string length $newValue] > 0} {
            $widgets(button) configure -image $newValue
        } else {
            $widgets(button) configure -image ::combobox::bimage
        }
        set options($option) $newValue
        }

        -maxheight {
        # ComputeGeometry may dork with the actual height
        # of the listbox, so let's undork it
        $widgets(listbox) configure -height $options(-height)
        HandleScrollbar $w
        set options($option) $newValue
        }

        -opencommand {
        # nothing else to do...
        set options($option) $newValue
        }

        -relief {
        $widgets(frame) configure -relief $newValue
        set options($option) $newValue
        }

        -selectbackground {
        $widgets(entry) configure -selectbackground $newValue
        $widgets(listbox) configure -selectbackground $newValue
        set options($option) $newValue
        }

        -selectborderwidth {
        $widgets(entry) configure -selectborderwidth $newValue
        $widgets(listbox) configure -selectborderwidth $newValue
        set options($option) $newValue
        }

        -selectforeground {
        $widgets(entry) configure -selectforeground $newValue
        $widgets(listbox) configure -selectforeground $newValue
        set options($option) $newValue
        }

        -state {
        if {$newValue == "normal"} {
            set updateVisual 1
            # it's enabled

            set editable [::combobox::GetBoolean  $options(-editable)]
            if {$editable} {
            $widgets(entry) configure -state normal
            $widgets(entry) configure -takefocus 1
            }

                    # note that $widgets(button) is actually a label,
                    # not a button. And being able to disable labels
                    # wasn't possible until tk 8.3. (makes me wonder
            # why I chose to use a label, but that answer is
            # lost to antiquity)
                    if {[info patchlevel] >= 8.3} {
                        $widgets(button) configure -state normal
                    }

        } elseif {$newValue == "disabled"}  {
            set updateVisual 1
            # it's disabled
            $widgets(entry) configure -state disabled
            $widgets(entry) configure -takefocus 0
                    # note that $widgets(button) is actually a label,
                    # not a button. And being able to disable labels
                    # wasn't possible until tk 8.3. (makes me wonder
            # why I chose to use a label, but that answer is
            # lost to antiquity)
                    if {$::tcl_version >= 8.3} {
                        $widgets(button) configure -state disabled
                    }

        } else {
            set options($option) $oldValue
            set message "bad state value \"$newValue\";"
            append message " must be normal or disabled"
            error $message
        }

        set options($option) $newValue
        }

        -takefocus {
        $widgets(entry) configure -takefocus $newValue
        set options($option) $newValue
        }

        -textvariable {
        $widgets(entry) configure -textvariable $newValue
        set options($option) $newValue
        }

        -value {
        ::combobox::SetValue $widgets(this) $newValue
        set options($option) $newValue
        }

        -width {
        $widgets(entry) configure -width $newValue
        $widgets(listbox) configure -width $newValue
        set options($option) $newValue
        }

        -xscrollcommand {
        $widgets(entry) configure -xscrollcommand $newValue
        set options($option) $newValue
        }
    }   

    if {$updateVisual} {UpdateVisualAttributes $w}
    }
}

# ::combobox::UpdateVisualAttributes --
#
# sets the visual attributes (foreground, background mostly)
# based on the current state of the widget (normal/disabled,
# editable/non-editable)
#
# why a proc for such a simple thing? Well, in addition to the
# various states of the widget, we also have to consider the
# version of tk being used -- versions from 8.4 and beyond have
# the notion of disabled foreground/background options for various
# widgets. All of the permutations can get nasty, so we encapsulate
# it all in one spot.
#
# note also that we don't handle all visual attributes here; just
# the ones that depend on the state of the widget. The rest are
# handled on a case by case basis
#
# Arguments:
#    w      widget pathname
#
# Returns:
#    empty string

proc ::combobox::UpdateVisualAttributes {w} {

    upvar ::combobox::${w}::widgets     widgets
    upvar ::combobox::${w}::options     options

    if {$options(-state) == "normal"} {

    set foreground $options(-foreground)
    set background $options(-background)
    
    } elseif {$options(-state) == "disabled"} {

    set foreground $options(-disabledforeground)
    set background $options(-disabledbackground)
    }

    $widgets(entry)   configure -foreground $foreground -background $background
    $widgets(listbox) configure -foreground $foreground -background $background
    $widgets(button)  configure -foreground $foreground
    $widgets(vsb)     configure -background $background -troughcolor $background
    $widgets(frame)   configure -background $background

    # we need to set the disabled colors in case our widget is disabled.
    # We could actually check for disabled-ness, but we also need to
    # check whether we're enabled but not editable, in which case the
    # entry widget is disabled but we still want the enabled colors. It's
    # easier just to set everything and be done with it.

    if {$::tcl_version >= 8.4} {
    $widgets(entry) configure  -disabledforeground $foreground  -disabledbackground $background
    $widgets(button)  configure -disabledforeground $foreground
    $widgets(listbox) configure -disabledforeground $foreground
    }
}

# ::combobox::SetValue --
#
#    sets the value of the combobox and calls the -command,
#    if defined
#
# Arguments:
#
#    w          widget pathname
#    newValue   the new value of the combobox
#
# Returns
#
#    Empty string

proc ::combobox::SetValue {w newValue} {

    upvar ::combobox::${w}::widgets     widgets
    upvar ::combobox::${w}::options     options
    upvar ::combobox::${w}::ignoreTrace ignoreTrace
    upvar ::combobox::${w}::oldValue    oldValue

    if {[info exists options(-textvariable)]  && [string length $options(-textvariable)] > 0} {
    set variable ::$options(-textvariable)
    set $variable $newValue
    } else {
    set oldstate [$widgets(entry) cget -state]
    $widgets(entry) configure -state normal
    $widgets(entry) delete 0 end
    $widgets(entry) insert 0 $newValue
    $widgets(entry) configure -state $oldstate
    }

    # set our internal textvariable; this will cause any public
    # textvariable (ie: defined by the user) to be updated as
    # well
#    set ::combobox::${w}::entryTextVariable $newValue

    # redefine our concept of the "old value". Do it before running
    # any associated command so we can be sure it happens even
    # if the command somehow fails.
    set oldValue $newValue


    # call the associated command. The proc will handle whether or
    # not to actually call it, and with what args
    CallCommand $w $newValue

    return ""
}

# ::combobox::CallCommand --
#
#   calls the associated command, if any, appending the new
#   value to the command to be called.
#
# Arguments:
#
#    w         widget pathname
#    newValue  the new value of the combobox
#
# Returns
#
#    empty string

proc ::combobox::CallCommand {w newValue} {
    upvar ::combobox::${w}::widgets widgets
    upvar ::combobox::${w}::options options

    # call the associated command, if defined and -commandstate is
    # set to "normal"
    if {$options(-commandstate) == "normal" &&  [string length $options(-command)] > 0} {
    set args [list $widgets(this) $newValue]
    uplevel \#0 $options(-command) $args
    }
}


# ::combobox::GetBoolean --
#
#     returns the value of a (presumably) boolean string (ie: it should
#     do the right thing if the string is "yes", "no", "true", 1, etc
#
# Arguments:
#
#     value       value to be converted
#     errorValue  a default value to be returned in case of an error
#
# Returns:
#
#     a 1 or zero, or the value of errorValue if the string isn't
#     a proper boolean value

proc ::combobox::GetBoolean {value {errorValue 1}} {
    if {[catch {expr {([string trim $value])?1:0}} res]} {
    return $errorValue
    } else {
    return $res
    }
}

# ::combobox::convert --
#
#     public routine to convert %x, %y and %W binding substitutions.
#     Given an x, y and or %W value relative to a given widget, this
#     routine will convert the values to be relative to the combobox
#     widget. For example, it could be used in a binding like this:
#
#     bind .combobox <blah> {doSomething [::combobox::convert %W -x %x]}
#
#     Note that this procedure is *not* exported, but is intended for
#     public use. It is not exported because the name could easily
#     clash with existing commands.
#
# Arguments:
#
#     w     a widget path; typically the actual result of a %W
#           substitution in a binding. It should be either a
#           combobox widget or one of its subwidgets
#
#     args  should one or more of the following arguments or
#           pairs of arguments:
#
#           -x <x>      will convert the value <x>; typically <x> will
#                       be the result of a %x substitution
#           -y <y>      will convert the value <y>; typically <y> will
#                       be the result of a %y substitution
#           -W (or -w)  will return the name of the combobox widget
#                       which is the parent of $w
#
# Returns:
#
#     a list of the requested values. For example, a single -w will
#     result in a list of one items, the name of the combobox widget.
#     Supplying "-x 10 -y 20 -W" (in any order) will return a list of
#     three values: the converted x and y values, and the name of
#     the combobox widget.

proc ::combobox::convert {w args} {
    set result {}
    if {![winfo exists $w]} {
    error "window \"$w\" doesn't exist"
    }

    while {[llength $args] > 0} {
    set option [lindex $args 0]
    set args [lrange $args 1 end]

    switch -exact -- $option {
        -x {
        set value [lindex $args 0]
        set args [lrange $args 1 end]
        set win $w
        while {[winfo class $win] != "Combobox"} {
            incr value [winfo x $win]
            set win [winfo parent $win]
            if {$win == "."} break
        }
        lappend result $value
        }

        -y {
        set value [lindex $args 0]
        set args [lrange $args 1 end]
        set win $w
        while {[winfo class $win] != "Combobox"} {
            incr value [winfo y $win]
            set win [winfo parent $win]
            if {$win == "."} break
        }
        lappend result $value
        }

        -w -
        -W {
        set win $w
        while {[winfo class $win] != "Combobox"} {
            set win [winfo parent $win]
            if {$win == "."} break;
        }
        lappend result $win
        }
    }
    }
    return $result
}

# ::combobox::Canonize --
#
#    takes a (possibly abbreviated) option or command name and either
#    returns the canonical name or an error
#
# Arguments:
#
#    w        widget pathname
#    object   type of object to canonize; must be one of "command",
#             "option", "scan command" or "list command"
#    opt      the option (or command) to be canonized
#
# Returns:
#
#    Returns either the canonical form of an option or command,
#    or raises an error if the option or command is unknown or
#    ambiguous.

proc ::combobox::Canonize {w object opt} {
    variable widgetOptions
    variable columnOptions
    variable widgetCommands
    variable listCommands
    variable scanCommands

    switch $object {
    command {
        if {[lsearch -exact $widgetCommands $opt] >= 0} {
        return $opt
        }

        # command names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the commands in a temporary array so
        # we can use [array names]
        set list $widgetCommands
        foreach element $list {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }

    {list command} {
        if {[lsearch -exact $listCommands $opt] >= 0} {
        return $opt
        }

        # command names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the commands in a temporary array so
        # we can use [array names]
        set list $listCommands
        foreach element $list {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }

    {scan command} {
        if {[lsearch -exact $scanCommands $opt] >= 0} {
        return $opt
        }

        # command names aren't stored in an array, and there
        # isn't a way to get all the matches in a list, so
        # we'll stuff the commands in a temporary array so
        # we can use [array names]
        set list $scanCommands
        foreach element $list {
        set tmp($element) ""
        }
        set matches [array names tmp ${opt}*]
    }

    option {
        if {[info exists widgetOptions($opt)]  && [llength $widgetOptions($opt)] == 2} {
        return $opt
        }
        set list [array names widgetOptions]
        set matches [array names widgetOptions ${opt}*]
    }

    }

    if {[llength $matches] == 0} {
    set choices [HumanizeList $list]
    error "unknown $object \"$opt\"; must be one of $choices"

    } elseif {[llength $matches] == 1} {
    set opt [lindex $matches 0]

    # deal with option aliases
    switch $object {
        option {
        set opt [lindex $matches 0]
        if {[llength $widgetOptions($opt)] == 1} {
            set opt $widgetOptions($opt)
        }
        }
    }

    return $opt

    } else {
    set choices [HumanizeList $list]
    error "ambiguous $object \"$opt\"; must be one of $choices"
    }
}

# ::combobox::HumanizeList --
#
#    Returns a human-readable form of a list by separating items
#    by columns, but separating the last two elements with "or"
#    (eg: foo, bar or baz)
#
# Arguments:
#
#    list    a valid tcl list
#
# Results:
#
#    A string which as all of the elements joined with ", " or
#    the word " or "

proc ::combobox::HumanizeList {list} {

    if {[llength $list] == 1} {
    return [lindex $list 0]
    } else {
    set list [lsort $list]
    set secondToLast [expr {[llength $list] -2}]
    set most [lrange $list 0 $secondToLast]
    set last [lindex $list end]

    return "[join $most {, }] or $last"
    }
}

# This is some backwards-compatibility code to handle TIP 44
# (http://purl.org/tcl/tip/44.html). For all private tk commands
# used by this widget, we'll make duplicates of the procs in the
# combobox namespace.
#
# I'm not entirely convinced this is the right thing to do. I probably
# shouldn't even be using the private commands. Then again, maybe the
# private commands really should be public. Oh well; it works so it
# must be OK...
foreach command {TabToWindow CancelRepeat ListboxUpDown} {
    if {[llength [info commands ::combobox::tk$command]] == 1} break;

    set tmp [info commands tk$command]
    set proc ::combobox::tk$command
    if {[llength [info commands tk$command]] == 1} {
        set command [namespace which [lindex $tmp 0]]
        proc $proc {args} "uplevel $command \$args"
    } else {
        if {[llength [info commands ::tk::$command]] == 1} {
            proc $proc {args} "uplevel ::tk::$command \$args"
        }
    }
}

# end of combobox.tcl
}

ret  {combobox_lim} (type window , optional loclist ={) {cmdproc {}} {cb_textvar c_var} {cb_width 15} {cb_opt 0} {lim 1} args} {
/* ****combobox_lim*/
/* */
/* */
/* */
/* ***/
/*    window : nom du combobox*/
/*    procedure : procedure pour creer la liste de choix*/
/*    cmdproc : commande executee a chaque nouveau choix (passe aussi le nom du combo)*/
/*    cb_textvar : nom de la variable*/
/*    cb_width taille en char du combo*/
/*    cb_opt : valeur par defaut*/
/*    lim : 1 saisie limitée (par defaut) -1 sinon*/
/*    args : arguments de la procedure cmdproc*/

catch {namespace import combobox::*}
     edita =  1
    if {$lim == 1} { edita =  0}
    global $cb_textvar
     $cb = _textvar $cb_opt
    combobox $window -command $cmdret  -editable $edita -textvariable $cb_textvar -width $cb_width -background white
    # eval $window list insert end $loclist
    foreach elem $loclist (
        $type window , type list , type insert , type end $, type elem
    )
    # Sélectionne la valeur initiale dans la liste
    set indice [lsearch $loclist $cb_opt]
    if {$indice != -1} { $window select $indice }
}

ret  {comm_add} (type win , type i_, type source , type i_, type target , type exch_, type per_, type unit , type exch_, type per_, type val , type lag , type src_, type time_, type op , type src_, type add_, type val , type src_, type mult_, type val , type dbg_, type source , type stat_, type source_, type mask , type stat_, type source_, type nmsk , type stat_, type source_, type all , type remail , type tgt_, type time_, type op , type tgt_, type add_, type val , type tgt_, type mult_, type val , type dbg_, type cible , type stat_, type cible_, type mask , type stat_, type cible_, type nmsk , type stat_, type cible_, type all , type file_, type packing , type file_, type scaling , type file_, type adding , type file_, type fill_, type value) {
#****  comm_add - add a new connexion

    # Variables globales
    global dico_applis dico_caract_fichiers
    global dico_caract_cnx
    global dico_caract_points
    global liste_cnx_in dico_cnx_out

    # Var. de saisie des options de remaillage
    global nbr_neighbours_m bi3_method_m if_masked_m norm_method_m norm_near_nei_m
    # Var globale indiquant que l'utilisateur a validé sa saisie des options de remaillage
    global valid_remail

    # Vérifie les informations entrées
    if { [comm_validation $exch_per_unit $exch_per_val $remail] } {
        return error
    }

    # Extrait les infos pertinentes
    # -----------------------------

    # Nom de l'application du composant source
    set appli_source $dico_caract_points($i_source.appli)
    # Nom du composant source
    set comp_source $dico_caract_points($i_source.comp)
    # Nom du champ source
    set champ_source $dico_caract_points($i_source.champ)

    # Nom de l'application du composant cible
    set appli_cible $dico_caract_points($i_target.appli)
    # Nom du composant cible
    set comp_cible $dico_caract_points($i_target.comp)
    # Nom du champ cible
    set champ_cible $dico_caract_points($i_target.champ)

    # Mémorise la nouvelle connexion
    # ------------------------------

    # 1) Au niveau des points de couplage
    # -----------------------------------

    # 1.a) Point de couplage cible
    # Mémorise que le point cible est connecté
    set dico_caract_points($i_target.lcnx) "i"

    # 1.b) Point de couplage source
    # Le point source peut avoir plusieurs connexions
    # Liste des connexions sortantes déjà existantes
    set l_cnx_out ""
    if { [info exists dico_caract_points($i_source.lcnx)] } {
        set l_cnx_out $dico_caract_points($i_source.lcnx)
    }

    # Crée un nouvel id pour cette nouvelle connexion sortante
    # Il est formé de la lettre "o" suivie d'un numéro
    # On prend le dernier numéro utilisé plus 1
    set dernier_id [lindex $l_cnx_out end]
    if { $dernier_id != "" } {
        set num_dernier_id [string range $dernier_id 1 end]
    } else {
        set num_dernier_id 0
    }
    incr num_dernier_id
    set id_new_cnx_out "o$num_dernier_id"

    # Met à jour la liste des identifiants de connexion pour le point source
    lappend dico_caract_points($i_source.lcnx) $id_new_cnx_out

    # 2) Dans les listes des connexions
    # ---------------------------------

    # Clef (index) de la connexion sortante
    set clef_new_cnx_out $i_source$num_dernier_id

    # 2.a) la liste des connexions entrantes
    lappend liste_cnx_in $i_target

    # 2.b) le dico des connexions sortantes
    set dico_cnx_out($clef_new_cnx_out) $i_target

    # 2.c) la liste des connexions avec leurs caractéristiques
    set dico_caract_cnx($i_target.app_source)  $appli_source
    set dico_caract_cnx($i_target.app_cible)   $appli_cible
    set dico_caract_cnx($i_target.comp_source) $comp_source
    set dico_caract_cnx($i_target.comp_cible)  $comp_cible
    set dico_caract_cnx($i_target.champ_source) $champ_source
    set dico_caract_cnx($i_target.champ_cible)  $champ_cible
    set dico_caract_cnx($i_target.pt_source) $id_new_cnx_out

    # Enlever le 's' de pluriel aux unités de temps de la période des échanges
    set exch_per_unit [string range $exch_per_unit 0 end-1]

    # Réinterprète le champ "type de remaillage"
    # ------------------------------------------

    # Liste de descriptions lisibles et de mots-clefs correspondants
    array set remaillages { None {} {3D Nearest neighbour} nneighbour3D {3D Trilinear} trilinear {2D Nearest neighbour} nneighbour2D
        {2D Bilinear} bilinear {2D Bicubic} bicubic {2D Conservativ} conservativ2D }

    # Transforme le mot-clef en description lisible
    if { $remail != "" } { set remail $remaillages($remail) }

    # Réinterprète le champ "source time operation"
    array set mots_clefs { None {} {Time average} taverage {Time accumulation} accumul }
    if { $src_time_op != "" } { set src_time_op $mots_clefs($src_time_op) }

    # Réinterprète le champ "target time operation"
    array unset mots_clefs
    array set mots_clefs { {None (Closest time)} {} {Time interpolation} time_linear }
    if { $tgt_time_op != "" } { set tgt_time_op $mots_clefs($tgt_time_op) }

    # Réinterprète les booléens
    # Pour tous les champs booléens
    foreach nom_champ { dbg_source dbg_cible } {
        set valeur [set $nom_champ]
        if { $valeur != "" } {       
            if {$valeur == "yes"} {set $nom_champ true} else {set $nom_champ false}
        }
    }

    # Enregistre les attributs de la connexion
    # ----------------------------------------

    # Initialise avec valeurs par defaut
    set dico_caract_cnx($i_target.src_time_op) ""
    set dico_caract_cnx($i_target.src_add_val)  0
    set dico_caract_cnx($i_target.src_mult_val) 1
    set dico_caract_cnx($i_target.tgt_time_op) ""
    set dico_caract_cnx($i_target.tgt_add_val) 0
    set dico_caract_cnx($i_target.tgt_mult_val) 1
    set dico_caract_cnx($i_target.remail) ""

    foreach attrib {exch_per_unit exch_per_val lag dbg_source dbg_cible src_time_op src_add_val src_mult_val
                    remail tgt_time_op tgt_add_val tgt_mult_val
                    stat_source_mask stat_source_nmsk stat_source_all stat_cible_mask stat_cible_nmsk stat_cible_all} {
        set value [set $attrib]
        if { $value != "" } { set dico_caract_cnx($i_target.$attrib) $value }
    }

    # Enregistre les options de remaillage
    global options_remail
    if { $remail != "" } {
        # Réinterprète l'option booléenne norm_near_nei
        if {$options_remail(norm_near_nei) == "yes"} {set options_remail(norm_near_nei) true} else {set options_remail(norm_near_nei) false}
        # Traduit l'option de remaillage conservatif
        switch $options_remail(norm_method) {
            "Fractional area"  { set options_remail(norm_method) fracarea }
            "Destination area" { set options_remail(norm_method) destarea }
        }
        foreach option {nbr_neighbours bi3_method if_masked norm_method norm_near_nei} {
            set dico_caract_cnx($i_target.$option) $options_remail($option)
        }
    }
    array unset options_remail

    # Si la cible est un fichier NetCDF
    if { [string equal $appli_cible "///file///"] } {
        # Enregistre les attributs du champ du fichier NetCDF
        set dico_caract_fichiers($comp_cible.field.packing) $file_packing 
        set dico_caract_fichiers($comp_cible.field.scaling) $file_scaling 
        set dico_caract_fichiers($comp_cible.field.adding)  $file_adding 
        set dico_caract_fichiers($comp_cible.field.fill_value) $file_fill_value
        
        # Maintenant qu'il est connecté, le champ du fichier a un type numérique connu
        set dico_caract_fichiers($comp_cible.field.type) $dico_applis(app.$appli_source.comp.$comp_source.champ.$champ_source.datatype)
    }    

    catch {destroy $win}
}

ret  {comm_delete} (type clef_, type cnx) {
#** suppression d'une  communication
#
    global dico_caract_cnx

    set appli_source $dico_caract_cnx($clef_cnx.app_source)
    set appli_cible $dico_caract_cnx($clef_cnx.app_cible)
    set comp_source $dico_caract_cnx($clef_cnx.comp_source)
    set comp_cible  $dico_caract_cnx($clef_cnx.comp_cible)
    
    # Remove from memory
    comm_remove $clef_cnx
    
    # Redessine les composants source et cible
    catch {Draw_one_unit $appli_source.$comp_source}
    catch {Draw_one_unit $appli_cible.$comp_cible}

    # Redessine les connexions des composants source et cible
    Draw_comm $appli_source.$comp_source
    Draw_comm $appli_cible.$comp_cible

    # Affiche la liste des communications
    control_entity CONNECTION
}

ret  {comm_edit} (type clef_, type cnx) {
#** edition d'une  communications
#
    global dico_caract_cnx dico_applis
    global viewcommcheck

    # Extrait les infos pertinentes
    # -----------------------------

    # Crée une variable pour chaque champ
    foreach nom_champ { lag src_time_op src_add_val src_mult_val dbg_source stat_source_mask stat_source_nmsk stat_source_all remail tgt_time_op tgt_add_val tgt_mult_val dbg_cible stat_cible_mask stat_cible_nmsk stat_cible_all } {
        set $nom_champ ""
    }
    
    # Extrait tous les champs attributs de la connexion
    foreach {name value} [array get dico_caract_cnx $clef_cnx.*] {
        set nom_attribut [string range $name [string length $clef_cnx.] end]
        # Crée une variable pour chaque attribut
        set $nom_attribut $value
    }

    # Clef d'accès au champ de couplage source
    set clef_champ_source app.$app_source.comp.$comp_source.champ.$champ_source.o
    # Minimal period
    set period_source [array get dico_applis $clef_champ_source.nbr_*]
    set unite_period_source [string range  [lindex $period_source 0] [string length $clef_champ_source.nbr_] end]
    set qte_period_source [lindex $period_source 1]
    set scatter ""
    catch {set scatter $dico_applis($clef_champ_source.scatter)}
    # CF name (transient standard name) du champ de couplage source
    set std_name_source ""
    catch {set std_name_source $dico_applis(app.$app_source.comp.$comp_source.champ.$champ_source.std_name)}

    # Clef d'accès au champ de couplage cible
    set clef_champ_cible app.$app_cible.comp.$comp_cible.champ.$champ_cible.i
    # Minimal period
    set period_cible [array get dico_applis $clef_champ_cible.nbr_*]
    set unite_period_cible [string range  [lindex $period_cible 0] [string length $clef_champ_cible.nbr_] end]
    set qte_period_cible [lindex $period_cible 1]
    set gather ""
    catch {set gather $dico_applis($clef_champ_cible.gather)}
    # CF name (transient standard name) du champ de couplage cible
    set std_name_cible ""
    catch {set std_name_cible $dico_applis(app.$app_cible.comp.$comp_cible.champ.$champ_cible.std_name)}

    # Convertir les unites de temps
    #   de : secs, mins, hours, days, months, years
    #    a : seconds, minutes, hours, days, months, years
    array set conversion { {} {} secs seconds mins minutes hours hours days days months months years years }
    set unite_period_source $conversion($unite_period_source)
    set unite_period_cible  $conversion($unite_period_cible)

    # Ajouter un 's' de pluriel aux unités de temps de la période des échanges
    set exch_per_unit ${exch_per_unit}s

    # Réinterprèter le champ "type de remaillage"
    # ------------------------------------------

    # Liste de mots-clefs et de descriptions lisibles correspondantes
    array set remaillages { {} None nneighbour3D {3D Nearest neighbour} trilinear {3D Trilinear} nneighbour2D {2D Nearest neighbour}
        bilinear {2D Bilinear} bicubic {2D Bicubic} conservativ2D {2D Conservativ} }

    # Transforme le mot-clef en description lisible
    set remail $remaillages($remail)

    # Réinterprète le champ "source time operation"
    array set mots_clefs { {} None taverage {Time average} accumul {Time accumulation} }
    set src_time_op $mots_clefs($src_time_op)

    # Réinterprète le champ "target time operation"
    array unset mots_clefs
    array set mots_clefs { {} {None (closest time)} time_nneighbour {None (closest time)} time_linear {Time interpolation} }
    set tgt_time_op $mots_clefs($tgt_time_op)

    # Réinterprète les booléens
    # Pour tous les champs booléens
    foreach nom_champ { dbg_source dbg_cible } {
        set valeur [set $nom_champ]
        if {$valeur == "true"} {set $nom_champ yes} else {set $nom_champ no}
    }
    
    if { $remail != "None" } {
        if {$norm_near_nei == "true"} {set norm_near_nei yes} else {set norm_near_nei no}
        # Traduit l'option de remaillage conservatif
        switch $norm_method {
            fracarea { set norm_method "Fractional area" }
            destarea { set norm_method "Destination area" }
        }
    }
    
    # Crée la boite de dialogue de saisie de tous les paramètres d'une connexion
    if { $remail != "None" } {
        # Passe tous les parametres, avec les options de remaillage
        comm_saisie 0 $clef_cnx $comp_source $champ_source $std_name_source $qte_period_source $unite_period_source $comp_cible $champ_cible $std_name_cible $qte_period_cible $unite_period_cible $scatter $gather $exch_per_unit $exch_per_val $lag $src_time_op $src_add_val $src_mult_val $dbg_source $stat_source_mask $stat_source_nmsk $stat_source_all $remail $tgt_time_op $tgt_add_val $tgt_mult_val $dbg_cible $stat_cible_mask $stat_cible_nmsk $stat_cible_all $nbr_neighbours $bi3_method $if_masked $norm_method $norm_near_nei
    } else {
        # Passe tous les parametres sans les options de remaillage
        comm_saisie 0 $clef_cnx $comp_source $champ_source $std_name_source $qte_period_source $unite_period_source $comp_cible $champ_cible $std_name_cible $qte_period_cible $unite_period_cible $scatter $gather $exch_per_unit $exch_per_val $lag $src_time_op $src_add_val $src_mult_val $dbg_source $stat_source_mask $stat_source_nmsk $stat_source_all $remail $tgt_time_op $tgt_add_val $tgt_mult_val $dbg_cible $stat_cible_mask $stat_cible_nmsk $stat_cible_all
    }
    # Remarque : si la connexion a pour source ou cible un fichier, beaucoup des paramètres passés 
    #            à la procedure com_saisie() sont inutilisés
    #            De plus, si la connexion a un fichier pour cible, certains paramètres du fichier
    #            ne sont pas passés explicitement mais par l'intermédiaire du param. "clef_cnx"

    catch {tkwait window .edit_comm}
    # Si les connexions sont dessinées
    if {$viewcommcheck != 0} {
        # Redessine toutes les cnx allant au composant cible (dont celle qu'on vient de modifier)
        Draw_comm $app_cible.$comp_cible
    }
    # Si la cible est un fichier NetCDF
    if { $app_cible == "///file///" } {
        # Redessine le fichier car des attributs qui sont affichés dans une info-bulle ont pu changer
        Draw_one_unit $app_cible.$comp_cible
    }
    
    # Affiche la liste des connexions et sélectionne celle-ci
    control_entity CONNECTION $clef_cnx
}

ret  {comm_insert} (type i_, type source , type i_, type target) {
# Crée une nouvelle connexion entre deux composants

    # Variables globales
    global dico_caract_points dico_applis

    # Extrait les infos pertinentes
    # -----------------------------

    # Appli du composant source
    set appli_source $dico_caract_points($i_source.appli)
    # Nom du composant source
    set comp_source $dico_caract_points($i_source.comp)
    # Nom du champ source
    set champ_source $dico_caract_points($i_source.champ)
    
    # Si la source est un fichier NetCDF
    if { $appli_source == "///file///"} {
        set unite_period_source ""
        set qte_period_source ""
        set scatter ""
        set std_name_source ""
    } else {
        # Clef d'accès au champ de couplage source
        set clef_champ_source app.$appli_source.comp.$comp_source.champ.$champ_source.o
        # Minimal period
        set period_source [array get dico_applis $clef_champ_source.nbr_*]
        set unite_period_source [string range  [lindex $period_source 0] [string length $clef_champ_source.nbr_] end]
        set qte_period_source [lindex $period_source 1]
        set scatter $dico_applis($clef_champ_source.scatter)
        # CF name (transient standard name) du champ de couplage source
        catch {set std_name_source $dico_applis(app.$appli_source.comp.$comp_source.champ.$champ_source.std_name)}
    }
    
    # Appli du composant cible
    set appli_cible $dico_caract_points($i_target.appli)
    # Nom du composant cible
    set comp_cible $dico_caract_points($i_target.comp)
    # Nom du champ cible
    set champ_cible $dico_caract_points($i_target.champ)
    
    # Si la cible est un fichier NetCDF
    if { $appli_cible == "///file///"} {
        set unite_period_cible ""
        set qte_period_cible ""
        set gather ""
        set std_name_cible ""
    } else {
        # Clef d'accès au champ de couplage cible
        set clef_champ_cible app.$appli_cible.comp.$comp_cible.champ.$champ_cible.i
        # Minimal period
        set period_cible [array get dico_applis $clef_champ_cible.nbr_*]
        set unite_period_cible [string range  [lindex $period_cible 0] [string length $clef_champ_cible.nbr_] end]
        set qte_period_cible [lindex $period_cible 1]
        set gather $dico_applis($clef_champ_cible.gather)
        # CF name (transient standard name) du champ de couplage cible
        catch {set std_name_cible $dico_applis(app.$appli_cible.comp.$comp_cible.champ.$champ_cible.std_name)}
    }

    # Convertit les unites de temps
    #   de : secs, mins, hours, days, months, years
    #    a : seconds, minutes, hours, days, months, years
    array set conversion { secs seconds mins minutes hours hours days days months months years years }
    if { $unite_period_source != "" } {
        set unite_period_source $conversion($unite_period_source)
    }
    if { $unite_period_cible != "" } {
        set unite_period_cible  $conversion($unite_period_cible)
    }

    # Crée la boite de dialogue de saisie de tous les paramètres d'une connexion
    comm_saisie 1 "$i_source $i_target" $comp_source $champ_source $std_name_source $qte_period_source $unite_period_source $comp_cible $champ_cible $std_name_cible $qte_period_cible $unite_period_cible $scatter $gather
}

ret  {comm_new} (type flag , type point_, type index) {
#
    global oldput oldget
    global oldcolorput oldcolorget
    global i_source i_target
    global dico_cnx_out
    global dico_caract_cnx
    global dico_caract_points
    global entityselected objectselected tagselected oldcolor

    set w .gui.pr.cpd22.03

    #** annulation
    #-------------
    if { $flag == "menage" } {
        # S'il y avait un point d'entrée sélectionné
        if { [info exists oldget ]} {
            $w itemconfigure $oldget -fill $oldcolorget
            # Désélectionne et oublie ce point
            unset oldget
            unset i_target
        }
        # S'il y avait un point de sortie sélectionné
        if { [info exists oldput ]} {
            $w itemconfigure $oldput -fill $oldcolorput
            # Désélectionne et oublie ce point
            unset oldput
            unset i_source
        }
    } else {

        # Si il y avait un objet sélectionné
        if {$objectselected != ""} {
            # Déselectionne cet obet sur le graphe
            $w itemconfigure $tagselected -fill $oldcolor
            set tagselected ""
            set objectselected ""
        }

        #** connexion sortante d'un composant
        #------------------------------------
        if { $flag == "out" } {

            if { [info exists oldput ]} { $w itemconfigure $oldput -fill $oldcolorput}

            # Si on a cliqué sur le point sélectionné
            set point [$w find withtag current]
            if { [info exists oldput ] && $oldput == $point } {
                # Désélectionne et oublie ce point
                unset oldput
                unset i_source
            } else {
                # Mémorise le point sélectionné et sa couleur d'origine
                set oldput $point
                set oldcolorput [$w itemcget $oldput -fill ]
                # Change la couleur du point sélectionné
                $w itemconfigure current -fill red
                # Mémorise le point de couplage source (de la future connexion)
                set i_source $point_index
            }
        }

        #** connexion entrante dans un composant
        #---------------------------------------
        if { $flag == "in" } {
            # Si le point cible n'est pas déjà connecté
            set lcnx ""
            catch {set lcnx $dico_caract_points($point_index.lcnx)}
            if { $lcnx == "" } {
    
                # S'il y avait déjà un point sélectionné
                if { [info exists oldget ]} {
                    $w itemconfigure $oldget -fill $oldcolorget
                }
                # Si on a cliqué sur le point sélectionné
                set point [$w find withtag current]
                if { [info exists oldget ] && $oldget == $point } {
                    # Désélectionne et oublie ce point
                    unset oldget
                    unset i_target
                } else {
                    # Mémorise le point sélectionné et sa couleur d'origine
                    set oldget $point
                    set oldcolorget [$w itemcget $oldget -fill ]
                    # Change la couleur du point sélectionné
                    $w itemconfigure current -fill red
                    # Mémorise le point de couplage source (de la future connexion)
                    set i_target $point_index
                }
            }
        }
    }

    # Si un point source et un point cible sont sélectionnés
    if { [info exists i_source ] && [info exists i_target ] } {

        set si_annule 0
        # Nom de l'application du composant source
        set appli_source $dico_caract_points($i_source.appli)
        # Nom de l'application du composant cible
        set appli_cible $dico_caract_points($i_target.appli)
        
        # Si la source et la cible sont tous deux des fichiers NetCDF
        if { $appli_source == "///file///" && $appli_cible == "///file///" } {
            # On ne peut pas créer une telle connexion
            set si_annule 1
        } else {
    
            # On saisit les paramètres de la connexion
            comm_insert $i_source $i_target
            tkwait window .edit_comm
            # A ce stade, l'utilisateur peut avoir annulé la creation de la connexion
    
            # Si le point cible est maintenant connecté
            if { [info exists dico_caract_points($i_target.lcnx)] } {
    
                # Nom du composant source
                set comp_source $dico_caract_points($i_source.comp)
                # Nom du composant cible
                set comp_cible $dico_caract_points($i_target.comp)
    
                # Redessine les composants source et cible
                catch {Draw_one_unit $appli_source.$comp_source}
                catch {Draw_one_unit $appli_cible.$comp_cible}
    
                # Redessine les connexions du cible
                # Draw_comm $appli_source.$comp_source
                Draw_comm $appli_cible.$comp_cible
    
                # Affiche la liste des communications en sélectionnant la dernière créée
                # et annule la selection des points de couplage
                minimenu_comm $i_target
            } else {
                # L'utilisateur a annulé la creation de la connexion
                set si_annule 1
            }
        }
            
        if { $si_annule } {
            # On annule la selection du dernier point de couplage
            if { $flag == "in" } {
                # Désélectionne et oublie ce point
                $w itemconfigure $oldget -fill $oldcolorget
                unset oldget
                unset i_target
            } else {
                # Désélectionne et oublie ce point
                $w itemconfigure $oldput -fill $oldcolorput
                unset oldput
                unset i_source
            }
        }
    }
}

ret  {comm_remove} (type clef_, type cnx) {
# Remove from memory one connexion between two component or between one component and one file
    global dico_caract_cnx
    global dico_caract_points
    global liste_cnx_in dico_cnx_out

    # Extrait les infos pertinentes
    # -----------------------------

    set appli_source $dico_caract_cnx($clef_cnx.app_source)
    set appli_cible $dico_caract_cnx($clef_cnx.app_cible)
    set comp_source $dico_caract_cnx($clef_cnx.comp_source)
    set comp_cible  $dico_caract_cnx($clef_cnx.comp_cible)
    set champ_source $dico_caract_cnx($clef_cnx.champ_source)
    set champ_cible  $dico_caract_cnx($clef_cnx.champ_cible)
    # L'id (la clef) de la connexion est celui du point de couplage cible
    set id_point_in $clef_cnx
    # Recherche le numéro du point de couplage source (o1 ou o2, o3,...)
    set num_point_out $dico_caract_cnx($clef_cnx.pt_source)
    # Id du point de couplage source
    set id_point_out $appli_source.$comp_source.$champ_source.o

    # Supprime la memoire de la connexion
    # -----------------------------------

    # 1) Au niveau des points de couplage
    # -----------------------------------

    # 1.a) Point de couplage cible
    # Mémorise que le point cible n'est plus connecté
    unset dico_caract_points($id_point_in.lcnx)

    # 1.b) Point de couplage source
    # Le point source peut avoir plusieurs connexions
    # Liste de toutes les connexions sortantes
    set l_cnx_out $dico_caract_points($id_point_out.lcnx)
    # Supprime de la liste la connexion en question
    set dico_caract_points($id_point_out.lcnx) [lsearch -not -all -inline $l_cnx_out $num_point_out]

    # 2) Des listes des connexions
    # ----------------------------

    # 2.a) la liste des connexions sortantes
    set clef_cnx_out $appli_source.$comp_source.$champ_source.$num_point_out  
    unset dico_cnx_out($clef_cnx_out)

    # 2.b) la liste des connexions entrantes
    set liste_cnx_in [lsearch -not -all -inline $liste_cnx_in $clef_cnx]

    # 2.c) la liste des connexions avec leurs caractéristiques
    array unset dico_caract_cnx $clef_cnx.*
}

ret  {comm_saisie} (type si_, type nouveau , type clef_, type cnx , type comp_, type source , type champ_, type source , type std_, type name_, type source , type qte_, type period_, type source , type unite_, type period_, type source , type comp_, type cible , type champ_, type cible , type std_, type name_, type cible , type qte_, type period_, type cible , type unite_, type period_, type cible , type scatter , type gather , optional exch_per_unit ={) {exch_per_val {}} {lag {}} {src_time_op None} {src_add_val 0} {src_mult_val 1} {dbg_source no} {stat_source_mask off} {stat_source_nmsk off} {stat_source_all off} {remail None} {tgt_time_op {None (Closest time)}} {tgt_add_val 0} {tgt_mult_val 1} {dbg_cible no} {stat_cible_mask off} {stat_cible_nmsk off} {stat_cible_all off} {nbr_neighbours {}} {bi3_ret  Choose...} (type if_, type masked , optional No =value) {norm_method None} {norm_near_nei no}} {
/*  Crée la boite de dialogue permettant de choisir tous les paramètres d'une connexion*/
/*    - si_nouveau  :   indique si on crée une nouvelle connexion ou si on en modifie une existante*/
/*    - clef_cnx    :   si création, paire de clef des points de couplage source et cible*/
/*                      sinon clef d'acces a une connexion existante*/
/* */
    global dico_caract_points dico_caract_cnx
    global dico_caract_fichiers
    
    /*  Variables globales utilisées pour la saisie*/
    foreach var_name { exch_per_unit_m exch_per_val_m lag_m src_time_op_m src_add_val_m src_mult_val_m scatter_m dbg_source_m stat_cible_mask_m stat_cible_nmsk_m stat_cible_all_m remail_m tgt_time_op_m tgt_add_val_m tgt_mult_val_m gather_m dbg_cible_m stat_cible_mask_m stat_cible_nmsk_m stat_cible_all_m file_packing_m file_scaling_m file_adding_m file_fill_value_m } {
        global $var_name
         $var = _name ""
    }
    
    /* =====================================================================*/
    /* ===                     Crée une boite de dialogue*/
    /* =====================================================================*/
     u =  .edit_comm
    catch {destroy $u}
    toplevel $u
    if {$si_nouveau} {
        wm title $u "Insert a connection"
        wm iconname $u "Insert_Cnx"
        /*  Détermine les points de couplage source et cible*/
         i = _source [lindex $clef_cnx 0]
         i = _target [lindex $clef_cnx 1]
        /*  Appli du composant source*/
         appli = _source $dico_caract_points($i_source.appli)
        /*  Appli du composant cible*/
         appli = _cible $dico_caract_points($i_target.appli)
        /*  Définit la commande  à exécuter lors de la validation de saisie*/
        /*    --> ajout d'une nouvelle connexion*/
         on = _OK "comm_add $u $i_source $i_target"
    } else {
        wm title $u "Change connection properties"
        wm iconname $u "change_cnx"
        /*  Appli du composant source*/
         appli = _source $dico_caract_cnx($clef_cnx.app_source)
        /*  Appli du composant cible*/
         appli = _cible $dico_caract_cnx($clef_cnx.app_cible)
        /*  Définit la commande à exécuter lors de la validation de saisie*/
        /*    --> mise à jour des paramètres de la connexion*/
         on = _OK "comm_update $u $clef_cnx"
    }
    
    /*  Determine si la source ou la cible est un fichier NetCDF*/
     si = _source_fichier [string equal $appli_source "///file///"]
     si = _cible_fichier [string equal $appli_cible "///file///"]
    
    /*  Si la période des échanges n'est pas renseignée*/
    if {$exch_per_unit == ""} {
        
        /*  Initialise la période des échanges*/
        /*  ----------------------------------*/
        
        /*  Si connexion d'un composant avec un fichier NetCDF*/
        if {$si_source_fichier || $si_cible_fichier} {
            if {$si_source_fichier} {
                /*  La période des échanges est dictée par la cible*/
                 exch = _per_unit $unite_period_cible
                 exch = _per_val  $qte_period_cible
            } else {
                /*  La période des échanges est dictée par la source*/
                 exch = _per_unit $unite_period_source
                 exch = _per_val  $qte_period_source
            }
            
        } else {
            /*  Connexion entre deux composants ayant chacun une période propre*/
            
            /*  Unité de temps la plus grande des deux périodes (parmi source et cible)*/
             liste = _unites {seconds minutes hours days months years}
             indx = _period_source [lsearch $liste_unites $unite_period_source]
             indx = _period_cible  [lsearch $liste_unites $unite_period_cible]
            
            /*  Si l'unité des périodes source et cibles sont différentes*/
            if { $indx_period_source != $indx_period_cible } {
                /*  Choisit l'unité la plus petite*/
                if { $indx_period_source < $indx_period_cible } {
                     min = _index $indx_period_source
                     max = _index $indx_period_cible
                     exch = _per_unit $unite_period_source
                } else {
                     min = _index $indx_period_cible
                     max = _index $indx_period_source
                     exch = _per_unit $unite_period_cible
                }
                
                /*  Convertit les périodes source et cible dans cette unité*/
                /*  -------------------------------------------------------*/
                
                /*  Calcule le facteur multiplicatif a appliquer sur une unité*/
                 liste = _facteurs {60 60 24 30 12}
                 liste = _facteurs [lrange $liste_facteurs $min_index [expr $max_index-1]]
                 facteur =  1
                foreach nombre $liste_facteurs {
                     facteur =  [expr $facteur * $nombre]
                }
                /*  Si il faut convertir la période cible*/
                if {$indx_period_source < $indx_period_cible} {
                     valeur = _cible [expr $qte_period_cible * $facteur]
                     valeur = _source $qte_period_source
                } else {
                     valeur = _source [expr $qte_period_source * $facteur]
                     valeur = _cible  $qte_period_cible
                }
            
            /*  Si l'unité des périodes source et cibles sont les mêmes*/
            } else {
                /*  La période des échanges est initialisée avec cette unité*/
                 exch = _per_unit $unite_period_source
                 valeur = _source $qte_period_source
                 valeur = _cible  $qte_period_cible
            }
            /*  Initialise la valeur de la période avec le PPCM (Pplus Petit Commun Multiple) des deux valeurs*/
            /*  PPCM(A,B) = A * B / PGCD(A,B)*/
             exch = _per_val [expr $valeur_cible * $valeur_source / [pgcd $valeur_cible $valeur_source]]
        }
    }

     x =  [expr [winfo rootx .gui]+200]
     y =  [expr [winfo rooty .gui]-20]
    wm geometry $u "+$x+$y"

     w =  $u.menu
    frame $w
    grid $w -row 2 -column 0
    grid configure $w -columnspan 2 -padx 4 -pady 4

    /* =====================================================================*/
    /* ===                     boutons*/
    /* =====================================================================*/

    frame $w.buttons
    pack $w.buttons -side bottom -fill x -pady 2m
    button $w.buttons.dismiss -text Cancel -command "catch {destroy .remaillage}; destroy $u"
    button $w.buttons.ok -text OK -command "$on_OK \$exch_per_unit_m \$exch_per_val_m \$lag_m \$src_time_op_m \$src_add_val_m \$src_mult_val_m \$dbg_source_m \$stat_source_mask_m \$stat_source_nmsk_m \$stat_source_all_m \$remail_m \$tgt_time_op_m \$tgt_add_val_m \$tgt_mult_val_m \$dbg_cible_m \$stat_cible_mask_m \$stat_cible_nmsk_m \$stat_cible_all_m \$file_packing_m \$file_scaling_m \$file_adding_m \$file_fill_value_m"
    /*  focus $w.buttons.ok*/
    bind $w.buttons.ok <KeyPress-Return> "$on_OK \$exch_per_unit_m \$exch_per_val_m \$lag_m \$src_time_op_m \$src_add_val_m \$src_mult_val_m \$dbg_source_m \$stat_source_mask_m \$stat_source_nmsk_m \$stat_source_all_m \$remail_m \$tgt_time_op_m \$tgt_add_val_m \$tgt_mult_val_m \$dbg_cible_m \$stat_cible_mask_m \$stat_cible_nmsk_m \$stat_cible_all_m \$file_packing_m \$file_scaling_m \$file_adding_m \$file_fill_value_m"

    pack $w.buttons.dismiss -side left -expand 1 -padx 10
    pack $w.buttons.ok -side right -expand 1 -padx 10
    
    /*  frame $w.sep1 -width 430 -height 2 -borderwidth 1 -relief sunken*/
    /*  pack $w.sep1 -side bottom -fill x -pady 2m -expand 1*/

     w =  $u.char
    frame $w
    grid $w -row 0 -column 1
    grid configure $w -padx 4 -pady 4

    /* =====================================================================*/
    /* ===                     source*/
    /* =====================================================================*/

    /* ===source name*/
     r =  0
    if {$si_source_fichier} {
        label $w.label0 -text "Source file :"
    } else {
        label $w.label0 -text "Source component :"
    }
    grid $w.label0 -row $r -column 0 -sticky e -padx 10 -pady 4
    grid [label $w.label0b -relief sunken -width 60 -text $comp_source -anchor w] -row $r -column 1 -sticky w -padx 2
    incr r
    /* ===object name at source*/
    grid [label $w.label1 -text "Source field :"] -row $r -column 0 -sticky e -padx 10 -pady 4
    grid [label $w.label1b -relief sunken -width 60 -text $champ_source -anchor w] -row $r -column 1 -sticky w -padx 2
    incr r
    /* ===standard name at source*/
    grid [label $w.label1c -text "CF standard name:"] -row $r -column 0 -sticky e -padx 10 -pady 4
    grid [label $w.label1d -relief sunken -width 60 -text $std_name_source -anchor w] -row $r -column 1 -sticky w -padx 2
    incr r
    /* ===minimal period of output*/
    if {! $si_source_fichier} {
        grid [label $w.label2 -text "Minimal period :"] -row $r -column 0 -sticky e -padx 10 -pady 4
        grid [label $w.label22 -relief sunken -text "$qte_period_source $unite_period_source"] -row $r -column 1 -sticky w -padx 2
        incr r
    }

    /* =====================================================================*/
    /* ===                     target*/
    /* =====================================================================*/
    grid [ frame $w.sep1 -width 430 -height 2 -borderwidth 1 -relief sunken] -row $r -column 0 -pady 5 -columnspan 2
    incr r

    /* ===target name*/
    if {$si_cible_fichier} {
        /*  Le champ "comp_cible" est l'identifiant du fichier : il faut determiner son nom*/
         nom = _fichier $dico_caract_fichiers($comp_cible.name)
        label $w.label3 -text "Target file :"
        label $w.label3b -relief sunken -width 60 -text $nom_fichier -anchor w
    } else {
        label $w.label3 -text "Target component :"
        label $w.label3b -relief sunken -width 60 -text $comp_cible -anchor w
    }
    grid $w.label3 -row $r -column 0 -sticky e -padx 10 -pady 4
    grid $w.label3b -row $r -column 1 -sticky w -padx 2
    incr r
    /* ===object name at target*/
    grid [label $w.label4 -text "Target field :"] -row $r -column 0 -sticky e -padx 10 -pady 4
    grid [label $w.entry4 -relief sunken -width 60 -text $champ_cible -anchor w] -row $r -column 1 -sticky w -padx 2
    incr r
    /* ===standard name at target*/
    grid [label $w.label4a -text "CF standard name:"] -row $r -column 0 -sticky e -padx 10 -pady 4
    grid [label $w.label4b -relief sunken -width 60 -text $std_name_cible -anchor w] -row $r -column 1 -sticky w -padx 2
    incr r
    /* ===minimal period of input*/
    if {! $si_cible_fichier} {
        grid [label $w.label5 -text "Minimal period :"] -row $r -column 0 -sticky e -padx 10 -pady 4
        grid [label $w.label55 -relief sunken -text "$qte_period_cible $unite_period_cible"] -row $r -column 1 -sticky w -padx 2
        incr r
    }

    /* =====================================================================*/
    /* ===                     attributs de la cnx*/
    /* =====================================================================*/
    grid [ frame $w.sep2 -width 430 -height 2 -borderwidth 1 -relief sunken] -row $r -column 0 -pady 5 -columnspan 2
    incr r

    /* ===exchange period*/
    grid [label $w.label6 -text "Exchange period :" ] -row $r -column 0 -sticky e -padx 10 -pady 4

    grid [frame $w.frexch] -row $r -column 1 -sticky w -padx 2
    global exch_per_val_m exch_per_val_m_regexp
    trace variable exch_per_val_m w {entry_forceRegexp {^[0-9]*$} }
     exch = _per_val_m $exch_per_val
    pack [entry $w.frexch.e1 -takefocus 1 -textvariable exch_per_val_m -width 10 -background white] -side left
    /*  $w.frexch.e1 delete 0 end ; $w.frexch.e1 insert 0 $exch_per_val*/
     liste = _unites {seconds minutes hours days months years}
    combobox_lim $w.frexch.cmb $liste_unites {} exch_per_unit_m 28 $exch_per_unit
    pack $w.frexch.cmb -side left -padx 2
    incr r

    /*  Ajoute une bulle d'aide pour 'exchange_period'*/
     help = _text {Enter here the exchange period for the connection.}
    entry_help_balloon $w.frexch $help_text
    
    /* =====================================================================*/
    /* ===                     Paramètres à la source*/
    /* =====================================================================*/
    
    /*  Si la source est un fichier (n'est pas un composant d'une application)*/
    if {$si_source_fichier} {
        /*  Initialise des var globales inutilisées mais nécessaires par compatibilité avec l'autre option*/
        global src_time_op_m src_add_val_m src_mult_val_m scatter_m dbg_source_m stat_source_mask_m stat_source_nmsk_m stat_source_all_m
         src = _time_op_m ""
         src = _add_val_m ""
         src = _mult_val_m ""
         scatter = _m ""
         dbg = _source_m ""
         stat = _source_mask_m ""
         stat = _source_nmsk_m ""
         stat = _source_all_m ""
    } else {
        /*  Met dans un cadre spécial tous les champs paramètres de la connexion du cotè source*/
        comm_saisie_param_source $w $r $lag $src_time_op $src_add_val $src_mult_val $scatter $dbg_source $stat_source_mask $stat_source_nmsk $stat_source_all 
    }
    incr r

    /* =====================================================================*/
    /* ===                     transformations au milieu (remaillage)*/
    /* =====================================================================*/

    /*  Si la source et la cible sont des composants d'application*/
    if {! ($si_cible_fichier || $si_source_fichier) } {
        
        /*  Fait une copie des options de remaillage dans une var globale*/
        /*  Car les options de remaillage sont saisies dans*/
        /*  une boite de dialogue complémentaire (comm_saisie_remaillage)*/
        global options_remail
        foreach option {nbr_neighbours bi3_ret  if_masked norm_method norm_near_nei} (
            type set , type value [, type set $, type option]
            , type set , type options_, type remail($, type option) $, type value
        )

        # Champs de saisie
        grid [label $w.label13 -text "Regridding :" ] -row $r -column 0 -sticky e -padx 10 -pady 4
        grid [frame $w.fr_remail] -row $r -column 1 -sticky w -padx 2
        set liste_descript { None "3D Nearest neighbour" "3D Trilinear" "2D Nearest neighbour"
                            "2D Bilinear" "2D Bicubic" "2D Conservativ" }
        global si_debut_remail;  si = _debut_remail 1
        combobox_lim $w.fr_remail.cmb5 $liste_descript comm_saisie_remaillage remail_m 28 $remail
        pack $w.fr_remail.cmb5 -side left
        button $w.fr_remail.det -text Options -command [list comm_saisie_remaillage "$w.fr_remail.cmb5" -1 ]
        pack $w.fr_remail.det  -side left -expand 1 -padx 10
        incr r

        /*  Ajoute une bulle d'aide pour 'remaillage'*/
         help = _text {Choose the regridding to be performed on the output coupling field to express it on the target model grid.
Note that the regridding will provide values interpolated from the source field for all target grid cells except for the following ones:
• the target cell does not intersect any part of the source grid domain; for those cells, the target field keeps the same value as before the call to prism get ;
• the target cell is masked; for those cells, the target field keeps the same value as before the call to prism get ;
• the target cell is not masked, but the interpolation as requested in the SMIOC file cannot be performed; for those cells, the target field will take the 'psmile_undef' value (=-280177).

A '2D conservative' regridding means that the weight of a source cell is proportional to area intersected by target cell.}
        entry_help_balloon $w.fr_remail.cmb5 $help_text
 
        /*  Ajoute une bulle d'aide pour le bouton 'Options'*/
        global no_help_balloon
        if { $no_help_balloon == 0 } {
             help = _text {Click here to select the interpolation options.}
             help = _action "help_object %W [list $help_text] message"
            bind $w.fr_remail.det <Any-Enter> $help_action
            bind $w.fr_remail.det <FocusIn>   $help_action
            bind $w.fr_remail.det <Any-Leave>    "help_object_hide"
            bind $w.fr_remail.det <FocusOut>     "help_object_hide"
            bind $w.fr_remail.det <ButtonPress>  "help_object_hide"
        }
    }

    /* =====================================================================*/
    /* ===                     Paramètres à la cible*/
    /* =====================================================================*/

    /*  Si la cible est un fichier*/
    if {$si_cible_fichier} {
        /*  Met dans un cadre spécial tous les attributs du fichier NetCDF*/
        if { $si_nouveau } {
             file = _packing ""
             file = _scaling ""
             file = _adding ""
             file = _fill_value ""
        } else {
             file = _packing $dico_caract_fichiers($comp_cible.field.packing)
             file = _scaling $dico_caract_fichiers($comp_cible.field.scaling)
             file = _adding $dico_caract_fichiers($comp_cible.field.adding)
             file = _fill_value $dico_caract_fichiers($comp_cible.field.fill_value)
        }
        comm_saisie_attrib_NetCDF $w $r $file_packing $file_scaling $file_adding $file_fill_value
    
        /*  Initialise des var globales inutilisées mais nécessaires par compatibilité avec l'autre option (cible = composant)*/
        global tgt_time_op_m tgt_add_val_m tgt_mult_val_m gather_m dbg_cible_m stat_cible_mask_m stat_cible_nmsk_m stat_cible_all_m
         tgt = _time_op_m ""
         tgt = _add_val_m ""
         tgt = _mult_val_m ""
         gather = _m ""
         dbg = _cible_m ""
         stat = _cible_mask_m ""
         stat = _cible_nmsk_m ""
         stat = _cible_all_m ""
    } else {
        /*  la cible est un composant d'une application*/
        /*  Met dans un cadre spécial tous les champs paramètres de la connexion du cotè cible*/
        comm_saisie_param_cible $w $r $tgt_time_op $tgt_add_val $tgt_mult_val $gather $dbg_cible $stat_cible_mask $stat_cible_nmsk  $stat_cible_all $si_source_fichier
    }
    incr r
    
    /*  Cache la bulle d'aide et ferme la fenetre d'options de remaillage si fermeture de la fenetre*/
    bind $u <Destroy> "help_object_hide; catch {destroy .remaillage}"

}

ret  {pgcd} (type a , type b) {
# Calcule de Plus Grand Diviseur Commun de deux nombres entiers 
# selon la méthode Euclidienne
    if {$a > $b} {
        set n1 $a; set n2 $b
    } else {
        set n1 $b; set n2 $a
    }

    set r [expr $n1 % $n2]
    if { $r == 0} {
        return $n2
    } else {
        return [pgcd $n2 $r]
    }
}

ret  {comm_saisie_attrib_NetCDF} (type win , type row , type file_, type packing , type file_, type scaling , type file_, type adding , type file_, type fill_, type value) {
# Prépare un cadre rempli de zones de saisie pour la saisie des attributs d'un champ de fichier NetCDF
#
    # Crée le cadre de couleur et le place dans la grille de la fenêtre mère
    labelframe $win.netCDF -bg AntiqueWhite1 -borderwidth 1 -relief solid -text " NetCDF field attributes "
    grid  $win.netCDF -row $row -column 0 -columnspan 2 -pady 4
    set fr $win.netCDF
    set r 0
    
    #=== packing
    grid [label $fr.label2 -text "Packing :"] -row $r -column 0 -sticky e -padx 10 -pady 4
    global file_packing_m
    trace variable file_packing_m w {entry_forceRegexp {^[ 1248]?$} }
    set file_packing_m $file_packing
    grid [entry $fr.entry2 -textvariable file_packing_m -width 10 -background white] -row $r -column 1 -sticky w -padx 2
    incr r

    # Ajoute une bulle d'aide pour 'packing'
    set help_text {If packing is chosen, data on file is compressed to 1, 2, 4 or 8 bit data fields. Choose either 1, 2, 4 or 8 or none.}
    entry_help_balloon $fr.entry2 $help_text

    #=== scaling
    grid [label $fr.label3 -text "Scaling :"] -row $r -column 0 -sticky e -padx 10 -pady 4
    global file_scaling_m
    trace variable file_scaling_m w {entry_forceReal }
    set file_scaling_m $file_scaling
    grid [entry $fr.entry3 -textvariable file_scaling_m -width 10 -background white] -row $r -column 1 -sticky w -padx 2
    incr r

    # Ajoute une bulle d'aide pour 'scaling'
    set help_text {if present, data are stored in file after dividing by the ‘scaling’ value (1.0 by default).
The scaling factor is also stored in the file for the purpose of reading applications.}
    entry_help_balloon $fr.entry3 $help_text

    #=== adding
    grid [label $fr.label4 -text "Adding :"] -row $r -column 0 -sticky e -padx 10 -pady 4
    global file_adding_m
    trace variable file_adding_m w {entry_forceReal }
    set file_adding_m $file_adding
    grid [entry $fr.entry4 -textvariable file_adding_m -width 10 -background white] -row $r -column 1 -sticky w -padx 2
    incr r

    # Ajoute une bulle d'aide pour 'adding'
    set help_text {if present, data are stored in file after subtracting the adding’ value (0.0 by default).
The adding value is also stored in the file for the purpose of reading applications.}
    entry_help_balloon $fr.entry4 $help_text

    #=== fill_value
    grid [label $fr.label5 -text "Fill value :"] -row $r -column 0 -sticky e -padx 10 -pady 4
    global file_fill_value_m
    trace variable file_fill_value_m w {entry_forceReal }
    set file_fill_value_m $file_fill_value
    grid [entry $fr.entry5 -textvariable file_fill_value_m -width 10 -background white] -row $r -column 1 -sticky w -padx 2
    incr r

    # Ajoute une bulle d'aide pour 'fill_value'
    set help_text {Specifies the value given in the file to undefined or missing data. For example, value given to grid points for which no meaningfull value was calculated.}
    entry_help_balloon $fr.entry5 $help_text
}

ret  {comm_saisie_param_cible} (type win , type row , type tgt_, type time_, type op , type tgt_, type add_, type val , type tgt_, type mult_, type val , type gather , type dbg_, type cible , type stat_, type cible_, type mask , type stat_, type cible_, type nmsk , type stat_, type cible_, type all , type si_, type source_, type fichier) {
# Prépare un cadre rempli de zones de saisie pour la saisie d'une connexion
# Ce cadre est spécialisé dans les paramètres du côté de la cible de la connexion
#
    # Crée le cadre de couleur et le place dans la grille de la fenêtre mère
    labelframe $win.tgt_param -bg AntiqueWhite1 -borderwidth 1 -relief solid -text " Target parameters "
    grid  $win.tgt_param -row $row -column 0 -columnspan 2 -pady 4
    set fr_tgt $win.tgt_param
    set r_tgt 0
    
    # Si la source est un fichier
    if {$si_source_fichier} {
        #=== time operation
        grid [label $fr_tgt.label14 -text "Time operation :"] -row $r_tgt -column 0 -sticky e -padx 10 -pady 4
        combobox_lim $fr_tgt.cmb6 {{None (Closest time)} {Time interpolation}} {} tgt_time_op_m 28 $tgt_time_op
        grid $fr_tgt.cmb6 -row $r_tgt -column 1 -sticky w -padx 2
        incr r_tgt
    
        # Ajoute une bulle d'aide pour 'Time operation'
        set help_text {Target time interpolation is supported only for IO data read from a file. It is a linear time interpolation between the two closest timestamps in the input file.}
        entry_help_balloon $fr_tgt.cmb6 $help_text
    }
    
    #=== opération algébrique
    grid [label $fr_tgt.label15 -text "Algebraic operation :"] -row $r_tgt -column 0 -sticky e -padx 10 -pady 4
    grid [frame $fr_tgt.fr_tgt_algb] -row $r_tgt -column 1 -sticky w -padx 2
    
    pack [label $fr_tgt.fr_tgt_algb.label1 -text "Mult by "] -side left -padx 2
    global tgt_mult_val_m
    trace variable tgt_mult_val_m w {entry_forceReal}
    set tgt_mult_val_m $tgt_mult_val
    pack [entry $fr_tgt.fr_tgt_algb.e1 -textvariable tgt_mult_val_m -width 10 -background white] -side left
    
    pack [label $fr_tgt.fr_tgt_algb.label2 -text "Add "] -side left -padx 2
    global tgt_add_val_m
    trace variable tgt_add_val_m w {entry_forceReal}
    set tgt_add_val_m $tgt_add_val
    pack [entry $fr_tgt.fr_tgt_algb.e2 -textvariable tgt_add_val_m -width 10 -background white] -side left
    incr r_tgt

    # Ajoute une bulle d'aide pour 'Algebraic operation'
    set help_text {Each grid point coupling/IO field value is multiplied then increased by scalars specified in this element after  being received from source component.}
    entry_help_balloon $fr_tgt.fr_tgt_algb $help_text

    #===non masked value gathering
    grid [label $fr_tgt.label16 -text "Non masked value gathering :"] -row $r_tgt -column 0 -sticky e -padx 10 -pady 4
    array set conversion { 1 yes 0 no "" no }
    label $fr_tgt.label17 -relief sunken -text $conversion($gather)
    grid $fr_tgt.label17 -row $r_tgt -column 1 -sticky w -padx 2
    incr r_tgt

    #===mode debug at target
    grid [label $fr_tgt.label9 -text "Target debug mode :"] -row $r_tgt -column 0 -sticky e -padx 10 -pady 4
    combobox_lim $fr_tgt.cmb2 "yes no" {} dbg_cible_m 28 $dbg_cible
    grid $fr_tgt.cmb2 -row $r_tgt -column 1 -sticky w -padx 2
    incr r_tgt

    # Ajoute une bulle d'aide pour 'debug mode'
    set help_text {If set to true, the input coupling/IO field is automatically written to a file each time it is received from the source component.}
    entry_help_balloon $fr_tgt.cmb2 $help_text    
    
    #=== statistics at target
    grid [label $fr_tgt.label9b -text "Target statistics :"] -row $r_tgt -column 0 -sticky e -padx 10 -pady 4
    grid [frame $fr_tgt.fr_tgt_stat] -row $r_tgt -column 1 -sticky w -padx 2
    pack [label $fr_tgt.fr_tgt_stat.label1 -text "Masked :"] -side left -padx 2
    combobox_lim $fr_tgt.fr_tgt_stat.cmb1 "on off" {} stat_cible_mask_m 9 $stat_cible_mask
    pack $fr_tgt.fr_tgt_stat.cmb1 -side left
    
    pack [label $fr_tgt.fr_tgt_stat.label2 -text "Non Masked :"] -side left -padx 2
    combobox_lim $fr_tgt.fr_tgt_stat.cmb2 "on off" {} stat_cible_nmsk_m 9 $stat_cible_nmsk
    pack $fr_tgt.fr_tgt_stat.cmb2 -side left
    
    pack [label $fr_tgt.fr_tgt_stat.label3 -text "All :"] -side left -padx 2
    combobox_lim $fr_tgt.fr_tgt_stat.cmb3 "on off" {} stat_cible_all_m 9 $stat_cible_all
    pack $fr_tgt.fr_tgt_stat.cmb3 -side left
    incr r_tgt

    # Ajoute une bulle d'aide pour 'Statistics'
    set help_text {Different statistics (minimum, maximum, integral) are calculated for the field on the masked points, and/or on the non masked points, and/or on all points of the input coupling/IO field.
This is done each time the input field is received (before the time operation if any).
These statitistics are printed to the log file for information only; they do not transform the input coupling/IO field.}
    entry_help_balloon $fr_tgt.fr_tgt_stat $help_text
}

ret  {comm_saisie_param_source} (type win , type row , type lag , type src_, type time_, type op , type src_, type add_, type val , type src_, type mult_, type val , type scatter , type dbg_, type source , type stat_, type source_, type mask , type stat_, type source_, type nmsk , type stat_, type source_, type all) {
# Prépare un cadre rempli de zones de saisie pour la saisie d'une connexion
# Ce cadre est spécialisé dans les paramètres du côté de la source de la connexion
#
    # Crée le cadre de couleur et le place dans la grille de la fenêtre mère
    labelframe $win.src_param -bg LavenderBlush -borderwidth 1 -text " Source parameters " -relief solid
    grid  $win.src_param -row $row -column 0 -columnspan 2 -pady 4
    set fr_src $win.src_param
    set r_src 0
        
    #===lag
    grid [label $fr_src.label7 -text "Lag :"] -row $r_src -column 0 -sticky e -padx 10 -pady 4
    global lag_m lag_m_regexp
    trace variable lag_m w {entry_forceRegexp {^[0-9]*$} }
    set lag_m $lag
    grid [entry $fr_src.e7 -textvariable lag_m -width 10 -background white] -row $r_src -column 1 -sticky w -padx 2
    incr r_src
    
    # Ajoute une bulle d'aide pour 'lag'
    set help_text {The lag specifies the number of periods to be added to the output date (prism_put) to match the corresponding input date (prism_get) in the target component.

Note : if lag > 0 (see Oasis user guide, section 5.5.4), a coupling restart file is needed to start the run.}
    entry_help_balloon $fr_src.e7 $help_text
    
    #=== time operation
    grid [label $fr_src.label10 -text "Time operation :"] -row $r_src -column 0 -sticky e -padx 10 -pady 4
    combobox_lim $fr_src.cmb3 {None {Time accumulation} {Time average}} {} src_time_op_m 28 $src_time_op
    grid $fr_src.cmb3 -row $r_src -column 1 -sticky w -padx 2
    incr r_src

    # Ajoute une bulle d'aide pour 'Time operation'
    set help_text {For each grid point, the output coupling/IO field can be averaged or accumulated over the last coupling period before transfer to target component.}
    entry_help_balloon $fr_src.cmb3 $help_text
    
    #=== opération algébrique
    grid [label $fr_src.label11 -text "Algebraic operation :"] -row $r_src -column 0 -sticky e -padx 10 -pady 4
    grid [frame $fr_src.fr_src_algb] -row $r_src -column 1 -sticky w -padx 2

    pack [label $fr_src.fr_src_algb.label1 -text "Mult by "] -side left -padx 2
    global src_mult_val_m
    trace variable src_mult_val_m w {entry_forceReal}
    set src_mult_val_m $src_mult_val
    pack [entry $fr_src.fr_src_algb.e1 -textvariable src_mult_val_m -width 10 -background white] -side left
    
    pack [label $fr_src.fr_src_algb.label2 -text "Add "] -side left -padx 2
    global src_add_val_m
    trace variable src_add_val_m w {entry_forceReal}
    set src_add_val_m $src_add_val
    pack [entry $fr_src.fr_src_algb.e2 -textvariable src_add_val_m -width 10 -background white] -side left
    incr r_src

    # Ajoute une bulle d'aide pour 'Algebraic operation'
    set help_text {Each grid point coupling/IO field value is multiplied then increased by scalars specified in this element before transfer to target component.}
    entry_help_balloon $fr_src.fr_src_algb $help_text    

    #===non masked value scattering
    grid [label $fr_src.label12 -text "Non masked value scattering :"] -row $r_src -column 0 -sticky e -padx 10 -pady 4
    array set conversion { 1 yes 0 no "" no }
    label $fr_src.label13 -relief sunken -text $conversion($scatter)
    grid $fr_src.label13 -row $r_src -column 1 -sticky w -padx 2
    incr r_src

    #===mode debug at source
    grid [label $fr_src.label8 -text "Debug mode :"] -row $r_src -column 0 -sticky e -padx 10 -pady 4
    combobox_lim $fr_src.cmb1 "yes no" {} dbg_source_m 28 $dbg_source
    grid $fr_src.cmb1 -row $r_src -column 1 -sticky w -padx 2
    incr r_src

    # Ajoute une bulle d'aide pour 'Debug mode'
    set help_text {If set to true, the output coupling/IO field is automatically written to a file each time it is sent to the target component.}
    entry_help_balloon $fr_src.cmb1 $help_text    

    #=== statistics at source
    grid [label $fr_src.label8b -text "Statistics :"] -row $r_src -column 0 -sticky e -padx 10 -pady 4
    grid [frame $fr_src.fr_src_stat] -row $r_src -column 1 -sticky w -padx 2
    pack [label $fr_src.fr_src_stat.label1 -text "Masked :"] -side left -padx 2
    combobox_lim $fr_src.fr_src_stat.cmb1 "on off" {} stat_source_mask_m 9 $stat_source_mask
    pack $fr_src.fr_src_stat.cmb1 -side left
    
    pack [label $fr_src.fr_src_stat.label2 -text "Non Masked :"] -side left -padx 2
    combobox_lim $fr_src.fr_src_stat.cmb2 "on off" {} stat_source_nmsk_m 9 $stat_source_nmsk
    pack $fr_src.fr_src_stat.cmb2 -side left
    
    pack [label $fr_src.fr_src_stat.label3 -text "All :"] -side left -padx 2
    combobox_lim $fr_src.fr_src_stat.cmb3 "on off" {} stat_source_all_m 9 $stat_source_all
    pack $fr_src.fr_src_stat.cmb3 -side left
    incr r_src

    # Ajoute une bulle d'aide pour 'Statistics'
    set help_text {Different statistics (minimum, maximum, integral) are calculated for the field on the masked points, and/or on the non masked points, and/or on all points of the output coupling/IO field.
This is done each time the output field is sent, after any time operation (accumulation or average).
These statitistics are printed to the log file for information only; they do not transform the output coupling/IO field.}
    entry_help_balloon $fr_src.fr_src_stat $help_text
}

ret  {comm_saisie_remaillage} (type nom_, type widget , type indice_, type select) {
# Procedure appelee automatiquement sur selection d'un mode de remaillage
# dans la listbox lors de la specification d'une connexion.
# Cette meme proc. est appelee sur clic du bouton "Options" de la meme boite de dialogue.
# Dans ce cas, le parametre "indice_select" n'est pas renseigné et vaut -1.
#
    # Copie les options de remaillage dans des var globales
    global options_remail
    global nbr_neighbours_m nbr_neighbours_m_regexp bi3_method_m if_masked_m norm_method_m norm_near_nei_m
    foreach option {nbr_neighbours bi3_method if_masked norm_method norm_near_nei} {
        set value $options_remail($option)
        set $option\_m $value
    }

    # Var globale indiquant que l'utilisateur a validé sa saisie
    global valid_remail
    # Var globale indiquant qu'on vient de créer la liste déroulante (listbox)
    global si_debut_remail

    # Si sélection du type de remaillage dans la liste déroulante
    if { $indice_select != -1 } {
        # Ferme la liste déroulante
        $nom_widget close
        # Si c'est la première fois
        if { $si_debut_remail } {
            # Ce n'est pas une sélection manuelle : celle faite à l'init de la liste déroulante
            set si_debut_remail 0
            return
        }
    }

    # Type de remaillage sélectionné
    set type_remail [$nom_widget get]
    if { $type_remail != "None" } {
        # Création de la fenêtre de saisie du mode de remaillage avec les champs appropriés
        set u .remaillage
        catch {destroy $u}
        toplevel $u
        wm title $u "Regridding options"
        wm iconname $u "regrid_option"
        set x [expr [winfo rootx $nom_widget]+60]
        set y [expr [winfo rooty $nom_widget]+20]
        wm geometry $u "+$x+$y"
        # Var globale indiquant que l'utilisateur a validé sa saisie
        set valid_remail 0

        set w $u.menu
        frame $w
        grid $w -row 2 -column 0
        grid configure $w -columnspan 2 -padx 4 -pady 4

        # Boutons OK et Cancel
        # ---------------------
        frame $w.buttons
        pack $w.buttons -side bottom -fill x -pady 2m

        button $w.buttons.dismiss  -text Cancel -command "destroy $u"
        button $w.buttons.ok  -text Ok -command "global valid_remail; set valid_remail 1; destroy $u"

        pack $w.buttons.dismiss -side left -expand 1 -padx 10
        pack $w.buttons.ok -side left -expand 1 -padx 10

        frame $w.sep1 -width 200 -height 2 -borderwidth 1 -relief sunken
        pack $w.sep1 -side bottom -fill x -pady 2m -expand 1

        # Champs de saisie
        # ----------------

        set w $u.char
        frame $w
        grid $w -row 0 -column 1
        grid configure $w -padx 4 -pady 4
        set r 0

        # Type de remaillage
        label $w.label_t1 -text "Regridding method :"
        label $w.label_t2 -relief sunken -text $type_remail
        grid $w.label_t1 $w.label_t2 -row $r -sticky w
        incr r
        # Séparateur
        grid [ frame $w.sep1 -width 200 -height 2 -borderwidth 1 -relief sunken] -row $r -column 0 -pady 5 -columnspan 2
        incr r

        # Suivant le type de remaillage
        switch $type_remail {
            # Si remaillage par la methode des voisins
            "3D Nearest neighbour" -
            "2D Nearest neighbour" {
                label $w.label0 -text "Nbr of neighbours :"
                trace variable nbr_neighbours_m w {entry_forceRegexp {^[0-9]*$} }
                if {$nbr_neighbours_m == 0} {set nbr_neighbours_m 3}
                entry $w.entry0 -relief sunken -width 40 -textvariable nbr_neighbours_m -background white
                grid $w.label0 $w.entry0 -row $r -sticky w
                incr r
            }
            "2D Bicubic" {
                label $w.label0 -text "Bicubic method :"
                combobox_lim $w.comb0 "gradient sixteen" {} bi3_method_m 28 $bi3_method_m
                grid $w.label0 $w.comb0 -row $r -sticky w
                incr r

                # Ajoute une bulle d'aide pour 'Bicubic method'
                set help_text {Either 'gradient' (the four enclosing source neighbour values and gradient values are used), or 'sixteen' (the sixteen enclosing source neighbour values are used).}
                entry_help_balloon $w.comb0 $help_text    
            }
            "2D Conservativ" {
                label $w.label0 -text "Normalisation method :"
                combobox_lim $w.comb0 {None {Fractional area} {Destination area}} {} norm_method_m 28 $norm_method_m
                grid $w.label0 $w.comb0 -row $r -sticky w
                incr r
                label $w.label1 -text "Near neighbour :"
                combobox_lim $w.comb1 "yes no" {} norm_near_nei_m 28 $norm_near_nei_m
                grid $w.label1 $w.comb1 -row $r -sticky w
                incr r

                # Ajoute une bulle d'aide pour 'Normalisation method'
                set help_text {It can be:
· fracarea: The sum of the non-masked source cell intersected areas is used to normalise each target cell field value: the flux is not locally conserved, but the flux value itself is reasonable.

· destarea: The total target cell area is used to normalise each target cell field value even if it only partly intersects non-masked source grid cells: local flux conservation is ensured, but unreasonable flux values may result.

· none: No normalisation is applied.}
                entry_help_balloon $w.comb0 $help_text    
            }
        }
        if { $type_remail != "2D Conservativ" } {
            label $w.label2 -text "If masked :"
            combobox_lim $w.comb2 {{no_value} tneighbour nneighbour} {} if_masked_m 28 $if_masked_m
            grid $w.label2 $w.comb2 -row $r -sticky w
            incr r

            # Ajoute une bulle d'aide pour 'If masked '
            set help_text {Policy applied when some of N nearest neighbour points are masked (N being dependant on the interpolation method):
* novalue: psmile_undef' value (=-280177) is given to the target point;

* tneighbour: the non-masked points among neighbours are used for calculating a weighted average; if all N neighbours are masked, 'psmile_undef' value is given to that target point;

* nneighbour: the non-masked points among neighbours are used for calculating a weighted average; if all N neighbours are masked, the non-masked nearest neighbour is used.}
            entry_help_balloon $w.comb2 $help_text    
        }
        bind $u <Destroy> "help_object_hide"
        tkwait window .remaillage

        # Si la fenêtre est fermée pour la dernière fois
        if {[info exists valid_remail]} {
            # Si on a validé la saisie
            if { $valid_remail } {
                # Sauve les options de remaillage saisies dans une var globale
                global options_remail
                foreach option {nbr_neighbours bi3_method if_masked norm_method norm_near_nei} {
                    set value [set $option\_m]
                    set options_remail($option) $value
                    unset $option\_m
                }
            }
            unset valid_remail
        }
    }
}

ret  {comm_update} (type win , type clef_, type cnx , type exch_, type per_, type unit , type exch_, type per_, type val , type lag , type src_, type time_, type op , type src_, type add_, type val , type src_, type mult_, type val , type dbg_, type source , type stat_, type source_, type mask , type stat_, type source_, type nmsk , type stat_, type source_, type all , type remail , type tgt_, type time_, type op , type tgt_, type add_, type val , type tgt_, type mult_, type val , type dbg_, type cible , type stat_, type cible_, type mask , type stat_, type cible_, type nmsk , type stat_, type cible_, type all , type file_, type packing , type file_, type scaling , type file_, type adding , type file_, type fill_, type value) {
# Variables globales
    global dico_caract_fichiers
    global dico_caract_cnx
    global dico_caract_points
    global dico_cnx_out

    # Vérifie les informations entrées
    if { [comm_validation $exch_per_unit $exch_per_val $remail] } {
        return error
    }

    # Enlever le 's' de pluriel aux unités de temps de la période des échanges
    set exch_per_unit [string range $exch_per_unit 0 end-1]

    # Réinterprète le champ "type de remaillage"
    # ------------------------------------------

    # Liste de descriptions lisibles et de mots-clefs correspondants
    array set remaillages { None {} {3D Nearest neighbour} nneighbour3D {3D Trilinear} trilinear {2D Nearest neighbour} nneighbour2D
        {2D Bilinear} bilinear {2D Bicubic} bicubic {2D Conservativ} conservativ2D }

    # Transforme le mot-clef en description lisible
    if { $remail != "" } { set remail $remaillages($remail) }

    # Réinterprète le champ "source time operation"
    array set mots_clefs { None {} {Time average} taverage {Time accumulation} accumul }
    if { $src_time_op != "" } { set src_time_op $mots_clefs($src_time_op) }

    # Réinterprète le champ "target time operation"
    array unset mots_clefs
    array set mots_clefs { {None (Closest time)} {} {Time interpolation} time_linear }
    if { $tgt_time_op != "" } { set tgt_time_op $mots_clefs($tgt_time_op) }

    # Réinterprète les booléens
    # Pour tous les champs booléens
    foreach nom_champ { dbg_source dbg_cible } {
        set valeur [set $nom_champ]
        if { $valeur != "" } {       
            if {$valeur == "yes"} {set $nom_champ true} else {set $nom_champ false}
        }
    }

    # Enregistre les attributs de la connexion
    # ----------------------------------------

    set dico_caract_cnx($clef_cnx.src_time_op) ""
    set dico_caract_cnx($clef_cnx.src_add_val)  0
    set dico_caract_cnx($clef_cnx.src_mult_val) 1
    set dico_caract_cnx($clef_cnx.tgt_time_op) ""
    set dico_caract_cnx($clef_cnx.tgt_add_val) 0
    set dico_caract_cnx($clef_cnx.tgt_mult_val) 1
    set dico_caract_cnx($clef_cnx.remail) ""

    foreach attrib {exch_per_unit exch_per_val lag dbg_source dbg_cible src_time_op src_add_val src_mult_val
                    remail tgt_time_op tgt_add_val tgt_mult_val
                    stat_source_mask stat_source_nmsk stat_source_all stat_cible_mask stat_cible_nmsk stat_cible_all } {
        set value [set $attrib]
        if { $value != "" } { set dico_caract_cnx($clef_cnx.$attrib) $value }
    }

    # Enregistre les options de remaillage
    global options_remail
    if { $remail != "" } {
        # Réinterprète l'option booléenne norm_near_nei
        if {$options_remail(norm_near_nei) == "yes"} {set options_remail(norm_near_nei) true} else {set options_remail(norm_near_nei) false}
        # Traduit l'option de remaillage conservatif
        switch $options_remail(norm_method) {
            "Fractional area"  { set options_remail(norm_method) fracarea }
            "Destination area" { set options_remail(norm_method) destarea }
        }
        foreach option {nbr_neighbours bi3_method if_masked norm_method norm_near_nei} {
            set dico_caract_cnx($clef_cnx.$option) $options_remail($option)
        }
    }
    array unset options_remail

    # Appli du composant cible
    set appli_cible $dico_caract_cnx($clef_cnx.app_cible)
    # Si la cible est un fichier NetCDF
    if { [string equal $appli_cible "///file///"] } {
        # Identifiant du fichier cible
        set id_fichier $dico_caract_cnx($clef_cnx.comp_cible)
        # Enregistre les attributs du champ du fichier NetCDF
        set dico_caract_fichiers($id_fichier.field.packing) $file_packing 
        set dico_caract_fichiers($id_fichier.field.scaling) $file_scaling 
        set dico_caract_fichiers($id_fichier.field.adding)  $file_adding 
        set dico_caract_fichiers($id_fichier.field.fill_value) $file_fill_value
    }    
    
    catch {destroy .remaillage}; destroy $win
}

ret  {comm_validation} (type exch_, type per_, type unit , type exch_, type per_, type val , type remail) {
# Vérifie les informations entrées dans la boite de dialogue de paramétrisation
# d'une connexion. 
# Retourne 0 si pas d'erreur, 1 sinon.

    # Les options de remaillage
    global options_remail
    
    if {$exch_per_val == "" || $exch_per_unit == "Choose..."} {
        notice_show "Exchange period not filled !" error
        return 1
    }

    # Suivant le type de remaillage
    switch $remail {
        # Si remaillage par la methode des voisins
        "3D Nearest neighbour" -
        "2D Nearest neighbour" {
            if { $options_remail(nbr_neighbours) == "" } {
                notice_show "Regridding option : nbr of neighbours not filled !" error
                return 1
            }
        }
    }

    return 0
}

ret  {component_edit} (type clef_, type comp) {
#
    global dico_applis dico_units

    # Extrait les informations pertinentes
    # ------------------------------------

    set nom_composant $dico_units($clef_comp)
    # Extrait de la clef le nom de l'appli
    set len_comp [string length $nom_composant]
    incr len_comp
    set nom_appli [string range $clef_comp 0 end-$len_comp]
    # Nom long du composant
    set clef_comp_2 app.$nom_appli.comp.$nom_composant
    set nom_long_comp ""
    if {[info exists dico_applis($clef_comp_2.long_name)]} {
        set nom_long_comp $dico_applis($clef_comp_2.long_name)
    }
    #== nb de processus
    set clef_proc $clef_comp_2.proc
    set min_procnumber 0
    catch {set min_procnumber $dico_applis($clef_proc.min_value)}
    set max_procnumber $min_procnumber
    catch {set max_procnumber $dico_applis($clef_proc.max_value)}
    set step_procnumber 1
    catch {set step_procnumber $dico_applis($clef_proc.increment)}
    # Plage du nombre de processus
    if { $max_procnumber != $min_procnumber } {
        if { $step_procnumber != 1 } {
            set procnumber "$min_procnumber to $max_procnumber by step of $step_procnumber"
        } else {
            set procnumber "$min_procnumber to $max_procnumber"
        }
    } else {
        set procnumber $min_procnumber
    }

    # Rang des processus dans l'application
    global min_rank_m min_rank_m_regexp
    global max_rank_m max_rank_m_regexp

    set min_rank_m 0
    catch { set min_rank_m $dico_applis($clef_comp_2.min_rank) }
    set max_rank_m $max_procnumber
    if {$max_procnumber != 0} {incr max_rank_m -1}
    catch { set max_rank_m $dico_applis($clef_comp_2.max_rank) }

    # Cree une boite de dialogue
    # --------------------------

    set u .mod_component
    catch {destroy $u}
    toplevel $u
    wm title $u "Edit component"
    wm iconname $u "Mod_Compt"
    window_position $u 20 20
   
    set w $u.menu
    frame $w
    grid $w -row 2 -column 0
    grid configure $w -columnspan 2 -padx 4 -pady 4

    frame $w.buttons
    pack $w.buttons -side bottom -fill x -pady 2m

    button $w.buttons.dismiss  -text Cancel -command "destroy $u"
    button $w.buttons.ok  -text Ok -command "component_update $u $clef_comp_2 $nom_appli $nom_composant \$min_rank_m \$max_rank_m \$color_m"

    pack $w.buttons.dismiss -side left -expand 1 -padx 10
    pack $w.buttons.ok -side left -expand 1 -padx 10

    frame $w.sep1 -width 200 -height 2 -borderwidth 1 -relief sunken
    pack $w.sep1 -side bottom -fill x -pady 2m -expand 1

    set w $u.char
    frame $w
    grid $w -row 0 -column 1
    grid configure $w -padx 4 -pady 4
    set r 1

#== nom
    label $w.label1 -text "Name:"
    label $w.label11 -relief sunken -text $nom_composant
    grid  $w.label1 $w.label11 -row $r -sticky w
    incr r

#== nom long
    label $w.label2 -text "Long name:"
    label $w.label22 -relief sunken -text $nom_long_comp
    grid  $w.label2 $w.label22 -row $r -sticky w
    incr r

#== nb process
    label $w.label3 -text "Number of Processes :"
    label $w.label33 -relief sunken -text $procnumber
    grid  $w.label3 $w.label33 -row $r -sticky w
    incr r

    grid [ frame $w.sep1 -width 430 -height 2 -borderwidth 1 -relief sunken] -row $r -column 0 -pady 5 -columnspan 2
    incr r

#== rang des processus dans l'application
    label $w.label4 -text "Ranks of Process :"  -fg #ee3333
    frame $w.frrank
    trace variable min_rank_m w {entry_forceRegexp {^[0-9]*$} }
    trace variable max_rank_m w {entry_forceRegexp {^[0-9]*$} }
    pack [entry $w.frrank.e1 -textvariable min_rank_m -width 10 -background white] -side left
    pack [label $w.frrank.l1 -text " to "] -side left -padx 2
    pack [entry $w.frrank.e2 -textvariable max_rank_m -width 10 -background white] -side left -padx 2
    grid $w.label4 $w.frrank -row $r -sticky w
    incr r
    
#== couleur
    global color_m
    set color_m $dico_units($clef_comp.colour)
    label $w.label5 -text "Color :"
    button $w.entry5 -relief sunken -width 20 -text $color_m -background $color_m  -command {
        global color_m
        set color_m [tk_chooseColor -initialcolor $color_m]
        catch {.mod_component.char.entry5 configure -background $color_m}
        }
    grid  $w.label5 $w.entry5 -row $r -sticky w

    # Ajoute une bulle d'aide pour 'min_rank' and 'max_rank'
    set help_text {Enter here the ranks of first and last process of this component as they appear in the application process group.
Process ranks start from 0. Component processes are consecutive.}
    entry_help_balloon $w.frrank $help_text

    # Ajoute une bulle d'aide pour 'color'
    global no_help_balloon
    if { $no_help_balloon == 0 } {
        set help_text {Click here to change the color of the component.}
        set help_action "help_object %W [list $help_text] message"
        bind $w.entry5 <Any-Enter> $help_action
        bind $w.entry5 <FocusIn>   $help_action
        bind $w.entry5 <Any-Leave>    "help_object_hide"
        bind $w.entry5 <FocusOut>     "help_object_hide"
        bind $w.entry5 <ButtonPress>  "help_object_hide"
        
        bind $u <Destroy> "help_object_hide"
    }
}

ret  {entry_help_balloon} (type win , type help_, type text) {
# Programme l'affichage d'un texte d'aide pour la zone de saisie 'win'
    global no_help_balloon

    if { $no_help_balloon == 0 } {
       set help_action "help_object %W [list $help_text] message"
       # Le message d'aide s'affiche quand la souris survole la zone de saisie
       bind $win <Any-Enter> $help_action
       # et quand le curseur entre dans la zone de saisie
       bind $win <FocusIn>   $help_action
       # Le message d'aide disparait quand la souris ne survole plus la zone de saisie
       bind $win <Any-Leave>    "help_object_hide"
       bind $win <FocusOut>     "help_object_hide"
       # ou quand l'utilisateur a frappe une touche
       bind $win <Any-KeyPress> "help_object_hide"
    }
}

ret  {component_update} (type win , type clef_, type comp , type nom_, type appli , type nom_, type composant , type min_, type rank , type max_, type rank , type couleur) {
#
    global dico_applis dico_units

    set min_rank_b $min_rank
    set max_rank_b $max_rank
    if {$min_rank_b > $max_rank_b} {
        set min_rank_b $max_rank
        set max_rank_b $min_rank
    }

    # Nombre de processus de l'application
    catch { set proc_appli $dico_applis(app.$nom_appli.nbr_proc) }
    if { [info exists proc_appli] && $max_rank_b >= $proc_appli } {
      notice_show "invalid rank of process\n must be less than total number of application processes: $proc_appli" error
      return
    }
    
    # Nombre max de processus du composant
    set clef_proc $clef_comp.proc
    set max_procnumber 0
    catch {set max_procnumber $dico_applis($clef_proc.max_value)}
    if { $max_procnumber && $max_rank_b >= $max_procnumber } {
      notice_show "invalid rank of process\n must be less than maximum number of component processes: $max_procnumber" error
      return
    }

    # Met a jour le rang des processus dans l'application
    set dico_applis($clef_comp.min_rank) $min_rank_b
    set dico_applis($clef_comp.max_rank) $max_rank_b
    # Met a jour la couleur
    set clef_comp_1 $nom_appli.$nom_composant
    set dico_units($clef_comp_1.colour) $couleur
    
    catch {destroy $win}
    # Redessine le composant
    Draw_one_unit $clef_comp_1
}

ret  {config_RAZ} () {
# Efface toutes les données de configuration du couplage
#
    global dico_experiment dico_applis
    global liste_points_i liste_points_o dico_caract_points
    global liste_cnx_in dico_cnx_out dico_caract_cnx
    global dico_units
    global liste_fichiers dico_caract_fichiers
    
    array unset dico_experiment *
    array unset dico_applis *
    set liste_points_i {}
    set liste_points_o {}
    array unset dico_caract_points *
    
    set liste_cnx_in {}
    array unset dico_cnx_out *
    array unset dico_caract_cnx *
    
    array unset dico_units *
    set liste_fichiers {}
    array unset dico_caract_fichiers *
}

ret  {config_new} () {
#
# Starts a new coupling configuration
    
    global env
    global dico_applis
    global file_lue

    # S'il y a un couplage a l'ecran (au moins une appli chargee)
    set continuer 1
    set liste_applis {}
    catch { set liste_applis $dico_applis(lapplis) }
    if {[llength $liste_applis]} {
        set rep [tk_messageBox -message "Save current coupling configuration ?" -type yesno -icon question]
        if {$rep == "yes"} {
            set continuer [sauve_tout]
        }
    }

    if { $continuer } {
        # Efface la config du couplage
        config_RAZ
        set file_lue ""
        wm title .gui "OASIS - New configuration"
    
        global entityselected
        control_entity $entityselected
        drawall
    }
}

ret  {config_read} () {
#
# Load a coupling configuration
#
#** Verify that file SCC exists and read its content
#
    global env
    global dico_applis
    global file_lue

    # S'il y a un couplage a l'ecran (au moins une appli chargee)
    set continuer 1
    set liste_applis {}
    catch { set liste_applis $dico_applis(lapplis) }
    if {[llength $liste_applis]} {
        set rep [tk_messageBox -message "Save current coupling configuration ?" -type yesno -icon question]
        if {$rep == "yes"} {
            set continuer [sauve_tout]
        }
    }

    set file ""
    if { $continuer } {
        set tk_strictMotif 1
        set types {
            {{Coupling configuration} {scc.xml}}
        }
        set file [tk_getOpenFile -initialfile scc.xml -title "Load coupling configuration scc.xml"  -filetypes $types ]
    }
    if {$file == ""} {return}

#
#** Lecture du fichier .XML
#
    if {[file exists $file]} {
        .gui configure -cursor watch
        update
        # Efface la config du couplage
        config_RAZ
        set erreur [lit_fichier_SCC $file]
        .gui configure -cursor ""
        
        if {! $erreur } {
            set file_lue $file
            wm title .gui "OASIS - $file"
        
            global entityselected
            control_entity $entityselected
            drawall
        } else {
            # Efface les traces d'une config qui serait lue de façon incomplète
            config_RAZ
        }
    }
}

ret  {sauve_tout} () {
    
    # Sauve le SCC.xml
    set res_list [sauve_scc]
    set result [lindex $res_list 0]

    # Si la sauvegarde du SCC s'est bien passée
    if {$result != 0} {
        # Répertoire où on a sauvé le SCC
        set dir_name [lindex $res_list 1]
        # Sauve les SMIOC
        set result [sauve_smioc $dir_name]
     }
     return $result
}

ret  {sauve_scc} () {
# Génère les fichiers XML de configuration d'un couplage :
#  - le fichier SCC.XML
#
    global dico_applis
    global dico_units

    set result 1
    set dir_name ""

    # Vérifie qu'il y a au moins un composant ou un fichier NetCDF chargé en mémoire
    set liste_comp [array names dico_units]
    if { [llength $liste_comp] > 0 } {
        # Génere le texte XML pour le fichier SCC.xml
        set texte_xml [genere_SCC]
        
        # Si génération possible
        if {$texte_xml != ""} {

            # Sauve le texte dans un fichier scc.xml
            # Demande le choix du répertoire

            set dir_name [tk_chooseDirectory -title "directory where to save file scc.xml" -mustexist yes]
            if {$dir_name != ""} {

                set nom_fichier_SCC [file join $dir_name scc.xml]           
                set continuer yes
                # Si le fichier existe déjà
                if { [file exists $nom_fichier_SCC] } {
                    # Affiche un message d'avertissement
                    set continuer [tk_messageBox -message "Overwrite existing file \"$nom_fichier_SCC\" ?" -type yesno -icon question]
                }
                if {$continuer == "yes"} {

                    set fichier_XML [open $nom_fichier_SCC w]
                    puts $fichier_XML $texte_xml
                    close $fichier_XML
                    # if {$si_erreur} { file delete $nom_fichier_SCC }

                    # Si la sauvegarde s'est bien passée
                    if {$result != 0} {
                        # Sauve les parametres graphiques des composants du couplage dans un fichier XML 
                        # ------------------------------------------------------------------------------
                        
                        # Cree un fichier appelé Graphics.xml dans le même répertoire que le fichier SCC.XML
                        set nom_fichier_graphics [file join $dir_name Graphics.xml]
                        set fichier_XML [open $nom_fichier_graphics w]
                        # Remplit le fichier du texte XML
                        puts $fichier_XML [genere_graphics_XML]
                        close $fichier_XML
                    }
                } else {
                    set result 0
                }
            } else {
                set result 0
            }
        } else {
            set result 0
        }
    }
    
    return [list $result $dir_name]
}

ret  {sauve_smioc} (optional dir_name ="") {

    # Variables globales
    global dico_applis
    global dico_units

    set result 1

    # Vérifie qu'il y a au moins un composant ou un fichier NetCDF chargé en mémoire
    set liste_comp [array names dico_units]
    if { [llength $liste_comp] > 0 } {
    
        # Génère les SMIOC de tous les composants chargés en mémoire
        # ----------------------------------------------------------
        if {$dir_name == ""} {
            set dir_name [tk_chooseDirectory -title "directory where to save file SMIOC.xml" -mustexist yes]
        }
        if {$dir_name != ""} {
            # Pour toutes les applications chargées en mémoire
            foreach nom_appli $dico_applis(lapplis) {
                # Pour tous les composants de cette application
                foreach nom_composant $dico_applis(app.$nom_appli.lcomp) {
                    # Détermine le nom du fichier SMIOC (dans le même répertoire que le fichier SCC)
                    set nom_fichier [file join $dir_name $nom_appli\_$nom_composant\_smioc.xml]
                    set continuer yes
                    # Si le fichier existe déjà
                    if { [file exists $nom_fichier] } {
                        # Affiche un message d'avertissement
                        set continuer [tk_messageBox -message "Overwrite existing file \"$nom_fichier\" ?" -type yesno -icon question]
                    }
                    if {$continuer == "yes"} {
                        # Ecrit dans le fichier XML
                        set fichier_XML [open $nom_fichier w]
                        puts $fichier_XML [genere_SMIOC $nom_appli $nom_composant]
                        close $fichier_XML
                    } else {
                      set result 0
                      break
                    }
                }
                # Si un composant n'a pas été sauvegardé
                if {$result == 0} {
                    # Annule tout
                    break
                }
            }
            return $result
        } else {
            return 0
        }
    } else {
        return 0
    }
}

ret  {control_delete_entity} () {
#
    global entityselected
    global objectselected

    switch $entityselected {
        CONNECTION {
            # Si une connexion est sélectionnée
            if {$objectselected != ""} {
                comm_delete $objectselected
                set objectselected ""
            }
        }
        COUPLING_FIELD {
            # Les champs ne peuvent pas être supprimés
        }
        FILE {
            # Si un fichier est sélectionné
            if {$objectselected != ""} {
                NetCDF_file_delete $objectselected
                set objectselected ""
            }
        }
        COMPONENT {
            # a completer
        }
    }
}

ret  {control_edit_entity} () {
# action sur le bouton edit
    global entityselected
    global objectselected tagselected oldcolor
    global dico_units

    switch $entityselected {
        CONNECTION {
            # Si une connexion est sélectionnée
            if {$objectselected != ""} {
                comm_edit $objectselected
            }
        }
        FILE {
            # Si un fichier est sélectionné
            if {$objectselected != ""} {
                set id_fichier $dico_units($objectselected)
                # Permet la modif des param. de ce fichier
                NetCDF_file_edit $id_fichier
                tkwait window .mod_file

                # Le nom ou la couleur ont pu changer : raffiche le fichier sur le graphe
                set clef ///file///.$id_fichier
                Draw_one_unit $clef
        
                # Remet la couleur de l'objet sélectionné
                set w .gui.pr.cpd22.03
                set oldcolor [$w itemcget $tagselected  -fill ]
                $w itemconfigure $tagselected -fill red
            }
        }
        COUPLING_FIELD {
            # a completer
        }
        COMPONENT {
            # Si un composant est sélectionné
            if {$objectselected != ""} {
                # Si c'est un composant d'application
                if { [info exists dico_units($objectselected)] } {
                    component_edit $objectselected
                    catch {tkwait window .mod_component}
                
                    # La couleur a pu changer : raffiche le composant sur le graphe
                    Draw_one_unit $objectselected
                    # Remet la couleur de l'objet sélectionné
                    set w .gui.pr.cpd22.03
                    set oldcolor [$w itemcget $tagselected  -fill ]
                    $w itemconfigure $tagselected -fill red
                } else {
                    application_edit $objectselected
                    catch {tkwait window .mod_appli}
                }
            }
        }
    }
}

ret  {control_entity} (type entity , optional element ={)} {
# reinitialise la multi-lisbox en fonction de l'entity

    global dico_units
    global objectselected tagselected oldcolor
    global entityselected
    global orderentity
    global ordertri
    global entity_id

    # Si changement de type d'entités affichées
    if { $entity != $entityselected } {
    
        /*  Si il y avait un autre élément sélectionné (a part les points de couplage)*/
        if {$tagselected != ""} {
            /*  Désélectionne cet élément sur le graphe*/
             w =  .gui.pr.cpd22.03
            $w itemconfigure $tagselected -fill $oldcolor
        }
    }
     entityselected =  $entity

    /*  Détermine la liste des lignes de la Multi-list-box*/
    switch $entity {
        COMPONENT    {
            /*  Numero du bouton radio*/
             entity = _id 0
            /*  Titre des colonnes*/
             listopt =  {application component "long name" "start mode" "coupling mode" "nb ret esses"}
            # Contenu de la multiliste
            set loclist [liste_tous_composants]
        }
        FILE      (
            # type Numero , type du , type bouton , type radio
            , type set , type entity_, type id 3
            # , type Titre , type des , type colonnes
            , type set , type listopt , optional name ="io direction" ="io mode" ="suffix"
            # , type Contenu , type de , type la , type multiliste
            , type set , type loclist [, type liste_, type tous_, type fichiers]
        )
        COUPLING_FIELD        {
            # Numero du bouton radio
            set entity_id 1
            # Titre des colonnes
            set listopt {name "long name" application component type datatype "I/O"}
            # Contenu de la multiliste
            set loclist [liste_points_de_couplage]
        }
        CONNECTION {
            /*  Numero du bouton radio*/
             entity = _id 2
            /*  Titre des colonnes*/
             listopt =  {from "from component" to "to component" type datatype}
            /*  Contenu de la multiliste*/
             loclist =  [liste_toutes_connexions]
        }
        default {
             entity = _id 0
             listopt =  {}
             loclist =  {}
        }
    }

    /* ** clear list*/
     w =  .gui.pr.toolframe.cpd18.01
    /* ==destruction des colonnes*/
    foreach col [$w column names] {
        $w column delete $col
    }
    $w delete 0 end

    /*  Initialise la largeur des colonnes*/
     nbcol =  [llength $listopt]
    for { i =  0} {$i < $nbcol} {incr i} { lenmax = ($i) [string length [lindex $listopt $i]]}

    /*  Calcul de la largeur max des colonnes*/
    foreach elm $loclist {
         i =  0
        foreach col $elm {
            if { $i < $nbcol } {
                 longueur =  [string length $col]
                if { [string is upper $col] } {
                     longueur =  [expr $longueur * 10 / 8]
                }
                if {$longueur > $lenmax($i)} { lenmax = ($i) $longueur}
            }
            incr i
        }
    }

    /*  tri de la liste en fonction du critère*/
    if { $entity != "COMPONENT" } {
         loclist =  [lsort -dictionary -index $orderentity($entity) $loclist]
    }

    /*  creation des colonnes*/
    for { j =  0} {$j < $nbcol} {incr j} {
         col =  [lindex $listopt $j]
         nom = _col [string map { " " "-" } $col]
        $w column add $nom_col -label $col -width [expr $lenmax($j)+1]
        if {[MOD $j 2] == 0} {$w column configure $nom_col -background grey95}
        /* =======tri*/
        $w label bind $nom_col  <ButtonPress-1> " orderentity = ($entityselected) $j ; control_entity $entityselected "
    }

    /*  Insere les éléments*/
    foreach elm $loclist {
       $w insert end [lrange $elm 0 end-1]
    }

    /*  Mémorise l'ordre des éléments*/
    array un ordertri = 
     i =  0
    foreach elm $loclist {
         clef =  [lrange $elm end end]
         ordertri = ($clef) $i
        incr i
    }

    .gui.pr.toolframe.buttonfrc.deleteb configure -state disabled
    .gui.pr.toolframe.buttonfrc.editb configure -state disabled

    /*  Si il y a un élément de la liste a sélectionner*/
    if {$element != ""} {
        /*  Sélectionne cet élément*/
        $w selection  $ordertri = ($element)
        $w yview $ordertri($element)

        switch $entity {
            COMPONENT    {
                /*  Dans le futur, on pourra supprimer des composants : s'ils sont optionnels*/
                .gui.pr.toolframe.buttonfrc.deleteb configure -state disabled
                .gui.pr.toolframe.buttonfrc.editb configure -state normal
            }
            COUPLING_FIELD        {
                /*  Ni edition ni suppression des champs*/
                .gui.pr.toolframe.buttonfrc.deleteb configure -state disabled
                .gui.pr.toolframe.buttonfrc.editb configure -state disabled
            }
            FILE   -
            CONNECTION {
                .gui.pr.toolframe.buttonfrc.deleteb configure -state normal
                .gui.pr.toolframe.buttonfrc.editb configure -state normal
            }
        }
    }
}

ret  {control_entity_selected} () {
# Met a jour la liste des éléments dans la fenetre de gauche

    global entityselected objectselected tagselected
    if {![info exists entityselected]} {return}
    
    # Teste si l'element selectionne sur le graphe existe toujours
    set w .gui.pr.cpd22.03
    set selection [$w find withtag $tagselected]
    
    # Si l'élément selectionne sur le graphe existe toujours
    if { $selection != "" } {
        # Met a jour la liste en gardant l'élément sélectionné
        control_entity $entityselected $objectselected
    } else {
        # Met a jour la liste
        control_entity $entityselected 
    }
}

ret  {control_entity_selectionChanged} (type w , type args) {
#
    global dico_units
    global entityselected objectselected tagselected oldcolor
    global ordertri

    if { [$w curselection] == "" } {
        # pass
    } else {
        switch $entityselected {
            COMPONENT    {
                # Dans le futur, on pourra supprimer des composants : s'ils sont optionnels
                .gui.pr.toolframe.buttonfrc.deleteb configure -state disabled
                .gui.pr.toolframe.buttonfrc.editb configure -state normal
            }
            COUPLING_FIELD        {
                # Ni edition ni suppression des champs
                .gui.pr.toolframe.buttonfrc.deleteb configure -state disabled
                .gui.pr.toolframe.buttonfrc.editb configure -state disabled
            }
            FILE -
            CONNECTION {
                .gui.pr.toolframe.buttonfrc.deleteb configure -state normal
                .gui.pr.toolframe.buttonfrc.editb configure -state normal
            }
        }

        # Recherche la connexion selectionnée
        set rang_selection [$w curselection]

        foreach {clef rang} [array get ordertri] {
            if { $rang == $rang_selection } { break }
        }

        # Met a jour la sélection sur le graphe
        set w .gui.pr.cpd22.03
        # Si il y avait un autre objet selectionne
        if {$tagselected != ""} {
            # Deselectionne ce composant sur le graphe
            $w itemconfigure $tagselected -fill $oldcolor
        }
        set tagselected ""

        # Selon le type d'objets listes
        switch $entityselected {
            # Applis et composants
            COMPONENT    {
                # Si c'est un composant d'application
                if { [info exists dico_units($clef)] } {
                    set tagselected unitpoint_color($clef)
                } else {
                    # C'est une application : rien à sélectionner sur le graphe
                    set tagselected ""
                }
                set objectselected $clef
            }
            FILE   {
                set tagselected unitpoint_color($clef)
                set objectselected $clef
            }
            COUPLING_FIELD        {
            }
            CONNECTION {
                set tagselected tag_fils_connexions($clef)
                set objectselected $clef
            }
        }

        # Si un objet est selectionne sur le graphe
        if { $tagselected != "" } {
            # Change la couleur de l'objet sélectionné sur le graphe
            set oldcolor [$w itemcget $tagselected  -fill ]
            $w itemconfigure $tagselected -fill red
        }
    }
}

ret  {date_is_valid_date} (type nom_, type date) {
# Teste si une date est valide
    # "nom_date" est le nom d'une var globale de type array
    upvar \#0 $nom_date date
    
    set msg ok
    # Recopie les infos de la date (a cause de l'instruction "trace" sur la var globale de nom "$nom_date")
    foreach {name value} [array get date] {
        set new_date($name) $value
    }
    
    if {$new_date(year)   == ""} {set new_date(year) 0}
    if {$new_date(month)  == ""} {set new_date(month) 1}
    if {$new_date(day)    == ""} {set new_date(day) 1}
    if {$new_date(hour)   == ""} {set new_date(hour) 0}
    if {$new_date(minute) == ""} {set new_date(minute) 0}
    if {$new_date(second) == ""} {set new_date(second) 0}
    
    switch [date_nb_days_in_year $new_date(year)] {
        366 {     
            set daylist [list 31 29 31 30 31 30 31 31 30 31 30 31]
        } 
        365 {
            set daylist [list 31 28 31 30 31 30 31 31 30 31 30 31]
        }
        360 {
            set daylist [list 30 30 30 30 30 30 30 30 30 30 30 30]
        }
    }
    if {$new_date(second) < 0 } {set msg "negative second"}
    if {$new_date(second) > 60} {set msg "second > 60"}
    if {$new_date(minute) < 0 } {set msg "negative minute"}
    if {$new_date(minute) > 60} {set msg "minute > 60"}
    if {$new_date(hour)   <  0} {set msg "negative hour"}
    if {$new_date(hour)   > 24} {set msg "hour > 24"}
    if {$new_date(month)  > 12} {set msg "month > 12"}
    if {$new_date(month)  < 1 } {set msg "negative month "}
    if {$new_date(year)   < 0 } {set msg "negative year "}
    
    set maxday [lindex $daylist [expr $new_date(month) -1 ]]
    if {$new_date(day) > $maxday} {set msg "invalid day "}
    
    return $msg
}

ret  {date_nb_days_in_year} (type year) {
# Détermine le nombre de jours dans une année donnée
    set calendar STANDARD
    
    switch $calendar  {
    STANDARD {
        if {[expr $year/4.] == [expr int($year/4.)]} {
        set nb_days 366
        if {[expr $year/100.] == [expr int($year/100.)]}   {set nb_days 365}
        if {[expr $year/400.] == [expr int($year/400.)]}   {set nb_days 366}
        } else {
        set nb_days 365
        }
    }
    NOLEAP {
        set nb_days 365
    }
    360 {
        set nb_days 360
    }
    JULIAN {
        if {[expr $year/4.] == [expr int($year/4.)]} {
        set nb_days 366
        } else {
        set nb_days 365
        }
    }
    }
    return $nb_days
}

ret  {demi_chemin_1} (type x1 , type y1 , type xm , type ym , type cote , type clef_, type source) {
# Calcule le chemin du composant source au point milieu (xm, ym)
    #   - cote :        vaut bas, droit ou gauche : il indique le côté par lequel on approche le point milieu
    #   - clef_source : clef d'acces au composant source
        global dico_units
        global DRAW
    
        #=========de dessous a dessus
        if { $cote == "bas" } {
        
            # Quitte le point source par le dessous
            set y10 [expr $y1 +17 ]
            # Fait le tour du coin inferieur du composant source
            set coin_y [expr $dico_units($clef_source.coor_y) + $DRAW(heigthunit) + 17]
            if { $coin_y < $ym + 17 } {
                set coin_y [expr $ym + 17]
            }

            set milieu_x [expr ($x1 + $xm) / 2]
            # Si on va de gauche a droite
            if { $x1 < $xm } {
                # Fait le tour du coin inferieur droit du composant source
                set coin_x [expr $dico_units($clef_source.coor_x) + $dico_units($clef_source.largeur) + 17]
                # if { $coin_x < $milieu_x } { set coin_x $milieu_x }
                if { $coin_x < $xm } { set coin_x $xm }
            } else {
                # Fait le tour du coin inferieur gauche du composant source
                set coin_x [expr $dico_units($clef_source.coor_x) - 17]
                # if { $coin_x > $milieu_x } { set coin_x $milieu_x }
                if { $coin_x > $xm } { set coin_x $xm }
            }
            
            if { $coin_x == $xm } {
                return "$x1 $y1 $x1 $y10 $coin_x $coin_y $xm $ym"
            } else {
                # Approche le point milieu par le dessous
                set xm1 $xm
                set ym1 [expr $ym +20]
                
                return "$x1 $y1 $x1 $y10 $coin_x $coin_y $xm1 $ym1 $xm $ym"
            }
        
        #=========de dessus a dessous
        } else {
            # Approche le point milieu par le coté gauche ou droit
            if { $cote == "gauche" } {
                # Approche le point milieu par la gauche
                set xm1 [expr $xm -20]
            } else {
                set xm1 [expr $xm +20]
            }
            set ym1 $ym
            # Quitte le point source par le dessous
            set y10 [expr $y1 +17 ]
            return "$x1 $y1 $x1 $y10 $xm1 $ym1 $xm $ym"
        }
}

ret  {demi_chemin_2} (type xm , type ym , type x2 , type y2 , type cote , type clef_, type cible) {
# Calcule le chemin du point milieu (xm, ym) au composant cible
    #   - cote :        vaut bas, droit ou gauche : il indique le côté par lequel on approche le point milieu
    #                   == le côté opposé de celui par lequel on quitte
    #   - clef_cible : clef d'acces au composant cible
        global dico_units
        global DRAW
        #=========de dessous a dessus
        if { $cote == "bas" } {
        
            # Fait le tour du coin superieur du composant cible
            set coin_y [expr $dico_units($clef_cible.coor_y) - 17]
            if { $coin_y > $ym - 17 } {
                set coin_y [expr $ym - 17]
            }
            
            set milieu_x [expr ($xm + $x2) / 2]
            # Si on va de gauche a droite
            if { $xm < $x2 } {
                # Fait le tour du coin superieur gauche du composant cible
                set coin_x [expr $dico_units($clef_cible.coor_x) - 17]
                # if { $coin_x > $milieu_x } { set coin_x $milieu_x }
                if { $coin_x > $xm } { set coin_x $xm }
            } else {
                # Fait le tour du coin superieur droit du composant cible
                set coin_x [expr $dico_units($clef_cible.coor_x) + $dico_units($clef_cible.largeur) + 17]
                # if { $coin_x < $milieu_x } { set coin_x $milieu_x }
                if { $coin_x < $xm } { set coin_x $xm }
            }
            #  Arrive à dest. par le dessus
            set y20 [expr $y2 - 17]
            
            if { $coin_x == $xm } {
                return "$xm $ym $coin_x $coin_y $x2 $y20 $x2 $y2"
            } else {
                # Quitte le point milieu par le dessus
                set xm1 $xm
                set ym1 [expr $ym -20]
                return "$xm $ym $xm1 $ym1 $coin_x $coin_y $x2 $y20 $x2 $y2"
            }
            
        #=========de dessus a dessous
        } else {
            # Quitte le point milieu par le coté gauche ou droit
            if { $cote == "gauche" } {
                # Quitte le point milieu par la droite
                set xm1 [expr $xm +20]
            } else {
                set xm1 [expr $xm -20]
            }
            set ym1 $ym
            #  Arrive à dest. par le dessus
            set y20 [expr $y2 - 17]
            return "$xm $ym $xm1 $ym1 $x2 $y20 $x2 $y2"
        }
}

ret  {dialog_controls} (type win) {
return "$win.controls"
}

ret  {dialog_create} (type class , optional win =auto) {
#
    if {$win == "auto"} {
        set count 0
        set win ".dialog[incr count]"
        while {[winfo exists $win]} {
            set win ".dialog[incr count]"
        }
    }
    catch {destroy $win}
    toplevel $win -class $class

    frame $win.info
    pack $win.info -expand yes -fill both -padx 4 -pady 4

    frame $win.sep -height 2 -borderwidth 1 -relief sunken
    pack $win.sep -fill x -pady 4

    frame $win.controls
    pack $win.controls -fill x -padx 4 -pady 4

    wm title $win $class
    wm group $win .

    after idle [format {
        update idletasks
        wm minsize %s [winfo reqwidth %s] [winfo reqheight %s]
    } $win $win $win]

    return $win
}

ret  {dialog_info} (type win) {
return "$win.info"
}

ret  {dialog_safeguard} (type win) {
if {[lsearch [bindtags $win] modalDialog] < 0} {
        bindtags $win [linsert [bindtags $win] 0 modalDialog]
    }
}

ret  {dialog_wait} (type win , type varName) {
#
    dialog_safeguard $win

    set x [expr [winfo rootx .]+50]
    set y [expr [winfo rooty .]+50]
    wm geometry $win "+$x+$y"

    wm deiconify $win
    grab set $win

    vwait $varName

    grab release $win
    wm withdraw $win
}

ret  {distmin} (type x1 , type y1 , type x2 , type y2) {
global DRAW
        set dist [expr sqrt(($x2-$x1)*($x2-$x1)+($y2-$y1)*($y2-$y1))]
        if {$dist < $DRAW(maxi_line_size)} {return 1} else {return 0}
}

ret  {distming} (type x1 , type y1 , type x2 , type y2) {
global DRAW
        set dist [expr sqrt(($x2-$x1)*($x2-$x1)+($y2-$y1)*($y2-$y1))]
        if {$dist < $DRAW(grouped_maxi_line_size)} {return 1} else {return 0}
}

ret  {draw_print} () {
#
#
#**** draw_print - print the canvas
#
#     Purpose:
#     --------
#     This tcl/tk script print the canvas directly to a pinter
#     or to a postcripts file
#
#     Interface:
#     ----------
#         draw_print
#
#***  Externals:
#     ----------
#     This code uses Tcl/Tk
#
#     References:
#     -----------
#     Effective Tcl/Tk Programming, M. Harrison and M. McLennan,
#     Addison-Wesley professional computing series, 1998
#
#     History:
#     -------
#       Version   Programmer     Date        Description
#       -------   ----------     ----        -----------
#       0.0       Julien         1999/08/05       created
#*----------------------------------------------------------------
#
#** Print the canvas in a postcript file
#
#
    set win .gui.pr.cpd22.03

    set x0 0
    set y0 0

    set x1 [winfo width $win]
    set y1 [winfo height $win]

    foreach {x0 y0 x1 y1} [$win bbox all] {}
    set w [expr $x1-$x0]
    set h [expr $y1-$y0]

    return [$win postscript -x $x0 -y $y0 -width $w -height $h]
}

ret  {drawall} () {
#
    global DRAW
    global zoomfactor

    .gui configure -cursor watch

    #-------------------------------------
    #** variables a calculer avant de tracer
    #-------------------------------------
    Draw_set_init_variables

    #-------------------------------------
    #** fenetre d'affichage ,clean
    #-------------------------------------
    set w $DRAW(window)
    $w delete all
    $w dtag all

    #-------------------------------------
    #** affichage des unites
    #-------------------------------------
    Draw_drawunit

    #-------------------------------------
    #** affichage des communications
    #-------------------------------------
    Draw_comm

    #-------------------------------------
    #** bulle aide objet
    #-------------------------------------
    set u .ballon_object
    catch {destroy $u}
    toplevel $u -borderwidth 1 -relief flat
    wm iconify $u
    label $u.text -text "" -background #fefed4 -foreground black -font {helvetica 10} -justify left
    pack $u.text -side left -anchor w
    wm overrideredirect $u 1
    wm withdraw $u

    .gui configure -cursor {}
}

ret  {dump_array} (type nom_, type dico , optional match_expression =*) {
# Pour debug : dump le contenu d'un tableau
    upvar 1 $nom_dico dico
    puts "${nom_dico}($match_expression) :"
    foreach {n v} [array get dico $match_expression] {
        puts "$n : $v"
    }
}

ret  {entryLimit} (type entry , type traceProc , optional init ={)} {
## entryLimit - a convenience proc for managing traces on entry widgets
## Perhaps to make this even nicer, it could create a textvar for the
## user with the name the same as the entry?
# ARGS: entry       - the entry widget to trace
#   traceProc   - trace procedure
#   init        - initial value to use, defaults to {}
/*  If traceProc=={}, then all write traces on the entry's textvar are*/
/*  deleted.  This doesn't delete array traces.*/
/** 
 */


    if [string match {} [ var =  [$entry cget -textvariable]]] {
    return -code error "-textvariable not  for =  entry \"$entry\""
    }

    if {[string compare $traceProc {}]} {
    /*  TextVars are always considered global*/
    uplevel \/* 0 [list set $var $init]*/
    uplevel \/* 0 [list trace variable $var w $traceProc]*/
    if {[catch {uplevel \/* 0 [list set $var $init]} err]} {*/
        /*  If this errors out, the $init value was bad, or*/
        /*  something was wrong with the traceProc*/
        return -code error "an error was received ting =  the initial value of \"$var\" to \"$init\".  Make sure the value is valid and the traceProc is functional:\n$err"
    } else {
        /*  Do you really want to delete the trace when*/
        /*  destroying the entry?*/
        /* bind $entry <Destroy> [list + trace vdelete $var w $traceProc]*/
        return
    }
    }
    foreach p [uplevel \/* 0 [list trace vinfo $var]] {*/
    if {[string match w [lindex $p 0]]} {
        uplevel \/* 0 trace vdelete [list $var] $p*/
    }
    }
}

ret  {entry_forceAlpha} (type name , type el , type op) {
global $name ${name}_alpha
    if [string comp {} $el] {
    set old  ${name}_alpha\($el)
    set name $name\($el)
    } else { set old ${name}_alpha }
    if ![regexp {^[a-zA-Z]*$} [set $name]] {
    set $name [set $old]
    bell; return
    }
    set $old [set $name]
}

ret  {entry_forceInt} (type name , type el , type op) {
global $name ${name}_int
    if [string comp {} $el] {
    set old  ${name}_int\($el)
    set name $name\($el)
    } else { set old ${name}_int }
    if ![regexp {^[-+]?[0-9]*$} [set $name]] {
    set $name [set $old]
    bell; return
    }
    set $old [set $name]
}

ret  {entry_forceInt_min_max} (type min , type max , type name , type el , type op) {
global $name ${name}_int
    if [string comp {} $el] {
    set old  ${name}_int\($el)
    set name $name\($el)
    } else { set old ${name}_int }
    if ![regexp {^[-+]?[0-9]*$} [set $name]] {
    set $name [set $old]
    bell; return
    }
    if {[set $name] != ""} {
       if {[set $name] > $max} {set $name $max}
       if {[set $name] < $min} {set $name $min}
    }
    set $old [set $name]
}

ret  {entry_forceLen} (type len , type name , type el , type op) {
global $name ${name}_len
    if [string comp $el {}] {
    set old  ${name}_len\($el)
    set name $name\($el)
    } else { set old ${name}_len }
    if {[string length [set $name]] > $len} {
    set $name [set $old]
    bell; return
    }
    set $old [set $name]
}

ret  {entry_forceReal} (type name , type el , type op) {
global $name ${name}_real
    if [string comp {} $el] {
    set old  ${name}_real\($el)
    set name $name\($el)
    } else { set old ${name}_real }
    if ![regexp {^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$} [set $name]] {
    set $name [set $old]
    bell; return
    }
    set $old [set $name]
}

ret  {entry_forceReal_min_max} (type min , type max , type name , type el , type op) {
global $name ${name}_int
global $name ${name}_real
    if [string comp {} $el] {
    set old  ${name}_real\($el)
    set name $name\($el)
    } else { set old ${name}_real }
    if ![regexp {^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$} [set $name]] {
    set $name [set $old]
    bell; return
    }
    if {[set $name] != ""} {
       if {[set $name] > $max} {set $name $max}
       if {[set $name] < $min} {set $name $min}
    }
    set $old [set $name]
}

ret  {entry_forceRegexp} (type regexp , type name , type el , type op) {
global $name ${name}_regexp
    if [string comp {} $el] {
    set old  ${name}_regexp\($el)
    set name $name\($el)
    } else { set old ${name}_regexp }
    if ![regexp $regexp [set $name]] {
    set $name [set $old]
    bell; return
    }
    set $old [set $name]
}

ret  {entry_forceValue} (type default , type name , type el , type op) {
global $name
    if [string comp {} $el] { set name $name\($el) }
    if ![info exists $name] { set $name $default }
}

ret  {experiment_settings} () {
# boite de dialogue pour saisir les parametres de l'expérience et du run Oasis

    global dico_experiment dico_applis

    # Prépare les variables à saisir
    global local_name_m long_name_m start_mode_m drv_procs_m
    global expe_start_date expe_end_date
    global run_start_date run_end_date
    
    # Prépare les variables à saisir
    set local_name_m ""
    catch {set local_name_m $dico_experiment(name)}
    set long_name_m ""
    catch {set long_name_m $dico_experiment(long_name)}
    set start_mode_m ""
    catch {set start_mode_m $dico_experiment(start_mode)}
    set drv_procs_m ""
    catch {set drv_procs_m $dico_experiment(drv_procs)}

    # Initialisation des quatres dates
    foreach element { year month day hour minute second } {
        set expe_start_date($element) 1
        catch {set expe_start_date($element) $dico_experiment(start.$element)}
        set expe_end_date($element) 1
        catch {set expe_end_date($element) $dico_experiment(end.$element)}
        set run_start_date($element) 1
        catch {set run_start_date($element) $dico_experiment(run_start.$element)}
        set run_end_date($element) 1
        catch {set run_end_date($element) $dico_experiment(run_end.$element)}
    }
    

    # Liste des modes de démarrage autorisés
    # --------------------------------------
    
    set si_autorise_mode_spawn 1
    set si_autorise_mode_notspawn 1
    
    set liste_applis {}
    catch { set liste_applis $dico_applis(lapplis) }
    foreach nom_appli $liste_applis {
        set start_mode $dico_applis(app.$nom_appli.start_mode)
        switch $start_mode {
            # Si une appli ne marche que dans un mode donné, l'autre mode est interdit pour toutes les autres applis
            spawn     { set si_autorise_mode_notspawn 0 }
            notspawn  { set si_autorise_mode_spawn    0 }
        }
    }
    # Si il y a des restrictions incompatibles .... On n'y peut rien
    set options_start_mode {}
    if { $si_autorise_mode_notspawn } {
        lappend options_start_mode not_spawn
    }
    if { $si_autorise_mode_spawn } {
        lappend options_start_mode spawn
    }
    
    # Crée une boite de dialogue
    set u .set_experiment
    catch {destroy $u}
    toplevel $u
    wm title $u "Experiment settings"
    wm iconname $u "settings"
    window_position $u 200 80

    set w [frame $u.boutons]
    pack $w -side bottom -fill x -pady 2m -padx 2m
    button $w.dismiss -text Cancel -command "destroy $u"
    pack $w.dismiss  -side left -expand 1
    button $w.ok -text Ok -command "experiment_update $u \$local_name_m \$long_name_m \$start_mode_m \$drv_procs_m"
    pack $w.ok  -side left -expand 1
    
    frame $u.sep -width 100 -height 2 -borderwidth 1 -relief sunken
    pack $u.sep -side bottom

    set w [frame $u.char -borderwidth 1 -relief sunken]
    pack $w  -side top -expand 1 -pady 10 -padx 10 -ipadx 3 -ipady 5
    set r 1

#== nom
    label $w.label1 -text "Experiment name: " -fg #ee3333
    entry $w.entry1  -textvariable local_name_m -width 15 -background white
    grid  $w.label1 $w.entry1 -row $r -sticky w
    incr r

    # Ajoute une bulle d'aide pour 'Experiment name'
    set help_text {This entry is mandatory.}
    entry_help_balloon $w.entry1 $help_text

#== Long name
    label $w.label2 -text "Long name : "
    entry $w.entry2  -textvariable long_name_m -width 25 -background white
    grid  $w.label2 $w.entry2 -row $r -sticky w
    incr r

    # Ajoute une bulle d'aide pour 'Long name'
    set help_text {Enter here a description of the experiment.}
    entry_help_balloon $w.entry2 $help_text

#== Start mode
    label $w.label3 -text "Start mode : " -fg #ee3333
    combobox_lim $w.cmb3 $options_start_mode {} start_mode_m 10 $start_mode_m
    grid  $w.label3 $w.cmb3 -row $r -sticky w
    incr r

    # Ajoute une bulle d'aide pour 'Start mode'
    set help_text {Choose the mode into which all applications of the coupled model will be started: either spawn or not spawn, (see User Guide section 3.1); this user’s choice, restricted by the possibilities given in the Application Descriptions, determines the way the applications should be started in the run script.}
    entry_help_balloon $w.cmb3 $help_text

#== nombre de processus du driver
    trace variable drv_procs_m w {entry_forceRegexp {^[0-9]*$} }
    label $w.label4 -text "Number of processes for OASIS driver : " -fg #ee3333
    entry $w.entry4  -textvariable drv_procs_m -width 10 -background white
    grid  $w.label4 $w.entry4 -row $r -sticky w
    incr r

    # Ajoute une bulle d'aide pour 'process number'
    set help_text {Enter the number of processes used for the OASIS4 Driver/Transformer.}
    entry_help_balloon $w.entry4 $help_text


    # Start/End Experiment/Run dates dans un autre cadre en-dessous
    # -------------------------------------------------------------
    
    frame $u.sep2 -width 100 -height 2 -borderwidth 1 -relief sunken
    pack $u.sep2 -side top

    set w [frame $u.char2 -borderwidth 1 -relief sunken]
    pack $w  -side top -expand 1 -pady 10 -padx 10 -ipadx 3 -ipady 5
    set r 0

    # Limitation des valeurs possibles
    foreach date {expe_start_date expe_end_date run_start_date run_end_date} {
        trace variable ${date}(year) w   {entry_forceInt_min_max -500000 500000}
        trace variable ${date}(month) w  {entry_forceInt_min_max 1 12}
        trace variable ${date}(day) w    {entry_forceInt_min_max 1 31}
        trace variable ${date}(hour) w   {entry_forceInt_min_max 0 24}
        trace variable ${date}(minute) w {entry_forceInt_min_max 0 60}
        trace variable ${date}(second) w {entry_forceReal_min_max 0 60}
    }

    # Organise la saisie des quatre dates sur quatre lignes
    #    avec les années, mois, jours, etc... disposés en colonnes
    
    # Titre des colonnes        
    label $w.l11 -text "Year:"
    label $w.l12 -text "Month:"
    label $w.l13 -text "Day:"
    label $w.l14 -text "Hour:"
    label $w.l15 -text "Minute:"
    label $w.l16 -text "Second:"
    # Disposition des titres sur la première ligne
    for {set i 1} {$i <= 6} {incr i} {
        grid $w.l1$i  -row $r -column $i -pady 2 -padx 4 -sticky w
    }
    incr r

    # Crée les zones de saisie
    foreach date {expe_start_date expe_end_date run_start_date run_end_date} {
        foreach {rank time_unit} {1 year 2 month 3 day 4 hour 5 minute 6 second} {
            entry $w.${date}a$rank -textvariable ${date}($time_unit) -width 7 -background white -justify right

            frame $w.${date}fram$rank
            button $w.${date}fram$rank.plus  -text "+" -padx 2m -pady 0  -font "helvetica -10 bold" -command "increment_date ${date} $time_unit  1"
            button $w.${date}fram$rank.moins -text "-"  -padx 2m -pady 0 -font "helvetica -10 bold" -command "increment_date ${date} $time_unit -1"
        }

        # Disposition des champs en colonnes
        for {set i 1} {$i <= 6} {incr i} {
            grid $w.${date}a$i   -row $r -column $i -pady 0 -padx 4 -sticky w
        }
        incr r
        # Disposition des boutons "+" "-" en colonnes
        for {set i 1} {$i <= 6} {incr i} {
            grid $w.${date}fram$i -row $r -column $i 
            pack $w.${date}fram$i.moins -side left -pady 0 -padx 0 
            pack $w.${date}fram$i.plus -side right -pady 0 -padx 0 
        }
        incr r
        
        # Saute une ligne entre les dates de "Experiment" et les dates du "Run"
        if {$r == 5} {set r 6}
    }
    
    # La ligne 5 est vide : on lui donne une hauteur minimum
    grid rowconfigure $w 5 -minsize 40
    
    # Titre des lignes
    set r 1
    foreach {abbrev titre} { e_start "Experiment start date" e_end "Experiment end date" } {
        label $w.$abbrev -text $titre  -anchor w  -width 20
        # Disposé en colonne 0
        grid $w.$abbrev  -row $r -column 0
        incr r 2
    }
    incr r
    foreach {abbrev titre} { r_start "Run start date" r_end "Run end date" } {
        label $w.$abbrev -text $titre  -anchor w  -width 20
        # Disposé en colonne 0
        grid $w.$abbrev  -row $r -column 0
        incr r 2
    }

    # Ajoute une bulle d'aide pour 'Run start and end date'
    array set help_text_array {
        run_start_date
        {Enter the start date of the run; the start date has to correspond to the lower bound of the time interval which is represented by the first time step of the run.}
        run_end_date
        {Enter the end date of the run; the end date has to correspond to the upper bound of the time interval which is represented by the last time step of the run. Note that the end date of the current run has to be used as start date for the subsequent run.} 
    }
    
    foreach date {run_start_date run_end_date} {
        for {set i 1} {$i <= 6} {incr i} {
            entry_help_balloon $w.${date}a$i $help_text_array($date)
        }
    }
}

ret  {experiment_update} (type win , type local_, type name , type long_, type name , type start_, type mode , type drv_, type procs) {
# Valide la saisie des paramètres de l'expérience et du run
    global dico_experiment dico_applis
    
    global expe_start_date expe_end_date
    global run_start_date run_end_date

    # Experiment name is required
    if {$local_name == ""} {
        notice_show "Experiment name is required !" error
        focus .set_experiment.entry1
        return error
    }
    
    # Teste les quatres dates saisies
    foreach {date_var_name date_long_name} {expe_start_date "Experiment start date" 
        expe_end_date "Experiment end date" run_start_date "Run start date" run_end_date "Run end date" } {
        set msg [date_is_valid_date $date_var_name]
        if { $msg != "ok" } {
            notice_show "$date_long_name is invalid !" error
            focus .set_experiment.char2.${date_var_name}a1
            return error
        }
    }
           
    # Sauve en mémoire toutes les valeurs saisies
    set dico_experiment(name) $local_name
    set dico_experiment(long_name) $long_name
    set dico_experiment(start_mode) $start_mode
    set dico_experiment(drv_procs) $drv_procs

    # Sauve en mémoire les quatres dates
    foreach element { year month day hour minute second } {
        set dico_experiment(start.$element)     $expe_start_date($element)
        set dico_experiment(end.$element)       $expe_end_date($element)
        set dico_experiment(run_start.$element) $run_start_date($element)
        set dico_experiment(run_end.$element)   $run_end_date($element)
    }
    
    destroy $win
}

ret  {font_view_update} (optional font ={) {dummy {}}} {
global dxf
   cur = _font [get_cur_font]
  .choose_font.view configure -font "$cur_font"
  .choose_font.view configure  -foreground $dxf(choose_font_cb_color)
}

ret  {genere_SCC} () {
# Génère le texte du fichier SCC.XML au format XML, bien entendu
#
    global dico_experiment
    global dico_applis
    global dico_units
    global oasis4_version

    # Texte retourné par la procédure
    set texte_xml ""

    # Vérifie qu'il y a au moins un composant ou un fichier NetCDF chargé en mémoire
    set liste_comp [array names dico_units]
    if { [llength $liste_comp] > 0 } {
        # Si toutes les infos générales nécessaires sont renseignées
        if {   [info exists dico_experiment(name)]
            && [info exists dico_experiment(start_mode)]
            && [info exists dico_experiment(drv_procs)]
            && [info exists dico_experiment(start.year)]
            && $dico_experiment(name) != ""
            && $dico_experiment(drv_procs) != ""  } {
                        
            # Vérifie la compatibilité des applis avec le mode de lancement choisi
            # --------------------------------------------------------------------
            
            # Analyse le mode de démarrage requis par les applications
            set si_autorise_mode_notspawn 1
            set si_autorise_mode_spawn    1
            set liste_applis $dico_applis(lapplis)
            foreach nom_appli $liste_applis {
                set start_mode $dico_applis(app.$nom_appli.start_mode)
                switch $start_mode {
                    # Si une appli ne marche que dans un mode donné, l'autre mode est interdit pour toutes les autres applis
                    spawn     { set si_autorise_mode_notspawn 0 }
                    notspawn  { set si_autorise_mode_spawn    0 }
                }
            }
            
            # Recherche une incompatibilité éventuelle
            set si_erreur 0
            switch $dico_experiment(start_mode) {
                spawn {
                    if {$si_autorise_mode_spawn == 0} {set si_erreur 1}
                }
                not_spawn {
                    if {$si_autorise_mode_notspawn == 0} {set si_erreur 1}
                }
            }
            
            # Si erreur, message d'erreur
            if {$si_erreur} {
                notice_show "Experiment start mode ($dico_experiment(start_mode)) is incompatible with one or more application.
Please, change experiment stat mode in menu 'Experiment settings' !"
                return ""
            }
            
            # Recherche le N° de version d'OASIS4
            set nom_appli [lindex $liste_applis 0]
            set oasis4_version OASIS4_0_2
            if {[info exists dico_applis(app.$nom_appli.oasis4_version)] } {
                set oasis4_version  $dico_applis(app.$nom_appli.oasis4_version)
            }
    
            # Crée le document XML
            set doc [dom::DOMImplementation create]
    
            # Crée l'élément SCC racine
            set scc_element [::dom::document createElement $doc scc]
            # Ses attributs
            dom::element setAttribute $scc_element xmlns "http://www.cerfacs.fr/PRISM/XML/1.1"
            dom::element setAttribute $scc_element "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance"
            dom::element setAttribute $scc_element "xsi:schemaLocation" "http://www.cerfacs.fr/PRISM/XML/1.1"
            dom::element setAttribute $scc_element oasis4_version $oasis4_version
    
            # Crée l'élément "experiment"
            set experiment_elt [::dom::document createElement $scc_element experiment]
            # Ses attributs
            dom::element setAttribute $experiment_elt local_name $dico_experiment(name)
            if { [info exists dico_experiment(long_name)] } {
                dom::element setAttribute $experiment_elt long_name $dico_experiment(long_name)
            }
            dom::element setAttribute $experiment_elt start_mode $dico_experiment(start_mode)
            
                # Crée le sous-élément "driver"
                set driver_elt [::dom::document createElement $experiment_elt driver]
                    set node [::dom::document createElement $driver_elt nbr_procs]
                    set nbr_procs $dico_experiment(drv_procs)
                    ::dom::document createTextNode $node $nbr_procs
    
                # Crée le sous-élément "Experiment start date"
                set start_date_elt [::dom::document createElement $experiment_elt start_date]
                genere_element_date $start_date_elt "start"

                # Crée le sous-élément "Experiment end date"
                set end_date_elt   [::dom::document createElement $experiment_elt end_date]
                genere_element_date $end_date_elt "end"
    
            set run_elt [::dom::document createElement $scc_element run]
                # Crée le sous-élément "Run start date"
                set start_date_elt [::dom::document createElement $run_elt start_date]
                genere_element_date $start_date_elt "start"
                # Crée le sous-élément "Run end date"
                set end_date_elt   [::dom::document createElement $run_elt end_date]
                genere_element_date $end_date_elt "end"
    
            # Pour toutes les applications chargées en mémoire
            foreach nom_appli $liste_applis {
                set appli_elt [::dom::document createElement $scc_element application]
    
                # Test si toutes les données sont renseignées
                if {   [info exists dico_applis(app.$nom_appli.executable_name)] 
                    && [info exists dico_applis(app.$nom_appli.redirect)] } {
        
                    # Ses attributs
                    dom::element setAttribute $appli_elt local_name $nom_appli
                    set executable_name $dico_applis(app.$nom_appli.executable_name)
                    set redirect $dico_applis(app.$nom_appli.redirect)
                    dom::element setAttribute $appli_elt executable_name $executable_name
                    dom::element setAttribute $appli_elt redirect $redirect
        
                    # Sous-élément hosts
                    foreach id_host $dico_applis(app.$nom_appli.lhosts) {
                        set host_elt [::dom::document createElement $appli_elt host]
                        # Son attribut local_name
                        dom::element setAttribute $host_elt local_name $dico_applis(app.$nom_appli.host.$id_host.name)
                            set node [::dom::document createElement $host_elt nbr_procs]
                            # Le sous-element nbr_procs
                            set nbr_procs $dico_applis(app.$nom_appli.host.$id_host.nb_procs)
                            ::dom::document createTextNode $node $nbr_procs
                    }
                    # Pour tous les composants de cette application
                    foreach nom_composant $dico_applis(app.$nom_appli.lcomp) {
                        
                        # Test si toutes les données de ce composant sont renseignées
                        if { [info exists dico_applis(app.$nom_appli.comp.$nom_composant.min_rank)] } {
                            # élément component
                            set component_elt [::dom::document createElement $appli_elt component]
                            # Son attribut local_name
                            dom::element setAttribute $component_elt local_name $nom_composant
            
                                # Sous-élément rank
                                set rank_elt [::dom::document createElement $component_elt rank]
                                    # Sous-élément min_value
                                    set node [::dom::document createElement $rank_elt min_value]
                                    set min_value $dico_applis(app.$nom_appli.comp.$nom_composant.min_rank)
                                    ::dom::document createTextNode $node $min_value
                                    # Sous-élément max_value
                                    if { [info exists dico_applis(app.$nom_appli.comp.$nom_composant.max_rank)] } {
                                        set node [::dom::document createElement $rank_elt max_value]
                                        set max_value $dico_applis(app.$nom_appli.comp.$nom_composant.max_rank)
                                        ::dom::document createTextNode $node $max_value
                                    }
                        } else {
                            # Il manque des infos pour poursuivre
                            notice_show "Please, edit attributes of component \"$nom_appli/$nom_composant\" prior to generate SCC !"
                            set si_erreur 1
                            break
                        }
                    }
                } else {
                    # Il manque des infos pour poursuivre
                    notice_show "Please, edit attributes of application \"$nom_appli\" prior to generate SCC !"
                    set si_erreur 1
                    break
                }
            }

            if {!$si_erreur} {
                # Traduit en texte à syntaxe XML
                set texte_xml [::dom::DOMImplementation serialize $doc -indent 1]
            }
            # Libère la mémoire
            ::dom::DOMImplementation destroy $doc
        } else {
            # Il manque des infos pour poursuivre
            notice_show "Please, edit experiment settings prior to generate SCC !"
            return ""
        }
    }
    return $texte_xml
}

ret  {genere_SMIOC} (type nom_, type appli , type nom_, type composant) {
#
    global dico_applis
    global dico_caract_fichiers
    global dico_caract_points
    global dico_cnx_out
    global dico_caract_cnx

    global oasis4_version

    # Cle d'acces du composant dans dico_applis
    set clef_composant app.$nom_appli.comp.$nom_composant

    # Crée le document XML
    set doc [dom::DOMImplementation create]


    # Crée l'élément "prismcomponent" racine
    set prismcomponent_elt [::dom::document createElement $doc prismcomponent]
    # Ses attributs
    dom::element setAttribute $prismcomponent_elt xmlns "http://www.cerfacs.fr/PRISM/XML/1.1"
    dom::element setAttribute $prismcomponent_elt "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance"
    dom::element setAttribute $prismcomponent_elt "xsi:schemaLocation" "http://www.cerfacs.fr/PRISM/XML/1.1"
    dom::element setAttribute $prismcomponent_elt oasis4_version $oasis4_version
    dom::element setAttribute $prismcomponent_elt local_name $nom_composant

    # recopie la/les grille(s) depuis le PMIOD
    # 
    foreach grid_name $dico_applis($clef_composant.lgrids) {
    set grid_elt [::dom::document createElement $prismcomponent_elt grid]
        dom::element setAttribute $grid_elt local_name $grid_name
        # Indexing dimensions
        if { [info exists dico_applis($clef_composant.grid.$grid_name.periodi)] } { 
            set periodi_elt [::dom::document createElement $grid_elt indexing_dimension]
            dom::element setAttribute $periodi_elt index 1
            dom::element setAttribute $periodi_elt periodic $dico_applis($clef_composant.grid.$grid_name.periodi)
        }
        if { [info exists dico_applis($clef_composant.grid.$grid_name.periodj)] } { 
            set periodj_elt [::dom::document createElement $grid_elt indexing_dimension]
            dom::element setAttribute $periodj_elt index 2
            dom::element setAttribute $periodj_elt periodic $dico_applis($clef_composant.grid.$grid_name.periodj)
        }
        if { [info exists dico_applis($clef_composant.grid.$grid_name.periodk)] } { 
            set periodk_elt [::dom::document createElement $grid_elt indexing_dimension]
            dom::element setAttribute $periodk_elt index 3
            dom::element setAttribute $periodk_elt periodic $dico_applis($clef_composant.grid.$grid_name.periodk)
        }
    }    

    # Pour tous les noms des champs de couplage du composant
    # Rappel : un champ peut avoir deux points de couplage, un en entrée et un en sortie.
    foreach nom_champ $dico_applis($clef_composant.lchamps) {
        set lcnx_out ""
        catch { set lcnx_out $dico_caract_points($nom_appli.$nom_composant.$nom_champ.o.lcnx) }
        set lcnx_in ""
        catch { set lcnx_in $dico_caract_points($nom_appli.$nom_composant.$nom_champ.i.lcnx) }
        
        # Si le champ a des connexions (en entrée ou en sortie)
        if { $lcnx_out != "" || $lcnx_in != ""  } {

            # Elément "transient"
            set transient_elt [::dom::document createElement $prismcomponent_elt transient]
            # Son attribut "local_name"
            dom::element setAttribute $transient_elt local_name $nom_champ

            # Elément transient_standard_name
            set std_name_elt [::dom::document createElement $transient_elt transient_standard_name]
            ::dom::document createTextNode $std_name_elt $dico_applis($clef_composant.champ.$nom_champ.std_name)

            # Elément XML "physics"
            set physics_elt [::dom::document createElement $transient_elt physics]
            dom::element setAttribute $physics_elt transient_type $dico_applis($clef_composant.champ.$nom_champ.type)

                # Sous-élément physical_units
                set units_elt [::dom::document createElement $physics_elt physical_units]
                ::dom::document createTextNode $units_elt $dico_applis($clef_composant.champ.$nom_champ.units)
                # Sous-élément valid_min
                if { [info exists dico_applis($clef_composant.champ.$nom_champ.min)] } {
                    set min_elt [::dom::document createElement $physics_elt valid_min]
                    ::dom::document createTextNode $min_elt $dico_applis($clef_composant.champ.$nom_champ.min)
                }
                # Sous-élément valid_max
                if { [info exists dico_applis($clef_composant.champ.$nom_champ.max)] } {
                    set max_elt [::dom::document createElement $physics_elt valid_max]
                    ::dom::document createTextNode $max_elt $dico_applis($clef_composant.champ.$nom_champ.max)
                }

            # Elément numerics
            set numerics_elt [::dom::document createElement $transient_elt numerics]
            set datatype $dico_applis($clef_composant.champ.$nom_champ.datatype)
            dom::element setAttribute $numerics_elt datatype "xs:$datatype"

            # Elément "intent"
            set intent_elt [::dom::document createElement $transient_elt intent]

            # Si le champ est en sortie
            if { $lcnx_out != "" } {

                # Pour toutes les connexions sortantes
                foreach num_output $lcnx_out {
                    # Elément "output"
                    set output_elt [::dom::document createElement $intent_elt output]
                    # Nom du point de connexion sortante ou "transi_out_name"
                    set numero [string range $num_output 1 end]
                    set nom_point_cnx $nom_champ\_out$numero
                    dom::element setAttribute $output_elt transi_out_name $nom_point_cnx

                    # Elément "minimal_period" du champ en sortie
                    genere_element_min_period $output_elt $clef_composant.champ.$nom_champ.o

                    # Retrouve le point cible
                    set clef_point_source $nom_appli.$nom_composant.$nom_champ.$num_output
                    set clef_point_cible  $dico_cnx_out($clef_point_source)
                    # Exchange period unit and value
                    set exch_period_unit  $dico_caract_cnx($clef_point_cible.exch_per_unit)
                    set exch_period_value $dico_caract_cnx($clef_point_cible.exch_per_val)

                    # Element "exchange_date"
                    set exchange_elt [::dom::document createElement $output_elt exchange_date]
                    set period_elt [::dom::document createElement $exchange_elt period]
                    set elt [::dom::document createElement $period_elt $exch_period_unit]
                    ::dom::document createTextNode $elt $exch_period_value

                    # Element "corresp_transi_in_name" : le nom du point cible
                    # Si la cible est un fichier
                    if { $dico_caract_cnx($clef_point_cible.app_cible) == "///file///" } {
                        # Identifiant du fichier
                        set id_fichier $dico_caract_cnx($clef_point_cible.comp_cible)
                        # Le nom du point cible est simplement le nom du champ du fichier
                        set nom_pt_cible $dico_caract_fichiers($id_fichier.field.name)
                    } else {
                        # Le nom du point cible est le nom du champ suivi du suffixe _in
                        set nom_pt_cible $dico_caract_cnx($clef_point_cible.champ_cible)\_in
                    }
                    set elt [::dom::document createElement $output_elt corresp_transi_in_name]
                    ::dom::document createTextNode $elt $nom_pt_cible

                    # Si la cible est un fichier
                    if { $dico_caract_cnx($clef_point_cible.app_cible) == "///file///" } {
                        # Element "file"
                        set file_elt [::dom::document createElement $output_elt file]
                            # Sous-élément "name" : le nom du fichier
                            set nom_fichier $dico_caract_fichiers($id_fichier.name)
                            # Si l'option "suffix" est "true"
                            if { $dico_caract_fichiers($id_fichier.suffix) == "true" } {
                                # Enleve le suffixe .nc du nom du fichier
                                if { [string match *.nc $nom_fichier] } {
                                    set nom_fichier [string range $nom_fichier 0 end-3]
                                }
                            }
                            set elt [::dom::document createElement $file_elt name]
                            ::dom::document createTextNode $elt $nom_fichier
                            
                            # Sous-élément "suffix"
                            set elt [::dom::document createElement $file_elt suffix]
                            ::dom::document createTextNode $elt $dico_caract_fichiers($id_fichier.suffix)
                            # Sous-élément "format"
                            set elt [::dom::document createElement $file_elt format]
                            ::dom::document createTextNode $elt mpp_netcdf
                            # Sous-élément "io_mode"
                            set elt [::dom::document createElement $file_elt io_mode]
                            ::dom::document createTextNode $elt $dico_caract_fichiers($id_fichier.io_mode)
                            
                            # Sous-élément "packing" (attribut NetCDF)
                            set packing $dico_caract_fichiers($id_fichier.field.packing)
                            if { [string match "\[1248\]" $packing] } {
                                set elt [::dom::document createElement $file_elt packing]
                                ::dom::document createTextNode $elt $packing
                            }
                            # Sous-élément "scaling" (attribut NetCDF)
                            set scaling $dico_caract_fichiers($id_fichier.field.scaling)
                            if { $scaling != "" } {
                                set elt [::dom::document createElement $file_elt scaling]
                                ::dom::document createTextNode $elt $scaling
                            }
                            # Sous-élément "adding" (attribut NetCDF)
                            set adding $dico_caract_fichiers($id_fichier.field.adding)
                            if { $adding != "" } {
                                set elt [::dom::document createElement $file_elt adding]
                                ::dom::document createTextNode $elt $adding
                            }
                            # Sous-élément "fill_value" (attribut NetCDF)
                            set fill_value $dico_caract_fichiers($id_fichier.field.fill_value)
                            if { $fill_value != "" } {
                                set elt [::dom::document createElement $file_elt fill_value]
                                ::dom::document createTextNode $elt $fill_value
                            }
                    } else {
                        # Le nom du composant cible
                        set nom_comp_cible $dico_caract_cnx($clef_point_cible.comp_cible)
                        # Element "component_name"
                        set corresp_comp_elt [::dom::document createElement $output_elt component_name]
                        ::dom::document createTextNode $corresp_comp_elt $nom_comp_cible
                    }

                    # Element lag
                    set lag ""
                    catch {set lag $dico_caract_cnx($clef_point_cible.lag)}
                    if { $lag != ""} {
                        set elt [::dom::document createElement $output_elt lag]
                        ::dom::document createTextNode $elt $lag
                    }

                    # Element "source_transformation"
                    set transfo_elt [::dom::document createElement $output_elt source_transformation]
                        # Element "source_time_operation"
                        set src_time_op $dico_caract_cnx($clef_point_cible.src_time_op)
                        if { $src_time_op != "" } {
                            set elt [::dom::document createElement $transfo_elt source_time_operation]
                            ::dom::document createTextNode $elt $src_time_op
                        }
                        # Element "statistics" 
                        set stat_source_mask $dico_caract_cnx($clef_point_cible.stat_source_mask)
                        set stat_source_nmsk $dico_caract_cnx($clef_point_cible.stat_source_nmsk)
                        set stat_source_all  $dico_caract_cnx($clef_point_cible.stat_source_all)
                        if {$stat_source_mask == "on" || $stat_source_nmsk == "on" || $stat_source_all == "on"} {
                            set stat_elt [::dom::document createElement $transfo_elt statistics]
                                set elt [::dom::document createElement $stat_elt masked_points]
                                ::dom::document createTextNode $elt $stat_source_mask
                                set elt [::dom::document createElement $stat_elt notmasked_points]
                                ::dom::document createTextNode $elt $stat_source_nmsk
                                set elt [::dom::document createElement $stat_elt all_points]
                                ::dom::document createTextNode $elt $stat_source_all
                        }

                        # Element "source_local_transformation"
                        
                        # La transformation "scattering" est un attribut du point de couplage
                        set scatter 0
                        catch {set scatter $dico_applis($clef_composant.champ.$nom_champ.o.scatter)}
                        # Les autres transformations sont des attributs de la connexion
                        set src_add_val $dico_caract_cnx($clef_point_cible.src_add_val)
                        set src_mult_val $dico_caract_cnx($clef_point_cible.src_mult_val)
                        # Si il y a au moins une transformation a la source
                        if { $scatter == 1 || [expr $src_add_val != 0] || [expr $src_mult_val != 1] } {
                            # Creer l'element
                            set local_transfo_elt [::dom::document createElement $transfo_elt source_local_transformation]
                            # Element "scattering"
                            if { $scatter } {
                                set elt [::dom::document createElement $local_transfo_elt scattering]
                            }
                            # Element "add_scalar"
                            if { $src_add_val != 0 } {
                                set elt [::dom::document createElement $local_transfo_elt add_scalar]
                                ::dom::document createTextNode $elt $src_add_val
                            }
                            # Element "mult_scalar"
                            if { $src_mult_val != 1 } {
                                set elt [::dom::document createElement $local_transfo_elt mult_scalar]
                                ::dom::document createTextNode $elt $src_mult_val
                            }
                        }

                    # Element "debug_mode" a la source
                    set debug_mode $dico_caract_cnx($clef_point_cible.dbg_source)
                    set elt [::dom::document createElement $output_elt debug_mode]
                    ::dom::document createTextNode $elt $debug_mode
                }
            }

            # Si le champ est en entrée
            if { $lcnx_in != "" } {

                # Elément "input"
                set input_elt [::dom::document createElement $intent_elt input]

                # Attribut "required_but_changeable" du champ
                if { [info exists dico_applis($clef_composant.champ.$nom_champ.i.rbc)] } {
                    set rbc $dico_applis($clef_composant.champ.$nom_champ.i.rbc)
                    dom::element setAttribute $input_elt required_but_changeable $rbc
                }

                # Elément "minimal_period" du champ en entrée
                genere_element_min_period $input_elt $clef_composant.champ.$nom_champ.i

                # Exchange period unit and value
                set clef_point_cible  $nom_appli.$nom_composant.$nom_champ.i
                set exch_period_unit  $dico_caract_cnx($clef_point_cible.exch_per_unit)
                set exch_period_value $dico_caract_cnx($clef_point_cible.exch_per_val)

                # Element "exchange_date"
                set exchange_elt [::dom::document createElement $input_elt exchange_date]
                set period_elt [::dom::document createElement $exchange_elt period]
                set elt [::dom::document createElement $period_elt $exch_period_unit]
                ::dom::document createTextNode $elt $exch_period_value

                    # Elément "origin"
                    # Nom du point de connexion entrant ou "transi_in_name"
                    set nom_point_cnx $nom_champ\_in
                    set origin_elt [::dom::document createElement $input_elt origin]
                    dom::element setAttribute $origin_elt transi_in_name $nom_point_cnx

                    # Retrouve le point source
                    # L'appli du champ source ou ///file/// si c'est un fichier source
                    set appli_source $dico_caract_cnx($clef_point_cible.app_source)
                    # Le nom du composant source ou l'id du fichier source
                    set nom_comp_source $dico_caract_cnx($clef_point_cible.comp_source)
                    # Le nom du champ source
                    set nom_champ_source $dico_caract_cnx($clef_point_cible.champ_source)
                    # Le numéro du point source
                    set num_pt_source [string range $dico_caract_cnx($clef_point_cible.pt_source) 1 end]
                    
                    # Element "corresp_transi_out_name"
                    # Si la source est un fichier
                    if { $appli_source == "///file///" } {
                        # c'est simplement le nom du champ 
                        set corresp_transi_out_name $nom_champ_source
                    } else {
                        # c'est le nom du champ suivi du suffixe _out<numéro>
                        set corresp_transi_out_name $nom_champ_source\_out$num_pt_source
                    }
                    set elt [::dom::document createElement $origin_elt corresp_transi_out_name]
                    ::dom::document createTextNode $elt $corresp_transi_out_name
                    
                    # Si la source est un fichier
                    if { $appli_source == "///file///" } {
                        # Element "file"
                        set file_elt [::dom::document createElement $origin_elt file]
                            # Sous-élément "name" : le nom du fichier
                            set nom_fichier $nom_comp_source
                            # Si l'option "suffix" est "true"
                            if { $dico_caract_fichiers($nom_comp_source.suffix) == "true" } {
                                # Enleve le suffixe .nc du nom du fichier
                                if { [string match *.nc $nom_fichier] } {
                                    set nom_fichier [string range $nom_fichier 0 end-3]
                                }
                            }
                            set elt [::dom::document createElement $file_elt name]
                            ::dom::document createTextNode $elt $nom_fichier
                            
                            # Sous-élément "suffix"
                            set elt [::dom::document createElement $file_elt suffix]
                            ::dom::document createTextNode $elt $dico_caract_fichiers($nom_comp_source.suffix)
                            # Sous-élément "format"
                            set elt [::dom::document createElement $file_elt format]
                            ::dom::document createTextNode $elt mpp_netcdf
                            # Sous-élément "io_mode"
                            set elt [::dom::document createElement $file_elt io_mode]
                            ::dom::document createTextNode $elt $dico_caract_fichiers($nom_comp_source.io_mode)
                    } else {
                        # Element "component_name"
                        set corresp_comp_elt [::dom::document createElement $origin_elt component_name]
                        ::dom::document createTextNode $corresp_comp_elt $nom_comp_source
                    }

                    # Element "middle_transformation"
                    set remaillage $dico_caract_cnx($clef_point_cible.remail)
                    if { $remaillage != "" } {
                        set transfo_elt [::dom::document createElement $origin_elt middle_transformation]
                        set interpol_elt [::dom::document createElement $transfo_elt interpolation]

                        # Test : interpolation 2D ou 3D ?
                        switch $remaillage {
                            nneighbour3D -
                            trilinear  {
                                # Interpolation 3D
                                set interp_xD_elt [::dom::document createElement $interpol_elt interp3D]
                            }
                            default {
                                # Interpolation 2D
                                set interp_xD_elt [::dom::document createElement $interpol_elt interp2D]
                                # Element <Interpolation 1D> et sous-element <none> obligatoires bien qu'inutiles
                                set interp_1D_elt [::dom::document createElement $interpol_elt interp1D]
                                ::dom::document createElement $interp_1D_elt none
                            }
                        }

                        # Sous-element specifiant le type d'interpolation :
                        #   nneighbour3D, trilinear (3D), nneighbour2D, bilinear, bicubic ou conservativ2D
                        set interp_type_elt [::dom::document createElement $interp_xD_elt $remaillage]

                        # Element "parallel search"
                        set elt [::dom::document createElement $interp_type_elt para_search]
                        ::dom::document createTextNode $elt global

                        # Test : interpolation par plus proche voisin ?
                        if { $remaillage == "nneighbour3D" || $remaillage == "nneighbour2D" } {
                            # Element "nbr_neighbours"
                            set elt [::dom::document createElement $interp_type_elt nbr_neighbours]
                            ::dom::document createTextNode $elt $dico_caract_cnx($clef_point_cible.nbr_neighbours)
                        }

                        # Element "if masked"
                        if { $remaillage != "conservativ2D" } {
                            set elt [::dom::document createElement $interp_type_elt if_masked]
                            ::dom::document createTextNode $elt $dico_caract_cnx($clef_point_cible.if_masked)
                        }

                        # Si remaillage bicubique, Element "bicubic_method"
                        if { $remaillage == "bicubic" } {
                            set elt [::dom::document createElement $interp_type_elt bicubic_method]
                            ::dom::document createTextNode $elt $dico_caract_cnx($clef_point_cible.bi3_method)
                        }

                        # Si remaillage conservatif
                        if { $remaillage == "conservativ2D" } {
                            # Element "order"
                            set elt [::dom::document createElement $interp_type_elt order]
                            ::dom::document createTextNode $elt first
                            # Element "normalisation method"
                            set norm_elt [::dom::document createElement $interp_type_elt normalisation2D]
                                # Element "methodnorm2D"
                                set elt [::dom::document createElement $norm_elt methodnorm2D]
                                ::dom::document createTextNode $elt $dico_caract_cnx($clef_point_cible.norm_method)
                                # Element "nearnei"
                                set elt [::dom::document createElement $norm_elt nearnei]
                                ::dom::document createTextNode $elt $dico_caract_cnx($clef_point_cible.norm_near_nei)
                        }
                    }

                # Element "target_transformation"
                set transfo_elt [::dom::document createElement $input_elt target_transformation]
                    # Sous-element "target_local_transformation"
                    
                    # La transformation "gathering" est un attribut du point de couplage
                    set gather 0
                    catch {set gather $dico_applis($clef_composant.champ.$nom_champ.i.gather)}
                    # Les autres transformations sont des attributs de la connexion
                    set tgt_add_val $dico_caract_cnx($clef_point_cible.tgt_add_val)
                    set tgt_mult_val $dico_caract_cnx($clef_point_cible.tgt_mult_val)
                    # Si il y a au moins une transformation à la source
                    if { $gather == 1 || [expr $tgt_add_val != 0] || [expr $tgt_mult_val != 1] } {
                        # Creer l'element
                        set local_transfo_elt [::dom::document createElement $transfo_elt target_local_transformation]
                        # Element "gathering"
                        if { $gather } {
                            set elt [::dom::document createElement $local_transfo_elt gathering]
                        }
                        # Element "add_scalar"
                        if { $tgt_add_val != 0 } {
                            set elt [::dom::document createElement $local_transfo_elt add_scalar]
                            ::dom::document createTextNode $elt $tgt_add_val
                        }
                        # Element "mult_scalar"
                        if { $tgt_mult_val != 1 } {
                            set elt [::dom::document createElement $local_transfo_elt mult_scalar]
                            ::dom::document createTextNode $elt $tgt_mult_val
                        }
                    }
                    # Sous-element "target_time_operation"
                    set tgt_time_op $dico_caract_cnx($clef_point_cible.tgt_time_op)
                    if { $tgt_time_op != "" } {
                        set elt [::dom::document createElement $transfo_elt target_time_operation]
                        ::dom::document createTextNode $elt $tgt_time_op
                    }
                    # Element "statistics" 
                    set stat_cible_mask $dico_caract_cnx($clef_point_cible.stat_cible_mask)
                    set stat_cible_nmsk $dico_caract_cnx($clef_point_cible.stat_cible_nmsk)
                    set stat_cible_all  $dico_caract_cnx($clef_point_cible.stat_cible_all)
                    if {$stat_cible_mask == "on" || $stat_cible_nmsk == "on" || $stat_cible_all == "on"} {
                        set stat_elt [::dom::document createElement $transfo_elt statistics]
                            set elt [::dom::document createElement $stat_elt masked_points]
                            ::dom::document createTextNode $elt $stat_cible_mask
                            set elt [::dom::document createElement $stat_elt notmasked_points]
                            ::dom::document createTextNode $elt $stat_cible_nmsk
                            set elt [::dom::document createElement $stat_elt all_points]
                            ::dom::document createTextNode $elt $stat_cible_all
                    }

                # Element "debug_mode"
                set dbg_cible $dico_caract_cnx($clef_point_cible.dbg_cible)
                set elt [::dom::document createElement $input_elt debug_mode]
                ::dom::document createTextNode $elt $dbg_cible
            }
        }
    }

    # Traduit en texte à syntaxe XML
    set texte_xml [::dom::DOMImplementation serialize $doc -indent 1]
    # Libère la mémoire
    ::dom::DOMImplementation destroy $doc

    return $texte_xml
}

ret  {genere_element_date} (type element_, type pere , type prefixe) {
# Génère un sous-élément de type "date" dans l'élément element_pere passé en paramètre
# Le sous-élément "date" comprend les sous-éléments suivants :
#   year month day hou minute second
#
# Paramètres d'entrée :
#  - element_pere
#  - prefixe : prefixe de la clef permettant d'acceder au valeurs dans le dictionnaire global "dico_experiment"
#
    global dico_experiment
    
    # Crée un sous-élément "date"
    set date_elt [::dom::document createElement $element_pere date]
    # Crée un sous-élément pour chaque unité de durée : year, month, etc...
    foreach time_unit {year month day hour minute second} {
        set value $dico_experiment($prefixe.$time_unit)
        if {$value != ""} {
            set node [::dom::document createElement $date_elt $time_unit]
            ::dom::document createTextNode $node $value
        }
    }
}

ret  {genere_element_min_period} (type element_, type XML , type prefixe) {
global dico_applis

    set period_elt [::dom::document createElement $element_XML minimal_period]
    # Pour toutes les unités possibles de temps
    foreach unit_temps {secs mins hours days months years}  {

        set name nbr_$unit_temps
        # Si une valeur est définie pour cette unité
        if { [info exists dico_applis($prefixe.$name)] } {
            # Crée un sous-élément correspondant
            set sous_element [::dom::document createElement $period_elt $name]
            ::dom::document createTextNode $sous_element $dico_applis($prefixe.$name)
        }
    }
}

ret  {genere_graphics_XML} () {
# Génere le texte du fichier XML devant contenir
# les parametres graphiques des composants du couplage 
#
    global dico_applis
    global dico_units
    global liste_fichiers dico_caract_fichiers

    # Crée le document XML
    set doc [dom::DOMImplementation create]

    # Crée l'élément SCC racine
    set graphics_elt [::dom::document createElement $doc graphics]

    # Pour toutes les applications
    foreach nom_appli $dico_applis(lapplis) {
        # Pour tous les composants de cette application
        foreach nom_composant $dico_applis(app.$nom_appli.lcomp) {
            set clef_comp $nom_appli.$nom_composant
            
            # Si l'élément apparait sur le graphe
            if { [info exists dico_units($clef_comp)] } {
                # Crée un élément "component"
                set component_elt [::dom::document createElement $graphics_elt component]
                # Ses attributs :
                # name
                dom::element setAttribute $component_elt name $nom_composant
                # appli
                dom::element setAttribute $component_elt application $nom_appli
                # Position en x et y, couleur et mode d'affichage
                foreach attrib {coor_x coor_y colour expand} {
                    dom::element setAttribute $component_elt $attrib $dico_units($clef_comp.$attrib)
                }                        
            }
        }
    }
    
    # Pour tous les fichiers NetCDF
    foreach id_fichier $liste_fichiers {
        set clef_fichier ///file///.$id_fichier
        
        # Si l'élément apparait sur le graphe
        if { [info exists dico_units($clef_fichier)] } {
            # Crée un élément "file"
            set file_elt [::dom::document createElement $graphics_elt file]
            # Ses attributs :
            # name
            dom::element setAttribute $file_elt name $dico_caract_fichiers($id_fichier.name)
            # Position en x et y, couleur et mode d'affichage
            foreach attrib {coor_x coor_y colour expand} {
                dom::element setAttribute $file_elt $attrib $dico_units($clef_fichier.$attrib)
            }                        
        }
    }

    # Traduit en texte à syntaxe XML
    set texte_xml [::dom::DOMImplementation serialize $doc -indent 1]
    # Libère la mémoire
    ::dom::DOMImplementation destroy $doc
    
    return $texte_xml
}

ret  {get_actual_font} (type font) {
global dxf
  set dxf(choose_font_cb_name) ""
  set dxf(choose_font_cb_size) ""
  set dxf(choose_font_c_bold) ""
  set dxf(choose_font_c_italic) ""
  set dxf(choose_font_c_underline) ""

  set new_font ""
  set lfont_opt [font actual $font]
  for { set i 1 } { $i < 10 } { incr i 2 } {
    set opt_val [string trim [lindex $lfont_opt $i]]
    if {$i == 1 } { set dxf(choose_font_cb_name) $opt_val }
    if {$i == 3 } { set dxf(choose_font_cb_size) $opt_val }
    if { $i == 5 } {
        if { $opt_val == "normal" } {
            set opt_val ""
                 } else {
            set dxf(choose_font_c_bold) $opt_val
               }
       }
    
    if { $i == 7 } {
        if { $opt_val == "roman" }  {
            set opt_val ""
                 } else {
            set dxf(choose_font_c_italic) $opt_val
                }
       }
    if { $i == 9 } {
        if { $opt_val == "0" }  {
            set opt_val ""
            } else {
               set opt_val "underline"
            set dxf(choose_font_c_underline) $opt_val
           }
           }

    if { [llength [split $opt_val " "]] <= 1 } {
        append new_font " $opt_val"
         } else {
        append new_font " \{$opt_val\}"
       }

      }
  return [string trim $new_font]
}

ret  {get_cur_font} () {
global dxf
  set cur_font ""
  foreach el [list $dxf(choose_font_cb_name) $dxf(choose_font_cb_size)  $dxf(choose_font_c_bold) $dxf(choose_font_c_italic) $dxf(choose_font_c_underline)] {
    if { $el != "" } {
        set trim_el [string trim $el]
        if { [llength [split $trim_el " "]] <= 1 } {
            append cur_font " $trim_el"
            } else {
            append cur_font " \{$trim_el\}"
           }
        }
    }

  return [string trim $cur_font]
}

ret  {help_communication} (type x , type y , type i) {
#
    global dico_caract_cnx dico_caract_fichiers

    set champ_source $dico_caract_cnx($i.champ_source)
    
    # Si la cible est un fichier NetCDF
    if { $dico_caract_cnx($i.app_cible) == "///file///" } {
        # Le nom est mémorisé comme un attribut du champ "field"
        set id_fichier $dico_caract_cnx($i.comp_cible)
        set champ_cible $dico_caract_fichiers($id_fichier.field.name)
    } else {
        set champ_cible $dico_caract_cnx($i.champ_cible)
    }

    set exch_per_val  $dico_caract_cnx($i.exch_per_val)
    set exch_per_unit $dico_caract_cnx($i.exch_per_unit)
    if {$exch_per_val != 1} {
        # Met les unités au pluriel
        set exch_per_unit ${exch_per_unit}s
    }
    set text "From: $champ_source\nTo: $champ_cible\nPeriod: $exch_per_val $exch_per_unit"
    help_object .null $text label $x $y #e0fee6
}

ret  {help_object} (type w , type text , type type , optional x ={) {y {}} {color /* fefed4}} {*/
/*  Affiche une fenetre ballon*/
/*  Parametre d'entree :*/
/*    - w :     fenetre pres de laquelle doit s'afficher le message*/
/*    - text :  texte du message a afficher*/
/*    - type :  label ou message*/
/*    - x, y :  coordonnees a l'ecran*/
/*    - color : couleur du fond*/
/* */
    if {$x == ""} {
        /*  Place la bulle d'aide au dessus de la zone de saisie*/
         x =  [expr [winfo rootx $w] + [winfo width $w]]
         y =  [expr [winfo rooty $w] + [winfo height $w] - 5]
    } else {
        incr y 15
        incr x 5
    }

    /*   after 500*/
     u =  .ballon_object
    wm geometry $u +$x+$y
    destroy $u.text
    switch $type {
        message {message $u.text -text $text -padx 15 -pady 10 -justify left}
        label   {label $u.text -text $text -padx 15 -pady 10 -wraplength 140  -justify left}
    }
    $u.text configure -foreground black -font {helvetica 10} -background $color
    pack $u.text -side left
    wm deiconify $u
    raise $u
}

ret  {help_object_hide} () {
catch {wm withdraw .ballon_object}
}

ret  {host_boutons_delete} (type form , type host) {
# Supprime une ligne du tableau des ordinateurs "hosts" pour l'appli
# avant que la ligne ait été supprimée en mémoire de la variable hosts_m
#
    global hosts_m
    
    array set info_host [grid info $form.n$host]
    set num_ligne $info_host(-row)
    
    destroy $form.n$host; destroy $form.p$host; destroy $form.delete$host

    set hosts_suivants [lrange $hosts_m(lhosts) [expr $num_ligne + 1] end]
    # Pour toutes les lignes suivantes
    set i $num_ligne
    foreach host_suivant $hosts_suivants {
        # Change le no de lignes des trois widgets
        grid configure $form.n$host_suivant $form.p$host_suivant $form.delete$host_suivant -row $i
        incr i
    }
}

ret  {host_boutons_insert} (type form , type host , type nb_, type hosts) {
# Ajoute une ligne au formulaire de saisie des ordinateurs hosts
    global hosts_m
    global OASIS_GUI_DIR
    
    # Ajoute une ligne
    set no_ligne $nb_hosts
    
    grid [entry $form.n$host -textvariable hosts_m(host.$host.name) -width 20 -relief groove -background white -borderwidth 1] -row $no_ligne -column 0
    grid [entry $form.p$host -textvariable hosts_m(host.$host.nb_procs) -width 15 -relief groove -background white -borderwidth 1] -row $no_ligne -column 1
    
    set file delete1.xbm
    grid [button  $form.delete$host -bitmap  @[file join $OASIS_GUI_DIR IMAGES $file] -command "host_boutons_delete $form $host; host_delete $host" -background white -foreground red -relief groove  -borderwidth 1] -row $no_ligne -column 2
    focus $form.n$host
    bind $form.p$host <KeyPress-Return> "host_boutons_next $form $host"
    bind $form.p$host <KeyPress-Tab> "host_boutons_next $form $host"
}

ret  {host_boutons_next} (type form , type host) {
global hosts_m
    
    # Determine le no de ligne du bouton
    array set info_host [grid info $form.n$host]
    set num_ligne $info_host(-row)
    
    # Si le bouton est en derniere ligne de la table
    if { [lindex [grid size $form] 1] == [expr $num_ligne + 1] } {
        host_insert $form
    } else {
        set host_suivant [lindex $hosts_m(lhosts) [expr $num_ligne + 1]]
        focus $form.n$host_suivant
    }
}

ret  {host_delete} (type host) {
# Supprime un ordinateur host de la liste pour une application
    global hosts_m
    
    # Supprime de la liste
    set hosts_m(lhosts) [lsearch -not -all -inline $hosts_m(lhosts) $host]
    # Oublie ses parametres
    array unset hosts_m host.$host.*
}

ret  {host_insert} (type form) {
# Ajoute une nouvel ordinateur a la liste des ordinateurs hosts
    global hosts_m
    
    set nb_hosts [llength $hosts_m(lhosts)]
    # Si déja des ordinateurs hosts sont listés
    if { $nb_hosts != 0 } {
        # Détermine le no du dernier identifiant de host (id = numéro)
        set dernier_host [lindex $hosts_m(lhosts) end]
        # Crée un nouvel identifiant de host
        set nouvel_host [expr $dernier_host + 1]
    } else {
        set nouvel_host 1
    }
    # Ajoute a la liste
    lappend hosts_m(lhosts) $nouvel_host
    set hosts_m(host.$nouvel_host.name) ""
    set hosts_m(host.$nouvel_host.nb_procs) ""

    # Ajoute une ligne au formulaire
    host_boutons_insert $form $nouvel_host $nb_hosts
}

ret  {incr_font} (type object , type incr_, type val) {
#
    set font [lindex [$object configure -font] 4]
    set size [lindex $font 1]
    if { $size != "" && [regexp {^[0-9]+$} $size]  && [regexp {^[+-]?[0-9]+$} $incr_val]} {
        set font [lreplace $font 1 1 [incr size $incr_val]]
    }
    return $font
}

ret  {increment_date} (type nom_, type date , type champ_, type date , type offset) {
# Incrémente un champ de la variable globale nom_date de la quantité "offset"
# Le nom du champ est donné par "champ_date"
#
    global $nom_date
    
    set xval [set ${nom_date}($champ_date)]
    if { $xval == ""} {set xval 0}
    set xval [expr $xval + $offset]
    set ${nom_date}($champ_date) $xval
    # Pour forcer la verification des limites
    set ${nom_date}($champ_date) [set ${nom_date}($champ_date)]
}

ret  {liste_points_de_couplage} () {
global liste_points_i liste_points_o
    global dico_applis dico_caract_points
    global dico_caract_fichiers

    set liste {}

    # Pour tous les points de couplage en entrée ou en sortie
    foreach clef_point [concat $liste_points_i $liste_points_o] {
        set nom_appli $dico_caract_points($clef_point.appli)
        set nom_comp  $dico_caract_points($clef_point.comp)
        set nom_champ $dico_caract_points($clef_point.champ)

        # Sens I/O
        set I_O [string range $clef_point end end]
        if { $I_O == "i" } {
            set I_O input
        } else {
            set I_O output
        }
        
        # Si le point de couplage appartient à un fichier NetCDF
        if { $nom_appli == "///file///" } {
            set id_fichier $nom_comp
            set id_champ   $nom_champ
            
            if { $I_O == "input" } {
                # Le nom du fichier
                set nom_comp $dico_caract_fichiers($id_fichier.name)
                # C'est un fichier de sortie : normalement $id_champ vaut "field"
                # Le vrai nom du champ
                set nom_champ $dico_caract_fichiers($id_fichier.field.name)
            }
            
            set nom_appli "file"
            set type single
            set datatype $dico_caract_fichiers($id_fichier.$id_champ.type)
            if { [catch {set long_name $dico_caract_fichiers($id_fichier.$id_champ.long_name)} ] } {
                set long_name ""
            }

        } else {
            set clef_champ app.$nom_appli.comp.$nom_comp.champ.$nom_champ
            if { [catch {set long_name $dico_applis($clef_champ.long_name)} ] } {
                set long_name ""
            }
            set type $dico_applis($clef_champ.type)
            set datatype $dico_applis($clef_champ.datatype)
        }

        # Ajoute dans la liste une ligne par point de couplage
        # name "long name" application component type datatype I/O
        # Une ligne se termine par une clef d'acces a cette connexion
        set line [list $nom_champ $long_name $nom_appli $nom_comp $type $datatype $I_O $clef_point]
        lappend liste $line
    }
    return $liste
}

ret  {liste_tous_composants} () {
#
    global dico_applis

    set liste {}

    set liste_applis {}
    catch { set liste_applis $dico_applis(lapplis) }

    # Pour toutes les applications chargees en memoire
    foreach nom_appli $liste_applis {
        set long_name ""
        if {[info exists dico_applis(app.$nom_appli.long_name)]} {
            set long_name $dico_applis(app.$nom_appli.long_name)
        }
        set start_mode $dico_applis(app.$nom_appli.start_mode)
        set coupling_mode $dico_applis(app.$nom_appli.coupling_mode)
        set erreur [catch {
            set min_value $dico_applis(app.$nom_appli.proc.min_value)
            set max_value $dico_applis(app.$nom_appli.proc.max_value)
            set increment $dico_applis(app.$nom_appli.proc.increment)
            set nb_proc "\[$min_value:$max_value:$increment\]"
        }]
        if {$erreur} { set nb_proc "" }

        # Ajoute dans la liste une ligne par appli
        # Une ligne se termine par une clef d'acces a cette ligne
        set line [list $nom_appli "" $long_name $start_mode $coupling_mode $nb_proc $nom_appli]
        lappend liste $line

        # Pour tous les composants de cette application
        foreach nom_composant $dico_applis(app.$nom_appli.lcomp) {
            set clef_comp app.$nom_appli.comp.$nom_composant
            if {[catch {set long_name $dico_applis($clef_comp.long_name)}] } {
                set long_name ""
            }
            set erreur [catch {
                set min_value $dico_applis($clef_comp.proc.min_value)
                set max_value $dico_applis($clef_comp.proc.max_value)
                set increment $dico_applis($clef_comp.proc.increment)
                set nb_proc "\[$min_value):$max_value:$increment\]"
            }]
            if {$erreur} { set nb_proc "" }

            # Ajoute dans la liste une ligne par composant
            # Une ligne se termine par une clef d'acces a cd composant
            set line [list $nom_appli $nom_composant $long_name $start_mode $coupling_mode $nb_proc $nom_appli.$nom_composant]
            lappend liste $line
        }
    }
    return $liste
}

ret  {liste_tous_fichiers} () {
#
    global liste_fichiers dico_caract_fichiers

    set liste {}

    foreach file_id $liste_fichiers {
        set io_direction $dico_caract_fichiers($file_id.dir)
        set io_mode $dico_caract_fichiers($file_id.io_mode)
        set suffix $dico_caract_fichiers($file_id.suffix)
        set filename $dico_caract_fichiers($file_id.name)
        
        # Ajoute dans la liste une ligne par fichier énumérant ceci :
        #     nom,  sens (sortie ou entrée), mode d'acces (single ou parallele), avec ou sans suffixe
        # Une ligne se termine par une clef d'acces a ce fichier : ///file/// suivi de son identifiant
        set line [list $filename $io_direction $io_mode $suffix "///file///.$file_id"]
        lappend liste $line
    }
    return $liste
}

ret  {liste_toutes_connexions} () {
#
    global liste_cnx_in
    global dico_applis dico_caract_cnx dico_caract_fichiers

    set liste {}

    # Pour tous les points de couplage en entrée ou en sortie
    foreach clef_cnx $liste_cnx_in {
        set appli_source $dico_caract_cnx($clef_cnx.app_source)
        set appli_cible $dico_caract_cnx($clef_cnx.app_cible)
        set champ_source $dico_caract_cnx($clef_cnx.champ_source)
        set champ_cible  $dico_caract_cnx($clef_cnx.champ_cible)
        set comp_source $dico_caract_cnx($clef_cnx.comp_source)
        set comp_cible  $dico_caract_cnx($clef_cnx.comp_cible)

        # Si la cible est un fichier NetCDF
        if { $appli_cible == "///file///" } {
            # "comp_cible" contient l'identifiant du fichier
            # Son nom
            set nom_comp_cible $dico_caract_fichiers($comp_cible.name)
            # "champ_cible" contient "field"
            # le nom du champ
            set nom_champ_cible $dico_caract_fichiers($comp_cible.field.name)
            # Détermine les attributs du champ d'après le champ source
            set clef_champ app.$appli_source.comp.$comp_source.champ.$champ_source
        } else {
            set nom_comp_cible $comp_cible
            set nom_champ_cible $champ_cible 
            # Détermine les attributs du champ d'après le champ cible
            set clef_champ app.$appli_cible.comp.$comp_cible.champ.$champ_cible
        }
        
        # Détermine le type du champ
        set type $dico_applis($clef_champ.type)
        set datatype $dico_applis($clef_champ.datatype)

        # Ajoute dans la liste une ligne par connexion
        # from "from component" to "to component" type datatype
        # Une ligne se termine par une clef d'acces a cette connexion
        set line [list $champ_source $comp_source $nom_champ_cible $nom_comp_cible $type $datatype $clef_cnx]
        lappend liste $line
    }
    return $liste
}

ret  {lit_1er_sous_element} (type element) {
# Retourne la ref. du premier sous-élément XML d'un élément XML donné
#   Balaie les noeuds enfants jusqu'au premier noeud de type "élément"
#   En effet, il peut y avoir des noeuds de type "texte" ou "commentaires"
#   avant le premier sous-élément.
#
    set sous_elt [dom::node configure $element -firstChild]
    set sous_elt_type [dom::node configure $sous_elt -nodeType]
    while {$sous_elt_type != "element"} {
        set sous_elt [dom::node configure $sous_elt -nextSibling]
        set sous_elt_type [dom::node configure $sous_elt -nodeType]
    }
    return $sous_elt
}

ret  {lit_XML_texte} (type element_, type XML) {
set texte ""
   # Lit les sous-éléments de l'élément XML
   set ss_elem_list [dom::node children $element_XML]
   foreach element $ss_elem_list  {
      set name [dom::node configure $element -nodeName]
      if {$name == "#text"} {
         set value [dom::node configure $element -nodeValue]
         if { $value != "" } {
            set texte "$texte $value"
         }
      }
   }
   return [string trim $texte]
}

ret  {lit_element_application} (type appli_, type elt , type dir_, type name) {
# Lit dans un fichier SCC l'élément <application> donné en parametre
# Ouvre aussi le fichier PMIOD de tous les composants de l'application listés dans
# l'élément <application> ou à défaut le fichier SMIOC.
#
# Paramètres d'entrée :
#  - element : element XML de type "application"
#  - dir_name : nom du repertoire contenant le fichier SCC.xml
#
# Valeur de retour :
#      0 si pas d'erreur
#      1 s'il manque un fichier PMIOD ou SMIOC
#
    global dico_applis dico_units
    global liste_points_i liste_points_o dico_caract_points
    
    # Lit les attributs local_name, executable_name, redirect
    set att [dom::node configure $appli_elt -attributes]
    set nom_appli [load_XML_attributes $att dico_applis "app"]
    
    # Lit le fichier AD.xml de l'application, si présent dans le même répertoire
    # et lit aussi les fichiers PMIOD des composants de l'appli si ceux ci sont aussi présents
    # ----------------------------------------------------------------------------
    set liste_comp_ajoutes {}
    set nom_fichier_AD [file join $dir_name "$nom_appli\_ad.xml"]
    if {! [file exists $nom_fichier_AD]} {
        # Essaie avec des lettres majuscules
        set nom_fichier_AD [file join $dir_name "$nom_appli\_AD.xml"]
    }
    # Si le fichierAD existe
    if {[file exists $nom_fichier_AD]} {
        lit_fichier_AD  $nom_fichier_AD dico_applis liste_comp_ajoutes
    } else {
        # erreur
        notice_show  "Cannot find Application Description file for \n$nom_appli\nYou have to locate and load it manually" error
        # Ajoute le nom de l'appli à la liste
        lappend dico_applis(lapplis) $nom_appli
        # Initialise arbitrairement des champs pas renseignés qui sont en fait obligatoires
        set dico_applis(app.$nom_appli.start_mode) notspawn_or_spawn
        set dico_applis(app.$nom_appli.coupling_mode) coupled_or_standalone
        set dico_applis(app.$nom_appli.proc.min_value) 0
        set dico_applis(app.$nom_appli.proc.max_value) 0
        set dico_applis(app.$nom_appli.proc.increment) 0
    }
        
    # Lit les sous-éléments de l'élément <application>
    set current_host_id 0
    set ss_elem_list [dom::node children $appli_elt]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name != "#text" && $name != "#comment"} {
            switch $name {
                host {
                    # Lit l'attribut "local_name" qui est le nom du host
                    set att [dom::node configure $element -attributes]
                    set host_name [load_XML_attributes $att dico_applis "app.$nom_appli.host"]
                    # L'identifiant du host est une numéro
                    set dico_applis(app.$nom_appli.host.$current_host_id.name) $host_name
                    # Ajoute a la liste
                    lappend dico_applis(app.$nom_appli.lhosts) $current_host_id
                    # Lit le sous-element "nbr_procs" qui est unique
                    set nbr_procs_elt [lit_1er_sous_element $element]
                    # Lit la valeur du sous-élément "nbr_procs"
                    set txt_elem [dom::node configure $nbr_procs_elt -firstChild]
                    set value [dom::node configure $txt_elem -nodeValue]
                    set dico_applis(app.$nom_appli.host.$current_host_id.nb_procs) $value
                    incr current_host_id
                }
                component {
                    # Lit l'attribut "local_name" qui est le nom du composant
                    set att [dom::node configure $element -attributes]
                    set nom_comp [load_XML_attributes $att dico_applis "app.$nom_appli.comp"]

                    # Lit les sous-éléments de l'élément <component> (qui sont tous de type "rank")
                    set ss_elem_list [dom::node children $element]
                    foreach element $ss_elem_list  {
                        set name [dom::node configure $element -nodeName]
                        if {$name == "rank"} {
                            lit_element_rank $element app.$nom_appli.comp.$nom_comp
                            # Pour l'instant, on ne lit que le premier
                            break
                        }
                    }

                    # Si le fichier PMIOD du composant n'a pas été lu en même temps que le fichier AD de l'appli
                    if {[lsearch $liste_comp_ajoutes $nom_appli.$nom_comp] == -1} {
                        # Si le fichier PMIOD du composant est présent dans le répertoire
                        set erreur 1
                        set nom_fichier_PMIOD [file join $dir_name "$nom_appli\_$nom_comp\_pmiod.xml"]
                        if { [file isfile $nom_fichier_PMIOD] } {
                            # Lit le fichier PMIOD du composant
                            set erreur [lit_fichier_component $nom_fichier_PMIOD dico_applis $nom_appli $nom_comp PMIOD]
                        }
                        # Si pas possible de lire le fichier PMIOD
                        if { $erreur } {
                            # En remplacement, ouvre et lit une première fois le fichier SMIOC.xml du composant
                            set nom_fichier_SMIOC [file join $dir_name "$nom_appli\_$nom_comp\_smioc.xml"]
                            set erreur [lit_fichier_component $nom_fichier_SMIOC dico_applis $nom_appli $nom_comp PMIOD]
                            # Initialise arbitrairement des champs pas renseignés qui sont en fait obligatoires
                            set dico_applis(app.$nom_appli.comp.$nom_comp.proc.min_value) 0
                            set dico_applis(app.$nom_appli.comp.$nom_comp.proc.max_value) 0
                            set dico_applis(app.$nom_appli.comp.$nom_comp.proc.increment) 0
                        }
                        
                        # Si erreur aussi a la lecture du fichier SMIOC
                        if { $erreur } {
                            notice_show  "Both files $nom_fichier_PMIOD and $nom_fichier_SMIOC are absent or invalid !" error
                            return 1
                        } else {
                            # Ajoute le composant à la liste
                            lappend dico_applis(app.$nom_appli.lcomp) $nom_comp
                        }
                    }

                    # Ajoute le composant à la liste des unités graphiques
                    set dico_units($nom_appli.$nom_comp) $nom_comp
                
                    # Ajoute tous les points d'échange (de couplage) de ce composant
                    # à la liste générale des points de couplage
                    if { ![info exists dico_applis(app.$nom_appli.comp.$nom_comp.lchamps)] } {
                        set dico_applis(app.$nom_appli.comp.$nom_comp.lchamps) {}
                    }
                    set liste_champs $dico_applis(app.$nom_appli.comp.$nom_comp.lchamps)
                    foreach nom_champ $liste_champs  {
                        set clef_base "$nom_appli.$nom_comp.$nom_champ"
            
                        # Si le champ de couplage est en entrée
                        if { [info exists dico_applis(app.$nom_appli.comp.$nom_comp.champ.$nom_champ.input)] } {
                            set clef "$clef_base.i"
                            lappend liste_points_i $clef
                            set dico_caract_points($clef.appli) $nom_appli
                            set dico_caract_points($clef.comp) $nom_comp
                            set dico_caract_points($clef.champ) $nom_champ
                        }
            
                        # Si le champ de couplage est en sortie
                        if { [info exists dico_applis(app.$nom_appli.comp.$nom_comp.champ.$nom_champ.output)] } {
                            set clef "$clef_base.o"
                            lappend liste_points_o $clef
                            set dico_caract_points($clef.appli) $nom_appli
                            set dico_caract_points($clef.comp) $nom_comp
                            set dico_caract_points($clef.champ) $nom_champ
                        }
                    }
                }
            }
        }
    }
    return 0
}

ret  {lit_element_date} (type elt_, type parent , type prefixe) {
# Lit dans le fichier SCC.XML la date de "start" ou "end" de "experiment" ou "run"
#
# Paramètres d'entrée :
#  - elt_parent :   element XML qui contient le sous-element "date"
#  - prefixe : préfixe de la clef permettant d'accéder au valeurs dans le dictionnaire global "dico_experiment"
#
    global dico_experiment
    
    # Initialisation des champs de la date
    foreach champ { year month day hour minute second } {
        set dico_experiment($prefixe.$champ) ""
    }
    
    # Accède au sous-element XML "date"
    set date_elt [lit_1er_sous_element $elt_parent]
    # Lit les sous-éléments de l'élément <date>
    set ss_elem_list [dom::node children $date_elt]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name != "#text" && $name != "#comment"} {
            # La var. $name contient une des valeurs suivantes : year month day hour minute second 
            # Extrait la valeur du sous-element year month day hour minute ou second 
            set ss_elem [dom::node configure $element -firstChild]
            set value [dom::node configure $ss_elem -nodeValue]
            set dico_experiment($prefixe.$name) $value
        }
    }
}

ret  {lit_element_exchange_date} (type element_, type XML) {
# Lit un élément XML de type <exchange_date> (période des échanges)
#
# Retourne une liste contenant l'unité de temps de la période des échanges (year, month, day,...)
# et le nombre d'unités.
#
# On suppose qu'il n'y a qu'une seule unité de temps. En fait, la période peut etre définie
# par plusieurs unités de temps, par exemple : 2 heures 30 minutes
# Mais ce cas n'est pas pris en charge.
    
    # Accède au sous-élément <period> : le premier sous-element de <exchange_date>
    set period_elt [lit_1er_sous_element $element_XML]
    
    # Accède au premier sous-element de <period> : year, month, day ou autre
    set ss_elt_unite [lit_1er_sous_element $period_elt]
    set unite [dom::node configure $ss_elt_unite -nodeName]
    
    # Lit la valeur du sous-élément
    set txt_elem [dom::node configure $ss_elt_unite -firstChild]
    set valeur [dom::node configure $txt_elem -nodeValue]

    return [list $unite $valeur]
}

ret  {lit_element_file} (type element_, type XML , type nom_, type dico) {
# Lit un élément XML de type <file>
#
# Remplit un dictionnaire contenant tous les parametres du fichier
# Retourne le nom du fichier.
#
    upvar 1 $nom_dico dico_fichier

    # Initialise la structure de donnees
    set dico_fichier(suffix) false
    set dico_fichier(io_mode) iosingle

    # Lit les sous-éléments de l'élément <file>
    set ss_elem_list [dom::node children $element_XML]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name != "#text" && $name != "#comment"} {
            set value [lit_XML_texte $element]
            set dico_fichier($name) $value
        }
    }
    return $dico_fichier(name)
}

ret  {lit_element_input} (type element_, type XML , type nom_, type appli , type nom_, type comp , type nom_, type champ , type PMIOD_, type ou_, type SMIOC) {
# Lit l'élément input d'un fichier SMIOC.xml
# en particulier les éléments XML concernant la connexion arrivant a ce point couplage
#
# Parametres d'entrée :
#   - element_XML :      élément XML de type <output>
#   - nom_appli :        nom de l'application
#   - nom_comp :         nom du composant
#   - nom_champ :        nom du champ de couplage
#   - PMIOD_ou_SMIOC :   vaut PMIOD ou SMIOC
#

    global dico_applis
    
    global liste_points_i liste_points_o dico_caract_points
    global liste_cnx_in dico_cnx_out dico_caract_cnx
    
    global liste_fichiers dico_caract_fichiers
    global dico_units
    
    # Lit les sous-éléments de l'élément <input>
    # ------------------------------------------
    
    set ss_elem_list [dom::node children $element_XML]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        switch $name {
            exchange_date {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    set exch_date [lit_element_exchange_date $element]
                }
            }
            
            origin {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    array set cnx_attribute {}
                    array set dico_fichier {}
                    set origin [lit_element_origin $element cnx_attribute dico_fichier]
                    set nom_comp_source [lindex $origin 0]
                    set nom_corresp [lindex $origin 1]
                }
            }
            
            target_transformation {
                array set cnx_attribute {}
                lit_element_src_tgt_transfo $element cnx_attribute target $PMIOD_ou_SMIOC
            }
            
            debug_mode {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    # Lit la valeur du sous-élément <debug_mode> : a priori = "true"
                    set txt_elem [dom::node configure $element -firstChild]
                    set cnx_attribute(dbg_cible) [dom::node configure $txt_elem -nodeValue]
                }
            }
        }
    }
   
    # Si on lit un fichier SMIOC
    if {$PMIOD_ou_SMIOC == "SMIOC"} {
        
        # Crée une nouvelle connexion
        # ---------------------------
        
        # Préfixe de la clef des éléments à mettre dans les dictionnaires dico_caract_points et dico_caract_cnx
        set prefixe "$nom_appli.$nom_comp.$nom_champ"
        # Mémorise que le point de couplage entrant est connecté
        lappend dico_caract_points($prefixe.i.lcnx) i
    
        # Si la cible est un composant d'une application
        if {$nom_comp_source != ""} {
            # Recherche le nom de l'application à partir du nom du composant
            foreach nom_appli_source $dico_applis(lapplis) {
                if {[lsearch $dico_applis(app.$nom_appli_source.lcomp) $nom_comp_source] != -1} {
                    break
                }
            }
            # La source de la connexion, extraite du SMIOC et mémorisée dans la variable "nom_corresp" 
            #    est décrite ainsi :  <nom-champ>_out<numero>
            # Il faut extraire de cette chaine de caractères le nom du champ et le numéro de la connexion sortante
            regexp {^(.*)_out([0-9]*)$} $nom_corresp match_str nom_champ_source numero
        } else {
            # La cible de la connexion est un fichier NetCDF
            set nom_appli_source ///file///
            set nom_comp_source $dico_fichier(name)
            # Champ source
            set nom_champ_source $nom_corresp
            # Numéro de connexion sortant du point
            set numero 1
        }
    
        # Clef (index) de la connexion : celle de la connexion entrante, construite sur celle du point cible
        set clef_cnx_in $prefixe.i
        # Ajoute à la liste des connexions entrantes
        if {[lsearch $liste_cnx_in $clef_cnx_in] == -1} {
            lappend liste_cnx_in $clef_cnx_in
        }
        # Clef de la connexion sortante : construite d'apres celle du point source
        set clef_cnx_out $nom_appli_source.$nom_comp_source.$nom_champ_source.o$numero
        # Ajoute au dico des connexions sortantes
        set dico_cnx_out($clef_cnx_out) $clef_cnx_in
    
        # Renseigne les caractéristiques de la nouvelle connexion
        # -------------------------------------------------------
    
        # Source et cible
        set dico_caract_cnx($clef_cnx_in.app_source)   $nom_appli_source
        set dico_caract_cnx($clef_cnx_in.app_cible)    $nom_appli
        set dico_caract_cnx($clef_cnx_in.comp_source)  $nom_comp_source
        set dico_caract_cnx($clef_cnx_in.comp_cible)   $nom_comp
        set dico_caract_cnx($clef_cnx_in.champ_source) $nom_champ_source
        set dico_caract_cnx($clef_cnx_in.champ_cible)  $nom_champ
        set dico_caract_cnx($clef_cnx_in.pt_source)    o$numero
    
        # Période des échanges
        set dico_caract_cnx($clef_cnx_in.exch_per_unit)  [lindex $exch_date 0]
        set dico_caract_cnx($clef_cnx_in.exch_per_val)   [lindex $exch_date 1]
    
        # Initialise les autres caractéristiques
        foreach {caract default_value} {
            dbg_cible false
            stat_cible_mask false
            stat_cible_nmsk false
            stat_cible_all false
            tgt_time_op  {}
            tgt_add_val  0
            tgt_mult_val 1
            remail {}   } {
            set dico_caract_cnx($clef_cnx_in.$caract) $default_value
        }
    
        # Renseigne les vraies valeurs pour ces autres caractéristiques
        foreach {name value} [array get cnx_attribute] {
            set dico_caract_cnx($clef_cnx_in.$name) $value
        }

        # Si la source est un fichier NetCDF
        if {$nom_appli_source == "///file///"} {
            # Met a zéro des caractéristiques qui ne sont pas significatives 
            # pour une connexion depuis un fichier
            foreach {caract default_value} {
                lag {} 
                dbg_source false
                stat_source_mask false
                stat_source_nmsk false
                stat_source_all false
                src_time_op  {}
                src_add_val  0
                src_mult_val 1 } {
                set dico_caract_cnx($clef_cnx_in.$caract) $default_value
            }
        }
        
        # Mémorise la source si c'est un fichier
        # --------------------------------------
    
        # Si la source est un fichier NetCDF
        if {$nom_appli_source == "///file///"} {
            # Ajoute le fichier a la liste
            set id_fichier $nom_comp_source
            lappend liste_fichiers $id_fichier
    
            # Renseigne les caractéristiques du fichier
            set dico_caract_fichiers($id_fichier.dir) input
            set dico_caract_fichiers($id_fichier.name) $nom_comp_source
            set dico_caract_fichiers($id_fichier.io_mode) $dico_fichier(io_mode)
            set dico_caract_fichiers($id_fichier.suffix) $dico_fichier(suffix)
            set dico_caract_fichiers($id_fichier.lchamps) $nom_champ_source
    
            # Renseigne les caractéristiques du champ du fichier
            if {[info exists dico_fichier(fill_value)]} {
                set dico_caract_fichiers($id_fichier.$nom_champ_source.fill_value) $dico_fichier(fill_value)
            } else {
                set dico_caract_fichiers($id_fichier.$nom_champ_source.fill_value) ""
            }
            # type numérique est celui du champ cible
            set dico_caract_fichiers($id_fichier.$nom_champ_source.type) $dico_applis(app.$nom_appli.comp.$nom_comp.champ.$nom_champ.datatype)
    
            # Crée le point de couplage du fichier
            set clef_pt_source $nom_appli_source.$nom_comp_source.$nom_champ_source.o
            lappend liste_points_o $clef_pt_source
            # Renseigne les caractéristiques du point de couplage
            set dico_caract_points($clef_pt_source.appli) $nom_appli_source
            set dico_caract_points($clef_pt_source.comp)  $id_fichier
            set dico_caract_points($clef_pt_source.champ) $nom_champ_source
            set dico_caract_points($clef_pt_source.lcnx)  o1
    
            # Crée une nouvelle unité sur le graphe de couplage
            set dico_units(///file///.$id_fichier) $id_fichier
        }
    }
}

ret  {lit_element_intent} (type element_, type XML , type nom_, type dico , type nom_, type appli , type nom_, type comp , type nom_, type champ , type PMIOD_, type ou_, type SMIOC) {
# Lit dans un fichier XML (PMIOD ou SMIOC) d'un composant un élément <intent>
#
# Parametres d'entrée :
#   - element_XML :      élément XML de type <transient>
#   - nom_dico  :        nom du dictionnaire à remplir (habituellement dico_applis)
#   - nom_appli :        nom de l'application
#   - nom_comp :         nom du composant
#   - nom_champ :        nom du champ de couplage
#   - PMIOD_ou_SMIOC :   vaut PMIOD ou SMIOC
#
    upvar 1 $nom_dico dict_vars

   # Préfixe de la clef des éléments à mettre dans le dictionnaire
   set prefixe "app.$nom_appli.comp.$nom_comp.champ.$nom_champ"
   
   # Lit les sous-éléments de l'élément <transient>
   set ss_elem_list [dom::node children $element_XML]
   set nb_output 0
   foreach element $ss_elem_list  {
      set name [dom::node configure $element -nodeName]
      switch $name {
         output {
            # Compte le nombre de sorties (output) du même champ
            incr nb_output
            # Si ce point de couplage n'est pas encore mémorisé
            if {! [info exists dict_vars($prefixe.output)]} {
               # Cree un nouveau point de couplage
               # Mémorise que le point de couplage est "output"
               set dict_vars($prefixe.output) 1
               # Lit le sous-élément <minimal_period> de l'élément <output>
               set ss_elem_list [dom::node children $element]
               foreach sous_element $ss_elem_list  {
                  set name [dom::node configure $sous_element -nodeName]
                  if { $name == "minimal_period" } {
                     lit_element_min_period $sous_element dict_vars "$prefixe.o"
                     break
                  }
               }
            }
            # Si on s'interesse au point de couplage (PMIOD) 
            if {$PMIOD_ou_SMIOC == "PMIOD"} {
                # Si c'est la premiere sortie du champ
                if {$nb_output == 1} {
                    # Lit les infos concernant l'element scatter du point de couplage
                    set scatter [lit_element_output $element $nom_appli $nom_comp $nom_champ $PMIOD_ou_SMIOC]
                    set dict_vars($prefixe.o.scatter) $scatter
                }
            } else {
                # Lit les infos concernant la connexion partant de ce point de couplage
                lit_element_output $element $nom_appli $nom_comp $nom_champ $PMIOD_ou_SMIOC
            }
         }
         input {
            # Si ce point de couplage n'est pas encore mémorisé
            if {! [info exists dict_vars($prefixe.input)]} {
               # Mémorise que le point de couplage est "input"
               set dict_vars($prefixe.input) 1
               # Lit l'attribut "required_but_changeable" si présent
               set value [dom::element getAttribute $element "required_but_changeable"]
               set dict_vars($prefixe.i.rbc) $value
               # Lit le sous-élément <minimal_period> de l'élément <output>
               set ss_elem_list [dom::node children $element]
               foreach sous_element $ss_elem_list  {
                  set name [dom::node configure $sous_element -nodeName]
                  if { $name == "minimal_period" } {
                     lit_element_min_period $sous_element dict_vars "$prefixe.i"
                  }
               }
            }
            # Si on s'interesse au point de couplage (PMIOD) 
            if {$PMIOD_ou_SMIOC == "PMIOD"} {
                # Lit les infos concernant l'element gather du point de couplage
                set gather [lit_element_input $element $nom_appli $nom_comp $nom_champ $PMIOD_ou_SMIOC]
                set dict_vars($prefixe.i.gather) $gather
            } else {
               # Lit les infos concernant la connexion arrivant à ce point de couplage
               lit_element_input $element $nom_appli $nom_comp $nom_champ $PMIOD_ou_SMIOC
            }
         }
      }
   }
}

ret  {lit_element_liste_ss_elts} (type element_, type XML , type nom_, type dico , type nom_, type traduction) {
# Lit un élément XML donné composé d'une liste de sous-éléments simples
#
# Sauve en mémoire dans un dictionnaire les valeurs des sous-éléments.
# 
# Paramètres d'entrée :
#   - element_XML :       élément à lire
#   - nom_dico :          nom du dictionnaire à remplir
#   - nom_traduction :    nom du dictionnaire de traduction
#                         Ce dictionnaire donne la traduction des nom des sous-éléments en clefs du dictionnaire a remplir
#
    upvar 1 $nom_dico dico
    upvar 1 $nom_traduction traduction
    
    # Lit les sous-éléments de l'élément
    set ss_elem_list [dom::node children $element_XML]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name != "#text" && $name != "#comment"} {
            # Convertit le nom du sous-élément en clef
            set clef $traduction($name)
            # Lit le contenu du sous-élément
            set txt_elem [dom::node configure $element -firstChild]
            # S'il a un contenu
            if {$txt_elem != ""} {
                # Lit la valeur du contenu
                set value  [dom::node configure $txt_elem -nodeValue]
            } else {
                # Prend une valeur arbitraire de 1
                set value 1
            }
            # Mémorise le contenu du sous-élément
            set dico($clef) $value
        }
    }
}

ret  {lit_element_mid_transfo} (type element_, type XML , type nom_, type dico) {
# Lit un élément XML de type <middle_transformation>
#
# Remplit un dictionnaire contenant tous les parametres lus dans l'élément XML.
#
# Parametres d'entrée :
#   - element_XML :       élément XML
#   - nom_dico :          nom du dictionnaire a remplir
#
    upvar 1 $nom_dico cnx_attribute
    
    # Accède au sous-élément <interpolation> : le premier sous-élément
    set interpolation_elt [lit_1er_sous_element $element_XML]
    
    # Cherche le sous-élément <interp3D> ou <interp2D> de l'élément <interpolation>
    set ss_elem_list [dom::node children $interpolation_elt]
    foreach interp_elt $ss_elem_list  {
        set name [dom::node configure $interp_elt -nodeName]
        if {$name  == "interp3D" || $name == "interp2D"} { break }
    }
    
    # Initialise les attributs de la méthode de remaillage
    set cnx_attribute(nbr_neighbours)  0
    set cnx_attribute(if_masked)       no_value
    set cnx_attribute(bi3_method)      gradient
    set cnx_attribute(norm_method)     None
    set cnx_attribute(norm_near_nei)   false


    # Accède au premier et seul sous-élément de <interpxD>
    # qui est de type <nneighbour3D>, <trilinear>, <nneighbour2D>, <bilinear>, <bicubic> ou <conservativ2D>
    set method_elt [lit_1er_sous_element $interp_elt]
    # Mémorise la methode de remaillage
    set cnx_attribute(remail) [dom::node configure $method_elt -nodeName]

    # Lit les sous-éléments de l'élément "method_elt"
    set ss_elem_list [dom::node children $method_elt]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        switch $name {
            if_masked {
                # Lit la valeur du sous-élément
                set txt_elem [dom::node configure $element -firstChild]
                set cnx_attribute(if_masked) [dom::node configure $txt_elem -nodeValue]
            }
            bicubic_method {
                # Lit la valeur du sous-élément
                set txt_elem [dom::node configure $element -firstChild]
                set cnx_attribute(bi3_method) [dom::node configure $txt_elem -nodeValue]
            }
            nbr_neighbours {
                # Lit la valeur du sous-élément
                set txt_elem [dom::node configure $element -firstChild]
                set cnx_attribute(nbr_neighbours) [dom::node configure $txt_elem -nodeValue]
            }
            normalisation2D {
                # Lit les sous-éléments de l'élément <normalisation2D>
                set ss_elem_list [dom::node children $element]
                foreach element $ss_elem_list  {
                    set name [dom::node configure $element -nodeName]
                    switch $name {
                        methodnorm2D {
                            # Lit la valeur du sous-élément
                            set txt_elem [dom::node configure $element -firstChild]
                            set cnx_attribute(norm_method) [dom::node configure $txt_elem -nodeValue]
                        }
                        nearnei {
                            # Lit la valeur du sous-élément
                            set txt_elem [dom::node configure $element -firstChild]
                            set cnx_attribute(norm_near_nei) [dom::node configure $txt_elem -nodeValue]
                        }
                    }
                }
            }
        }
    }
}

ret  {lit_element_min_period} (type element_, type XML , type nom_, type dico , type prefixe) {
upvar 1 $nom_dico dict_vars

    # Lit les sous-éléments de l'élément <minimal_period>
    set ss_elem_list [dom::node children $element_XML]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        set value [lit_XML_texte $element]
        set dict_vars($prefixe.$name) $value
    }
}

ret  {lit_element_nbr_proc} (type element_, type XML , type nom_, type dico , type prefixe) {
# Lit un element XML de type <nbr_proc>
    
    upvar 1 $nom_dico dict_vars
    # Lit les sous-éléments de l'élément <nbr_proc>
    set ss_elem_list [dom::node children $element_XML]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name != "#text" && $name != "#comment"} {
            set value [lit_XML_texte $element]
            set dict_vars($prefixe.$name) $value
        }
    }
    # Complete les informations si necessaire
    if { ![info exists dict_vars($prefixe.max_value)] } {
         catch {set dict_vars($prefixe.max_value) $dict_vars($prefixe.min_value)}
    }
    if { [info exists dict_vars($prefixe.min_value)] && ![info exists dict_vars($prefixe.increment)] } {
         set dict_vars($prefixe.increment) 1
    }
}

ret  {lit_element_origin} (type element_, type XML , type nom_, type dico_, type cnx , type nom_, type dico_, type fichier) {
# Lit un élément XML de type <origin>, qui est sous-élément de <input>
# et qui décrit l'origine d'une connexion avec un champ de couplage.
#
# Retourne une liste contenant le nom du composant source et le nom du champ source.
# Renseigne un dictionnaire avec les caractéristiques de la connexion
# Si la source de la connexion est un fichier, renseigne un dictionnaire
# avec les caractéristiques du fichier.
#
    upvar 1 $nom_dico_cnx dico_cnx
    upvar 1 $nom_dico_fichier dico_fichier
    set nom_comp_source ""
    set nom_corresp ""
    
    # Lit les sous-éléments de l'élément <origin>
    # -------------------------------------------
    
    set ss_elem_list [dom::node children $element_XML]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        switch $name {
            corresp_transi_out_name {
                # Lit la valeur du sous-élément <corresp_transi_out_name>
                set txt_elem [dom::node configure $element -firstChild]
                set nom_corresp [dom::node configure $txt_elem -nodeValue]
            }

            component_name {
                # Lit la valeur du sous-élément <component_name>
                set txt_elem [dom::node configure $element -firstChild]
                set nom_comp_source [dom::node configure $txt_elem -nodeValue]
            }
            
            middle_transformation {
                lit_element_mid_transfo $element dico_cnx
            }

            file {
                lit_element_file $element dico_fichier
            }
        }
    }
    return [list $nom_comp_source $nom_corresp]
}

ret  {lit_element_output} (type element_, type XML , type nom_, type appli , type nom_, type comp , type nom_, type champ , type PMIOD_, type ou_, type SMIOC) {
# Lit l'élément output d'un fichier PMIOD.xml ou SMIOC.xml
# Pour un fichier PMIOD :
#    cherche l'info <scatter> du point de couplage en question
#
# Pour un fichier SMIOC :
#    lit les éléments XML concernant la connexion partant de ce point couplage
#
# Parametres d'entrée :
#   - element_XML :      élément XML de type <output>
#   - nom_appli :        nom de l'application
#   - nom_comp :         nom du composant
#   - nom_champ :        nom du champ de couplage
#   - PMIOD_ou_SMIOC :   vaut PMIOD ou SMIOC
#
# Valeur de retour
#   - Pour un fichier PMIOD, 1 si l'info <scatter> est presente, 0 sinon
#   - Pour un fichier SMIOC, rien
#
    global dico_applis
    
    global liste_points_i liste_points_o dico_caract_points
    global liste_cnx_in dico_cnx_out dico_caract_cnx
    
    global liste_fichiers dico_caract_fichiers
    global dico_units
    
    # Lit les sous-éléments de l'élément <output>
    # -------------------------------------------
    
    set ss_elem_list [dom::node children $element_XML]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        switch $name {
            exchange_date {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    set exch_date [lit_element_exchange_date $element]
                }
            }
            
            corresp_transi_in_name {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    # Lit la valeur du sous-élément <corresp_transi_in_name>
                    set txt_elem [dom::node configure $element -firstChild]
                    set corresp_name [dom::node configure $txt_elem -nodeValue]
                }
            }
            
            file {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    array set dico_fichier {}
                    set output_file [lit_element_file $element dico_fichier]
                }
            }

            component_name {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    # Lit la valeur du sous-élément <component_name>
                    set txt_elem [dom::node configure $element -firstChild]
                    set nom_comp_cible [dom::node configure $txt_elem -nodeValue]
                }
            }

            lag {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    # Lit la valeur du sous-élément <lag>
                    set txt_elem [dom::node configure $element -firstChild]
                    set cnx_attribute(lag) [dom::node configure $txt_elem -nodeValue]
                }
            }

            source_transformation {
                array set cnx_attribute {}
                lit_element_src_tgt_transfo $element cnx_attribute source $PMIOD_ou_SMIOC
            }
            
            debug_mode {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    # Lit la valeur du sous-élément <debug_mode> : a priori = "true"
                    set txt_elem [dom::node configure $element -firstChild]
                    set cnx_attribute(dbg_source) [dom::node configure $txt_elem -nodeValue]
                }
            }
        }
    }
   
    # Si on lit un fichier PMIOD
    if {$PMIOD_ou_SMIOC == "PMIOD"} {
        # Retourne l'attribut <scattering> du point de couplage
        return [info exists cnx_attribute(scatter)]
    
    # Si on lit un fichier SMIOC
    } else {

        # Crée une nouvelle connexion
        # ---------------------------
        
        # Préfixe de la clef des éléments à mettre dans les dictionnaires dico_caract_points et dico_caract_cnx
        set prefixe "$nom_appli.$nom_comp.$nom_champ"
        
        # Lit l'attribut "transi_out_name"
        set value [dom::element getAttribute $element_XML "transi_out_name"]
    
        # L'élément <output> que l'on lit décrit une connexion sortante
        # Le numéro de la cnx est celui de l'attribut "transi_out_name"
        # "transi_out_name" a la forme <nom_champ>_out*** ou *** est un nombre
        set num_output [string range $value [string length "${nom_champ}_out"] end]

        # Ajoute la connexion a la liste
        lappend dico_caract_points($prefixe.o.lcnx) o$num_output
        
        # Clef de la connexion sortante : construite d'apres celle du point source
        set clef_cnx_out $prefixe.o$num_output
        
        # Si la cible est un composant d'une application
        if {[info exists nom_comp_cible]} {
            # Recherche le nom de l'application a partir du nom du composant
            foreach nom_appli_cible $dico_applis(lapplis) {
                if {[lsearch $dico_applis(app.$nom_appli_cible.lcomp) $nom_comp_cible] != -1} {
                    break
                }
            }
            # Nom du champ cible :  <nom-champ>_in<numero> ou  <numero> est normalement absent
            # Il faut extraire de cette chaine de caractères le nom du champ
            regexp {^(.*)_in[0-9]*$} $corresp_name match_str nom_champ_cible
        } else {
            # La cible de la connexion est un fichier NetCDF
            set nom_appli_cible ///file///
            set nom_comp_cible [NetCDF_file_cree_nouvel_id]
            # Champ cible = "field"; le nom reel du champ sera indiqué ailleurs
            set nom_champ_cible field
        }
    
        # Clef (index) de la connexion : celle de la connexion entrante, construite sur celle du point cible
        set clef_cnx_in $nom_appli_cible.$nom_comp_cible.$nom_champ_cible.i
        # Ajoute à la liste des connexions entrantes
        if {[lsearch $liste_cnx_in $clef_cnx_in] == -1} {
            lappend liste_cnx_in $clef_cnx_in
        }
        # Ajoute au dico des connexions sortantes
        set dico_cnx_out($clef_cnx_out) $clef_cnx_in
    
        # Renseigne les caractéristiques de la nouvelle connexion
        # -------------------------------------------------------
        
        # Source et cible
        set dico_caract_cnx($clef_cnx_in.app_source)   $nom_appli
        set dico_caract_cnx($clef_cnx_in.app_cible)    $nom_appli_cible
        set dico_caract_cnx($clef_cnx_in.comp_source)  $nom_comp
        set dico_caract_cnx($clef_cnx_in.comp_cible)   $nom_comp_cible
        set dico_caract_cnx($clef_cnx_in.champ_source) $nom_champ
        set dico_caract_cnx($clef_cnx_in.champ_cible)  $nom_champ_cible
        set dico_caract_cnx($clef_cnx_in.pt_source)    o$num_output
    
        # Période des échanges
        set dico_caract_cnx($clef_cnx_in.exch_per_unit)  [lindex $exch_date 0]
        set dico_caract_cnx($clef_cnx_in.exch_per_val)   [lindex $exch_date 1]
    
        # Initialise les autres caractéristiques
        foreach {caract default_value} {
            lag {} 
            dbg_source false
            stat_source_mask false
            stat_source_nmsk false
            stat_source_all false
            src_time_op  {}
            src_add_val  0
            src_mult_val 1 } {
            set dico_caract_cnx($clef_cnx_in.$caract) $default_value
        }
    
        # Renseigne les vraies valeurs pour ces autres caractéristiques
        foreach {name value} [array get cnx_attribute] {
            set dico_caract_cnx($clef_cnx_in.$name) $value
        }
    
        # Si la cible est un fichier NetCDF
        if {[info exists output_file]} {
            # Met a zéro des caractéristiques qui ne sont pas significatives 
            # pour une connexion vers un fichier
            foreach {caract default_value} {
                dbg_cible false
                stat_cible_mask false
                stat_cible_nmsk false
                stat_cible_all false
                tgt_time_op  {}
                tgt_add_val  0
                tgt_mult_val 1
                gather  false
                remail {}   } {
                set dico_caract_cnx($clef_cnx_in.$caract) $default_value
            }
        }
        
        # Mémorise la cible si c'est un fichier
        # -------------------------------------
        
        # Si la cible est un fichier NetCDF
        if {[info exists output_file]} {
            # Ajoute le fichier à la liste
            set id_fichier $nom_comp_cible
            lappend liste_fichiers $id_fichier
    
            # Renseigne les caractéristiques du fichier
            set dico_caract_fichiers($id_fichier.dir) output
            set dico_caract_fichiers($id_fichier.name) $output_file
            set dico_caract_fichiers($id_fichier.io_mode) $dico_fichier(io_mode)
            set dico_caract_fichiers($id_fichier.suffix) $dico_fichier(suffix)
            set dico_caract_fichiers($id_fichier.lchamps) field
    
            # Renseigne les caractéristiques du champ du fichier
            # Nom exact du champ
            set dico_caract_fichiers($id_fichier.field.name) $corresp_name
            # Autres caractéristiques 
            foreach caractere {packing scaling adding fill_value} {
                if {[info exists dico_fichier($caractere)]} {
                    set dico_caract_fichiers($id_fichier.field.$caractere) $dico_fichier($caractere)
                } else {
                    set dico_caract_fichiers($id_fichier.field.$caractere) ""
                }
            }
            # type numérique est celui du champ source
            set dico_caract_fichiers($id_fichier.field.type) $dico_applis(app.$nom_appli.comp.$nom_comp.champ.$nom_champ.datatype)
    
            # Crée le point de couplage du fichier
            lappend liste_points_i $clef_cnx_in
            # Renseigne les caractéristiques du point de couplage
            set dico_caract_points($clef_cnx_in.appli) $nom_appli_cible
            set dico_caract_points($clef_cnx_in.comp)  $id_fichier
            set dico_caract_points($clef_cnx_in.champ) field
            set dico_caract_points($clef_cnx_in.lcnx)  i
            
            # Crée une nouvelle unité sur le graphe de couplage
            set dico_units(///file///.$id_fichier) $id_fichier
        }
    }
}

ret  {lit_element_rank} (type element , type prefixe) {
# Lit dans un fichier SCC.xml le contenu d'un élément de type <rank>
#  qui peut contenir trois sous-éléments : min_value, max_value et increment
# min_value est toujours présent.
#
# Paramètres d'entrée :
#  - element : element XML de type "rank"
#  - prefixe : préfixe de la clef permettant d'accéder au valeurs dans le dictionnaire global "dico_applis"
#
    global dico_applis

    # Lit les sous-éléments de l'élément <rank>
    set ss_elem_list [dom::node children $element]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name != "#text" && $name != "#comment"} {
            switch $name {
                min_value {
                    # Lit la valeur du sous-élément "min_value"
                    set txt_elem [dom::node configure $element -firstChild]
                    set value [dom::node configure $txt_elem -nodeValue]
                    set dico_applis($prefixe.min_rank) $value
                }
                max_value {
                    # Lit la valeur du sous-élément "max_value"
                    set txt_elem [dom::node configure $element -firstChild]
                    set value [dom::node configure $txt_elem -nodeValue]
                    set dico_applis($prefixe.max_rank) $value
                }
                increment {
                    # Pour l'instant, valeur ignorée
                }
            }
        }
    }
}

ret  {lit_element_src_tgt_transfo} (type element_, type XML , type nom_, type dico , type source_, type ou_, type target , type PMIOD_, type ou_, type SMIOC) {
# Lit un élément XML de type <source_transformation> ou <target_transformation>
#
# Remplit un dictionnaire contenant tous les parametres lus dans l'élément XML.
#
# Parametres d'entrée :
#   - element_XML :       élément XML
#   - nom_dico :          nom du dictionnaire a remplir
#   - source_ou_target :  source ou target selon le type d'élément XML
#   - PMIOD_ou_SMIOC :    vaut PMIOD ou SMIOC
#
    upvar 1 $nom_dico cnx_attribute

    # Lit les sous-éléments de l'élément <source_transformation>
    set ss_elem_list [dom::node children $element_XML]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        switch $name {
            source_time_operation -
            target_time_operation {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    # Opération sur le temps à la source ou à la cible
                    # Lit la valeur du sous-élément
                    set txt_elem [dom::node configure $element -firstChild]
                    if { $source_ou_target == "source" } {set clef src} else {set clef tgt}
                    set cnx_attribute(${clef}_time_op) [dom::node configure $txt_elem -nodeValue]
                }
            }
            statistics {
                # Si on lit un fichier SMIOC
                if {$PMIOD_ou_SMIOC == "SMIOC"} {
                    # Lit les sous-éléments de l'élément <statistics>
                    # Traduit les sous-éléments XML (masked_points, notmasked_points, all_points) en autres mots-clefs
                    if { $source_ou_target == "source" } {set clef source} else {set clef cible}
                    array unset traduction
                    array set traduction "
                        masked_points stat_${clef}_mask 
                        notmasked_points stat_${clef}_nmsk 
                        all_points stat_${clef}_all
                        "
                    lit_element_liste_ss_elts $element cnx_attribute traduction
                }
            }
            source_local_transformation -
            target_local_transformation {
                # Lit les sous-éléments de l'élément <...._local_transformation>
                # Traduit les sous-éléments XML (scattering, add_scalar, mult_scalar) en autres mots-clefs
                if { $source_ou_target == "source" } {set clef src} else {set clef tgt}
                array unset traductionert
                array set traduction "
                    gathering gather
                    scattering scatter 
                    add_scalar ${clef}_add_val 
                    mult_scalar ${clef}_mult_val
                    "
                lit_element_liste_ss_elts $element cnx_attribute traduction
            }
        }
    }
}

ret  {lit_fichier_AD} (type nom_, type fichier , type nom_, type dico , type nom_, type lcomp_, type ajout) {
# Lit et décode un fichier XML contenant une AD (Application Description)
# Lit aussi tous les fichiers PMIOD des composants listés dans ce fichier AD.
# Suppose que les fichiers PMIOD sont dans le même répertoire que le fichier AD.
#

    # Accède à la variable dont le nom est $nom_dico
    upvar 1 $nom_dico dict_vars
    # Accède à la liste des composants ajoutés
    upvar 1 $nom_lcomp_ajout liste_comp_ajoutes
    
    # Déclare toutes les variables globales
    global dico_caract_points
    global dico_units
    
    # Lit le document à manipuler
    set text [read [open $nom_fichier]]
    if { [string trim $text] != "" } {
        set code_erreur [catch {set doc [dom::parse $text]} msg_erreur]
        if {$code_erreur} {
            notice_show "Error parsing file \"$nom_fichier\" :\n $msg_erreur" error
            return 1
        }
    } else {
        # Fichier vide
        notice_show "Error parsing file \"$nom_fichier\" :\n file is empty" error
        return 1
    }
    
    # Extrait le nom de l'appli du nom du fichier : exemple "ocea4" extrait de "/chemin/de/oceoa4_ad.xml"
    if {[string match "*_ad.xml" $nom_fichier]} {
        set file_name [file tail $nom_fichier]
        set dir_name [file dirname $nom_fichier]
        set nom_appli [string range $file_name 0 end-7]
    } else {
        return 1
    }
    # Fait quelques vérifications
    if {! [dom::node hasChildNodes $doc] } {
        return 1
    }
    
    # Récupère le premier élément du document
    # C'est l'élément principal (qui est de type <Application>)
    set element1 [dom::document configure $doc -documentElement]
    if { [dom::node configure $element1 -nodeType] != "element" } {
        return 1
    }
    if { [dom::node configure $element1 -nodeName] != "application" } {
        return 1
    }
    
    # Lit les attributs de l'élément <Application>
    set att [dom::node configure $element1 -attributes]
    foreach {name value} [array get $att] {
        set dict_vars(app.$nom_appli.$name) $value
    }
    
    # Vérifie que l'attribut "local_name" correspond au nom de l'appli
    set local_name $dict_vars(app.$nom_appli.local_name)
    if {$local_name != $nom_appli} {
        notice_show "Local name of application \"$local_name\" is not consistent with file name \"$nom_fichier\" !" error
    }
    
    # A ce stade, l'appli est OK : on l'enregistre dans la liste
    lappend dict_vars(lapplis) $nom_appli
    
    # Lit les sous-éléments de l'élément <application>
    set ss_elem_list [dom::node children $element1]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name != "#text" && $name != "#comment"} {
            switch $name {
                nbr_procs {
                    lit_element_nbr_proc $element dict_vars "app.$nom_appli.proc"
                }
    
                platform {
                    set ss_elem [dom::node configure $element -firstChild]
                    set value [dom::node configure $ss_elem -nodeValue]
                    # Ajoute la plate-forme à la liste des plate-formes
                    if { [info exists dict_vars(app.$nom_appli.lplatforms)] } {
                        lappend dict_vars(app.$nom_appli.lplatforms) $value
                    } else {
                        set dict_vars(app.$nom_appli.lplatforms) $value
                    }
                }
    
                component {
                    # Lit les attributs local_name, long_name, simulated, etc..
                    set att [dom::node configure $element -attributes]
                    set component_name [load_XML_attributes $att dict_vars "app.$nom_appli.comp"]
                    # Ajoute le composants à la liste des composants
                    if { [info exists dict_vars(app.$nom_appli.lcomp)] } {
                        lappend dict_vars(app.$nom_appli.lcomp) $component_name
                    } else {
                        set dict_vars(app.$nom_appli.lcomp) $component_name
                    }
        
                    # Lit le sous-élément nbr_procs
                    set ss_elem_list [dom::node children $element]
                    foreach element $ss_elem_list  {
                        set name [dom::node configure $element -nodeName]
                        if {$name == "nbr_procs"} {
                            lit_element_nbr_proc $element dict_vars "app.$nom_appli.comp.$component_name.proc"
                            break
                        }
                    }
                    # Lit le fichier PMIOD du composant
                    set nom_fichier_PMIOD [file join $dir_name "$nom_appli\_$component_name\_pmiod.xml"]
                    set result [lit_fichier_component $nom_fichier_PMIOD dict_vars $nom_appli $component_name PMIOD]
        
                    # Si erreur
                    if { $result != 0 } {
                        notice_show  "Pb à la lecture du fichier $nom_fichier_PMIOD" error 
                    } else {
                        # Ajoute le composant à la liste
                        lappend liste_comp_ajoutes $nom_appli.$component_name
                        set dico_units($nom_appli.$component_name) $component_name
                    }
                }
            }
        }
    }
    
    # Ajoute le nom de l'appli à la liste
    if { [info exists dict_vars(liste-applis)] } {
        lappend dict_vars(liste-applis) $nom_appli
    } else {
        set dict_vars(liste-applis) $nom_appli
    }
    # Libère la mémoire
    ::dom::DOMImplementation destroy $doc
    return 0
}
    
ret  {lit_fichier_Graphics} (type nom_, type fichier) {
# Lit le fichier Graphics.xml contenant les attributs graphiques des unités du graphe de couplage

    global dico_applis liste_fichiers dico_units 
    global dico_caract_fichiers
    
    if {! [file isfile $nom_fichier]} {
        return 1
    }
    
    # Lit le document à manipuler
    set text [read [open $nom_fichier]]
    set doc [dom::parse $text]
    
    # Récupère le premier élément du document
    # C'est l'élément principal (qui est de type <scc>)
    set element1 [dom::document configure $doc -documentElement]
    if { [dom::node configure $element1 -nodeType] != "element" } {
        return 1
    }
    if { [dom::node configure $element1 -nodeName] != "graphics" } {
        return 1
    }
    
    # Lit les sous-éléments de l'élément <graphics>
    set ss_elem_list [dom::node children $element1]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name == "component" || $name == "file"} {
            # Lit les attributs : name, application, coor_x, coor_y, colour, expand
            set att [dom::node configure $element -attributes]

            # Nom de l'application
            switch $name {
                component {
                    # Nom de l'application
                    set nom_appli [set ${att}(application)]
                    # Nom du composant
                    set nom_comp [set ${att}(name)]
                    # Clef de l'unité dans le dictionnaire dico_units
                    set clef_unit $nom_appli.$nom_comp
                    set si_trouve 1
                }
                file {
                    # Nom du fichier
                    set nom_fichier [set ${att}(name)]
                    # Recherche l'id du fichier qui a ce nom
                    set si_trouve 0
                    foreach {attrib value} [array get dico_caract_fichiers "*.name"] {
                        if {$value == $nom_fichier} {
                            set si_trouve 1
                            # Identifiant du fichier dans le dictionnaire dico_caract_fichiers :
                            #   c'est la même que $attrib moins l'extension .name
                            set id_fichier [string range $attrib 0 end-5]
                            # Clef de l'unité dans le dictionnaire dico_units
                            set clef_unit ///file///.$id_fichier
                            break 
                        }
                    }
                }
            }
            if { $si_trouve } {
                # Mémorise les attributs graphiques de l'unité
                foreach attribut {coor_x coor_y colour expand} {
                    set dico_units($clef_unit.$attribut) [set ${att}($attribut)]
                }
            }
        }
    }
    
    # Libère la mémoire
    ::dom::DOMImplementation destroy $doc
    
    return 0
}

ret  {lit_fichier_SCC} (type nom_, type fichier) {
# Lit et décode un fichier XML contenant un SCC (Coupling Configuration) auparavant généré par ce programme
# Lit aussi tous les fichiers AD des application listés dans ce fichier SCC, si ils existent.
# Lit aussi tous les fichiers PMIOD des composants listés dans les fichiers AD, si ils existent.
#
# Lit aussi tous les fichiers SMIOC des composants listés dans ce fichier SCC
# et recrée toutes les connexions qui sont décrites dans ces fichiers.
# Suppose que les fichiers SMIOC sont dans le même répertoire que le fichier SCC.
#
# Si un fichier SMIOC est manquant, ça peut être une erreur grave 
# car il peut alors manquer une extrémité cible ou source d'une connexion sur le graphe de couplage.
#
# Si un fichier AD ou PMIOD est manquant, on compense avec les fichiers respectifs SCC et SMIOC.
# Au pire, il manquera des points de couplage de composants mais qui ne seront pas connectés de toute façon.
#
    global dico_applis
    global liste_fichiers dico_caract_fichiers
    global dico_experiment

    # Repertoire du fichier a lire
    set dir_name [file dirname $nom_fichier]

    # Lit le document à interprêter
    set text [read [open $nom_fichier]]
    if { [string trim $text] != "" } {
        set code_erreur [catch {set doc [dom::parse $text]} msg_erreur]
        if {$code_erreur} {
            notice_show "Error parsing file \"$nom_fichier\" :\n $msg_erreur" error
            return 1
        }
    } else {
        # Fichier vide
        notice_show "Error parsing file \"$nom_fichier\" :\n file is empty" error
        return 1
    }

    # Récupère le premier élément du document
    # C'est l'élément principal (qui est de type <scc>)
    set element1 [dom::document configure $doc -documentElement]
    if { [dom::node configure $element1 -nodeType] != "element" } {
        return 1
    }
    if { [dom::node configure $element1 -nodeName] != "scc" } {
        return 1
    }
    
    # Lit les sous-éléments de l'élément <scc>
    set ss_elem_list [dom::node children $element1]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name != "#text" && $name != "#comment"} {
            switch $name {
                experiment {
                    # Lit les attributs local_name, long_name, start_mode
                    set att [dom::node configure $element -attributes]
                    set dico_experiment(name)       [set ${att}(local_name)]
                    set dico_experiment(long_name)  [set ${att}(long_name)]
                    set dico_experiment(start_mode) [set ${att}(start_mode)]

                    # Accède aux sous-elements
                    set ss_elem_list [dom::node children $element]
                    foreach element $ss_elem_list  {
                        set name [dom::node configure $element -nodeName]
                        if {$name != "#text" && $name != "#comment"} {
                            switch $name {
                                driver {
                                    # Accède au sous-élément "nbr_procs" : le premier sous-element de "driver"
                                    set nbr_procs_elt [lit_1er_sous_element $element]
                                    # Lit la valeur du sous-élément "nbr_procs"
                                    set txt_elem [dom::node configure $nbr_procs_elt -firstChild]
                                    set value [dom::node configure $txt_elem -nodeValue]
                                    set dico_experiment(drv_procs) $value
                                }
                                start_date {
                                    lit_element_date $element start
                                }
                                end_date {
                                    lit_element_date $element end
                                }
                            }
                        }
                    }
                }                
                run {
                    # Accède aux sous-elements
                    set ss_elem_list [dom::node children $element]
                    foreach element $ss_elem_list  {
                        set name [dom::node configure $element -nodeName]
                        if {$name != "#text" && $name != "#comment"} {
                            switch $name {
                                start_date {
                                    lit_element_date $element run_start
                                }
                                end_date {
                                    lit_element_date $element run_end
                                }
                            }
                        }
                    }
                }
                application {
                    set erreur [lit_element_application $element $dir_name]
                    if {$erreur} {return 1}
                }
            }
        }
    }

    # Libère la mémoire
    ::dom::DOMImplementation destroy $doc

    # Lit les connexions décrites dans les fichiers SMIOC
    # ---------------------------------------------------
    
    # Liste des applications
    set lapplis {}
    catch {set lapplis $dico_applis(lapplis)}
    
    # Pour toutes les applications
    foreach nom_appli $lapplis {
        # Pour tous les composants de cette application
        foreach nom_comp $dico_applis(app.$nom_appli.lcomp) {
            # Détermine le nom du fichier SMIOC (dans le même répertoire que le fichier SCC)
            set nom_fichier_SMIOC [file join $dir_name $nom_appli\_$nom_comp\_smioc.xml]
            # Lit les connexions du couplage dans le fichier SMIOC, s'il existe
            lit_fichier_component $nom_fichier_SMIOC dico_applis $nom_appli $nom_comp SMIOC
        }
    }

    # Vérifie la coherénce des connexions lues
    # ----------------------------------------
    global liste_cnx_in dico_cnx_out dico_caract_cnx
    global dico_caract_points
    
    # Pour toutes les connexions lues
    foreach clef_cnx_in $liste_cnx_in {
        # Si la source et la cible sont des composant d'application
        if {   $dico_caract_cnx($clef_cnx_in.app_source) != "///file///" 
            && $dico_caract_cnx($clef_cnx_in.app_cible) != "///file///"  } {

            # Source            
            set app_source   $dico_caract_cnx($clef_cnx_in.app_source)
            set comp_source  $dico_caract_cnx($clef_cnx_in.comp_source)
            set champ_source $dico_caract_cnx($clef_cnx_in.champ_source)
            set pt_source    $dico_caract_cnx($clef_cnx_in.pt_source)
            # Clef du point de couplage source
            set clef_pt_out $app_source.$comp_source.$champ_source.o
            # Liste des connexions au point de couplage source
            set lcnx_out ""
            catch {set lcnx_out $dico_caract_points($clef_pt_out.lcnx)}
            
            # Vérifie que la connexion est bien listée au niveau du point de couplage source
            set erreur 0
            if { [lsearch $lcnx_out $pt_source] == -1 } {
                set erreur 1
            }

            # Liste des connexions au point de couplage cible
            set lcnx_in ""
            catch {set lcnx_in $dico_caract_points($clef_cnx_in.lcnx)}
            # Vérifie que la connexion est bien listée au niveau du point de couplage cible
            if { $lcnx_in == "" } {
                set erreur 1
            }

            if {$erreur} {
                set app_cible   $dico_caract_cnx($clef_cnx_in.app_cible)
                set comp_cible  $dico_caract_cnx($clef_cnx_in.comp_cible)
                set champ_cible  $dico_caract_cnx($clef_cnx_in.champ_cible)
                notice_show  "Connection not consistently declared between field $app_source-$comp_source-$champ_source and field $app_cible-$comp_cible-$champ_cible !" error
                return 1
            }
        }
    }

    # Lit les fichiers NetCDF qui sont en entrée
    # ------------------------------------------
    
    # Dictionnaire des fichiers lus
    array set dico_ajout {}
    # Init de la liste des fichiers lus
    set liste_fic_ajoutes {}

    # Pour tous les fichiers du graphe    
    foreach id_fichier $liste_fichiers {
        # Si le fichier est en entrée
        if { $dico_caract_fichiers($id_fichier.dir) == "input" } {
            # Détermine le nom du fichier (dans le même répertoire que le fichier SCC)
            set nom_fichier [file join $dir_name $dico_caract_fichiers($id_fichier.name)]

            # Si le fichier est présent dans le répertoire du SCC
            if { [file isfile $nom_fichier]} {

                set fic_ajoute [NetCDF_file_read dico_ajout $nom_fichier]
                if {$fic_ajoute != ""} {
                    lappend liste_fic_ajoutes $fic_ajoute
                }
            }
        }
    }
    if { $liste_fic_ajoutes != ""} {
        # Met à jour les données avec les fichiers lus
        NetCDF_file_maj $liste_fic_ajoutes dico_ajout 0
    }
        
    # Lit les données graphiques du couplage dans le fichier Graphics.xml
    # -------------------------------------------------------------------
    
    # Initialise les données graphiques arbitrairement
    unit_init

    # Nom et chemin du fichier :  dans le même répertoire que le SCC
    set nom_fichier_Graphics [file join $dir_name "Graphics.xml"]
    set erreur [lit_fichier_Graphics $nom_fichier_Graphics]
    
    return 0
}

ret  {lit_fichier_component} (type nom_, type fichier , type nom_, type dico , type nom_, type appli , type nom_, type comp , type PMIOD_, type ou_, type SMIOC) {
# Lit un fichier PMIOD ou SMIOC d'un composant
#
# Parametres d'entrée :
#   - nom_fichier :      nom du fichier
#   - nom_dico  :        nom du dictionnaire à remplir (habituellement dico_applis)
#   - nom_appli :        nom de l'application
#   - nom_comp :         nom du composant
#   - PMIOD_ou_SMIOC :   vaut PMIOD ou SMIOC
#
    upvar 1 $nom_dico dict_vars
    # Préfixe de la clef des éléments à mettre dans le dictionnaire
    set prefixe "app.$nom_appli.comp.$nom_comp"
    
    if { ![file isfile $nom_fichier] } {
        return 1
    }
    # Lit le document à manipuler
    set text [read [open $nom_fichier]]
    if { [string trim $text] == "" } {
        # Fichier vide
        notice_show "Error parsing file \"$nom_fichier\" :\n file is empty" error
        return 1
    }
       
    set doc [dom::parse $text]
    
    # Récupère le premier élément du document
    # C'est l'élément principal (qui est de type <prismcomponent>)
    set element1 [dom::document configure $doc -documentElement]
    
    # Lit les attributs de l'élément <prismcomponent>
    set att [dom::node configure $element1 -attributes]
    foreach {name value} [array get $att] {
        if { $name != "local_name" } {
            set dict_vars($prefixe.$name) $value
        }
    }
    
    # Lit les sous-éléments de l'élément <prismcomponent>
    set ss_elem_list [dom::node children $element1]
    foreach element $ss_elem_list  {
        set name [dom::node configure $element -nodeName]
        if {$name != "#text" && $name != "#comment"} {
            switch $name {
                code {
                    # Pour l'instant, on ignore cet élément
                }
    
                grid {
                    # Lit les attributs local_name
                    set att [dom::node configure $element -attributes]
                    set grid_name [load_XML_attributes $att dict_vars "$prefixe.grid"]
                    # Ajoute la grille a la liste des grilles
                    if { [info exists dict_vars($prefixe.lgrids)] } {
                        # Si la grille n'existe pas
                        if {[lsearch $dict_vars($prefixe.lgrids) $grid_name] == -1 } { 
                            lappend dict_vars($prefixe.lgrids) $grid_name
                        }
                    } else {
                        set dict_vars($prefixe.lgrids) $grid_name
                    }
                    # Lit les sous-éléments
                    lit_element_grid $element dict_vars $nom_appli $nom_comp $grid_name
                }
    
                transient {
                    # Lit les attributs local_name, long_name, simulated, etc..
                    set att [dom::node configure $element -attributes]
                    set transient_name [load_XML_attributes $att dict_vars "$prefixe.champ"]
                    # Ajoute le point de couplage à la liste des points de couplage
                    if { [info exists dict_vars($prefixe.lchamps)] } {
                        # Si le point de couplage n'est pas déjà listé
                        if {[lsearch $dict_vars($prefixe.lchamps) $transient_name] == -1 } { 
                            lappend dict_vars($prefixe.lchamps) $transient_name
                        }
                    } else {
                        set dict_vars($prefixe.lchamps) $transient_name
                    }
                    # Lit les sous-éléments
                    lit_point_echange $element dict_vars $nom_appli $nom_comp $transient_name $PMIOD_ou_SMIOC
                }
            }
        }
    }
    # Libère la mémoire
    ::dom::DOMImplementation destroy $doc
    return 0
}

ret  {lit_element_grid} (type element_, type XML , type nom_, type dico , type nom_, type appli , type nom_, type comp , type nom_, type grid) {
# Lit dans un fichier XML (PMIOD ou SMIOC) d'un composant un élément <grid>
#
# Parametres d'entrée :
#   - element_XML :      élément XML de type <grid>
#   - nom_dico  :        nom du dictionnaire à remplir (habituellement dico_applis)
#   - nom_appli :        nom de l'application
#   - nom_comp :         nom du composant
#   - nom_grid :         nom de la grille 
#
    upvar 1 $nom_dico dict_vars

   # Préfixe de la clef des éléments à mettre dans le dictionnaire
   set prefixe "app.$nom_appli.comp.$nom_comp.grid.$nom_grid"

   # Lit les sous-éléments de l'élément <grid>
   set ss_elem_list [dom::node children $element_XML]
   foreach element $ss_elem_list  {
      set name [dom::node configure $element -nodeName]
      if {$name == "indexing_dimension"} {
            # Lit l'attribut "index" (1 ou 2 ou 3)
            set index [dom::element getAttribute $element "index"]
            switch $index {
               1 { set key $prefixe.periodi }
               2 { set key $prefixe.periodj }
               3 { set key $prefixe.periodk }
            }
            # Lit l'attribut "periodic" (true ou false)
            set value [dom::element getAttribute $element "periodic"]
            set dict_vars($key) $value
          }
   }
}

ret  {lit_point_echange} (type element_, type XML , type nom_, type dico , type nom_, type appli , type nom_, type comp , type nom_, type champ , type PMIOD_, type ou_, type SMIOC) {
# Lit dans un fichier XML (PMIOD ou SMIOC) d'un composant un élément <transient>
#
# Parametres d'entrée :
#   - element_XML :      élément XML de type <transient>
#   - nom_dico  :        nom du dictionnaire à remplir (habituellement dico_applis)
#   - nom_appli :        nom de l'application
#   - nom_comp :         nom du composant
#   - nom_champ :        nom du champ de couplage
#   - PMIOD_ou_SMIOC :   vaut PMIOD ou SMIOC
#
    upvar 1 $nom_dico dict_vars

   # Préfixe de la clef des éléments à mettre dans le dictionnaire
   set prefixe "app.$nom_appli.comp.$nom_comp.champ.$nom_champ"

   # Lit les sous-éléments de l'élément <transient>
   set ss_elem_list [dom::node children $element_XML]
   foreach element $ss_elem_list  {
      set name [dom::node configure $element -nodeName]
      switch $name {
         transient_standard_name {
            set value [lit_XML_texte $element]
            set dict_vars($prefixe.std_name) $value
         }
         physics {
            # Lit l'attribut "transient_type" (single ou vector)
            set value [dom::element getAttribute $element "transient_type"]
            set dict_vars($prefixe.type) $value
            # Lit les sous-éléments physical_units, valid_min et valid_max
            set ss_elem_list [dom::node children $element]
            foreach element $ss_elem_list  {
               set name [dom::node configure $element -nodeName]
               switch $name {
                  physical_units {
                     set value [lit_XML_texte $element]
                     set dict_vars($prefixe.units) $value
                  }
                  valid_min {
                     set value [lit_XML_texte $element]
                     set dict_vars($prefixe.min) $value
                  }
                  valid_max {
                     set value [lit_XML_texte $element]
                     set dict_vars($prefixe.max) $value
                  }
               }
            }
         }
         numerics {
            # Lit l'attribut "datatype" (xs:real, xs:double ou xs:integer)
            set value [dom::element getAttribute $element "datatype"]
            # Extrait le type (enlève "xs:")
            set value [string range $value 3 end]
            set dict_vars($prefixe.datatype) $value
         }
         computation {
         }
         intent {
            # Peut contenir un seul <input> et/ou plusieurs <output>
            lit_element_intent $element dict_vars $nom_appli $nom_comp $nom_champ $PMIOD_ou_SMIOC
         }
         transient_dependency {
         }
      }
   }
}

ret  {load_NetCDF_files} () {
load_dir_files "Load NetCDF files" "*.nc" NetCDF_file_read_files NetCDF_file_add_new
}

ret  {load_XML_ad_files} () {
load_dir_files "Load Application Description files" "*_ad.xml" read_AD_files
}

ret  {load_XML_attributes} (type nom_, type attr , type nom_, type dico , type prefixe) {
upvar 1 $nom_attr attributs
   upvar 1 $nom_dico dict_vars

   set local_name $attributs(local_name)
   foreach {name value} [array get attributs] {
      if { $name != "local_name" } {
         set dict_vars($prefixe.$local_name.$name) $value
      }
   }

   return $local_name
}

ret  {load_dir_files} (type title , type initial_, type mask , type on_, type OK , optional on_new ={)} {
# Permet de selectionner des fichiers d'un type particulier dans un repertoire
#
# Permet de creer un nouveau fichier si le parametre on_new est specifie.
#
# Paramètres d'entrée :
#   - dirname (global)      : repertoire initial
#   - title                 : titre de la boite de dialogue
#   - initial_mask          : masque initial d'extension des fichiers
#   - on_OK                 : commande a executer si appui sur le bouton OK
#   - on_new                : commande a executer si appui sur le bouton New

    global dirname
    global masque

    if {![info exists dirname]} { dirname =  [pwd]}
    /*  if { $title == "Load Application Description files" } {*/
    /*      set dirname /localhome/epitalon/tr-OASIS4/oasis4/util/running/toyoa4/input*/
    /*  } else {*/
    /*      set dirname /localhome/epitalon/tr-OASIS4/oasis4/util/running/toyoa4/data*/
    /*  }*/

     u =  .
    /*  permet de choisir n fichiers dans un repertoire*/

    catch {destroy $u}
    toplevel $u
    wm title $u $title
    wm iconname $u "Select files"

    frame $u.fr1
    pack $u.fr1 -side top -fill x -padx 10 -pady 10
    label $u.fr1.lab1 -text "Directory :"
    pack $u.fr1.lab1 -side left
    label $u.fr1.lab2 -text $dirname -relief sunken -background grey97 -anchor w
    pack $u.fr1.lab2 -side left -expand yes -fill x  -padx 10
    button $u.fr1.b1 -text "Browse" -command {
                global dirname
                 dir =  [tk_chooseDirectory -title "directory to 
                if {$dir != ""} {
                     dirname =  $dir}
                    .
                    
                }
    pack $u.fr1.b1 -side left

    frame $u.fr2
    pack $u.fr2 -side top -expand yes -fill x
    
    frame $u.fr2.f2
    pack $u.fr2.f2 -side left -fill both -padx 10 -pady 10 -expand yes
    pack [label $u.fr2.f2.lab1 -text "Select file list:"] -side top -anchor w
    listbox $u.fr2.f2.lb -background white  -yscrollc "$u.fr2.f2.sb " -selectmode =  extended
    scrollbar $u.fr2.f2.sb -bd 1 -command "$u.fr2.f2.lb yview"
    pack $u.fr2.f2.lb -side left -expand yes -fill both
    pack $u.fr2.f2.sb -side left -fill y

    frame $u.fr2.f3
     masque =  $initial_mask
    entry $u.fr2.f3.mask -textvariable masque -background white
    pack $u.fr2.f3 -side left -fill y -padx 10 -pady 10
    pack [label $u.fr2.f3.lab2 -text "File Mask:"] -side top -anchor w
    pack  $u.fr2.f3.mask  -expand yes -fill x -side top -anchor n

    frame $u.fr2.f3.bu
    pack $u.fr2.f3.bu -side bottom -fill x
    button $u.fr2.f3.bu.ok -text "OK" -command "
    button $u.fr2.f3.bu.cancel -text "Cancel" -command "destroy $u"
    pack $u.fr2.f3.bu.cancel  -side left
    pack  $u.fr2.f3.bu.ok -side right

    bind $u.fr2.f3.mask <Return> "
    

    if { $on_new != "" } {
        frame $u.fr3
        pack $u.fr3 -side bottom -expand yes -fill x -pady 10
        
        label $u.fr3.lab1 -text "Or enter new file name :"
        pack $u.fr3.lab1 -side top -anchor w -padx 10
        
        frame $u.fr3.f1
        pack $u.fr3.f1 -side top -expand yes -fill x
        
        global new_filename_m;  new = _filename_m ""
        entry $u.fr3.f1.e1 -textvariable new_filename_m -background white
        pack $u.fr3.f1.e1 -side left -fill x -padx 10 -expand yes
        button $u.fr3.f1.new -text "New" -command "global new_filename_m; $on_new \$new_filename_m; un new = _filename_m; destroy $u"
        pack  $u.fr3.f1.new -side right  -padx 10 
    }
}

ret  {load_files} (type on_, type OK) {
#
    global dirname
    set lst ""
    catch {set lst [selection get -displayof .load_dir.fr2.f2.lb]}
    set file_list ""
    foreach elm $lst {
        set file [file join $dirname $elm]
        lappend file_list $file
    }
    if {$file_list != ""} {$on_OK $file_list}
}

ret  {load_maj_listfile} () {
#**** load_maj_listfile
#
#     Purpose:
#     --------
#     update file list if the user enters a new mask file
#
#     Interface:
#     ----------
#     load_maj_listfile
#
#
#***  History:
#     -------
#       Version   Programmer     Date        Description
#       -------   ----------     ----        -----------
#       0.0       Thierry M.   2000/10/04     created
#
#*----------------------------------------------------------------
    global dirname
    global masque
    .load_dir.fr2.f2.lb delete 0 end
    foreach elm $masque {
        set loclist {}
        catch {set loclist [glob -directory $dirname $elm]}
        foreach filename $loclist {
            if {[file isfile $filename] } {.load_dir.fr2.f2.lb insert end [file tail $filename]}
        }
    }
}

ret  {maj_composants_ajoutes} (type nom_, type dico_, type ajout , type liste_, type comp_, type ajoutes) {
#
    # Accède à la variable dont le nom est $nom_dico_ajout
    upvar 1 $nom_dico_ajout dico_ajout
    
    global dico_applis
    global dico_units
    global liste_points_i  liste_points_o
    global dico_caract_points
    global dico_cnx_out dico_caract_cnx
    global oasis4_version

    # Position initiale du composant sur le graphe : en haut à gauche
    set position_x 80
    set position_y 25

    # Si besoinm initialise la liste des applications déjà chargées en mémoire
    if { ! [info exists dico_applis(lapplis)] } {
        set dico_applis(lapplis) {}
    }
    
    # Pour toutes les applis ajoutées
    foreach nom_appli $dico_ajout(lapplis) {
        # Si l'appli est chargée en mémoire pour la première fois
        if { [lsearch $dico_applis(lapplis) $nom_appli] == -1 } { 
            # Ajoute l'appli a la liste
            lappend dico_applis(lapplis) $nom_appli
            # Initialise la liste des composants de l'appli
            set dico_applis(app.$nom_appli.lcomp) {}
        } else {
        
            # Si le nombre de processus de l'appli a changé
            if {  [array get dico_ajout "app.$nom_appli.proc.*"] != [array get dico_applis "app.$nom_appli.proc.*"] } {
            
                # Vérifie la répartition des proc sur les ordinateurs hosts de l'application
                # --------------------------------------------------------------------------
            
                # Si la liste des ordinateurs hosts existe déja
                if {   [info exists dico_applis(app.$nom_appli.lhosts)]
                    && [llength $dico_applis(app.$nom_appli.lhosts)] != 0 } {
                    
                    set nb_proc_total 0
                    foreach id_host $dico_applis(app.$nom_appli.lhosts) {
                        # Additionne au total
                        incr nb_proc_total $dico_applis(app.$nom_appli.host.$id_host.nb_procs)
                    }
                    
                    # Vérifie que le nombre de processus est dans la fourchette acceptable pour l'appli
                    set si_OK 1
                    set min_proc $dico_applis(app.$nom_appli.proc.min_value)
                    set max_proc $dico_applis(app.$nom_appli.proc.max_value)
                    set increment $dico_applis(app.$nom_appli.proc.increment)
                    if { $nb_proc_total >= $min_proc && $nb_proc_total <= $max_proc } {
                    
                        # Vérifie que le nombre est un multiple attendu
                        if {[expr ($nb_proc_total - $min_proc) % $increment] == 0} {
                            # OK
                        } else {
                            set si_OK 0
                        }
                    } else {
                        set si_OK 0
                    }
                    
                    # Si pas OK
                    if { ! $si_OK } {
                        # Annule la répartition des proc. sur les ordinateurs hosts
                        foreach id_host $dico_applis(app.$nom_appli.lhosts) {
                            set dico_applis(app.$nom_appli.host.$id_host.nb_procs) ""
                        }
                    }
                }
            }
        }
        
        # Recopie les attributs de l'appli
        foreach attrib {oasis4_version start_mode coupling_mode proc.min_value proc.max_value proc.increment} {
            set dico_applis(app.$nom_appli.$attrib) $dico_ajout(app.$nom_appli.$attrib)
        }
        catch { set dico_applis(app.$nom_appli.long_name) $dico_ajout(app.$nom_appli.long_name) }

        # Met a jour la var globale 'oasis4_version'
        if {![info exists oasis4_version] && [info exists dico_applis(app.$nom_appli.oasis4_version)]} {
            set oasis4_version $dico_applis(app.$nom_appli.oasis4_version)
        }
    }
    
    # Pour tous les composants ajoutés
    foreach clef_comp $liste_comp_ajoutes {

        # Nom du composant
        set nom_composant $dico_units($clef_comp)
        # Extrait de la clef le nom de l'appli
        set len_comp [string length $nom_composant]
        incr len_comp
        set nom_appli [string range $clef_comp 0 end-$len_comp]

        # Si le composant est chargé en mémoire pour la première fois
        if { [lsearch $dico_applis(app.$nom_appli.lcomp) $nom_composant] == -1 } {

            # Ajoute le composant a la liste
            lappend dico_applis(app.$nom_appli.lcomp) $nom_composant
            # Ajoute toutes ses infos au dictionnaire global des applis et composants
            array set dico_applis [array get dico_ajout "app.$nom_appli.comp.$nom_composant.*"]
            
            # Place le composant sur le graphe
            set dico_units($clef_comp.coor_x) $position_x
            set dico_units($clef_comp.coor_y) $position_y
            incr position_y 80
            # Met le composant dans l'état "connexions visibles"
            set dico_units($clef_comp.expand) 1
            # Choisit une couleur pour le composant
            set dico_units($clef_comp.colour) [color_rgb [expr int(rand()*254)] [expr int(rand()*254)] [expr int(rand()*254)]]
    
            # Ajoute tous les points d'échange (de couplage) de ce composant
            # à la liste générale des points de couplage
            set liste_champs $dico_applis(app.$nom_appli.comp.$nom_composant.lchamps)
            foreach nom_champ $liste_champs  {
                set clef_base "$clef_comp.$nom_champ"
    
                # Si le champ de couplage est en entrée
                if { [info exists dico_applis(app.$nom_appli.comp.$nom_composant.champ.$nom_champ.input)] } {
                    set clef "$clef_base.i"
                    lappend liste_points_i $clef
                    set dico_caract_points($clef.appli) $nom_appli
                    set dico_caract_points($clef.comp) $nom_composant
                    set dico_caract_points($clef.champ) $nom_champ
                }
    
                # Si le champ de couplage est en sortie
                if { [info exists dico_applis(app.$nom_appli.comp.$nom_composant.champ.$nom_champ.output)] } {
                    set clef "$clef_base.o"
                    lappend liste_points_o $clef
                    set dico_caract_points($clef.appli) $nom_appli
                    set dico_caract_points($clef.comp) $nom_composant
                    set dico_caract_points($clef.champ) $nom_champ
                }
            }
            Draw_one_unit $clef_comp

        } else {

            # Etablit la liste des points de couplage du nouveau composant
            set liste_pts_couplage {}
            # Pour tous les champs du composant chargé en mémoire
            foreach nom_champ $dico_ajout(app.$nom_appli.comp.$nom_composant.lchamps) {
                # Ajoute un ou deux points de couplage
                set clef_base "$clef_comp.$nom_champ"
                
                # Si le champ de couplage est en entrée
                if { [info exists dico_ajout(app.$nom_appli.comp.$nom_composant.champ.$nom_champ.input)] } {
                    set clef "$clef_base.i"
                    lappend liste_pts_couplage $clef
                }
    
                # Si le champ de couplage est en sortie
                if { [info exists dico_ajout(app.$nom_appli.comp.$nom_composant.champ.$nom_champ.output)] } {
                    set clef "$clef_base.o"
                    lappend liste_pts_couplage $clef
                }
            }

            # Liste des points de couplage du composant existant auparavant
            set liste_clefs_points_i [lsearch -glob -all -inline $liste_points_i "$clef_comp.*"]
            set liste_clefs_points_o [lsearch -glob -all -inline $liste_points_o "$clef_comp.*"]
            
            # Vérifie la liste des points de couplage et cherche des points supprimés ou ajoutés
            # ----------------------------------------------------------------------------------

            # Pour tous les points de couplage du composant chargé en mémoire
            foreach clef_point $liste_pts_couplage {
                # Si c'est un point de couplage en sortie
                if { [string match *.o $clef_point] } { 
                    # Si le point de couplage n'existait pas auparavant
                    if { [lsearch $liste_clefs_points_o $clef_point] == -1} {
                        # Ajoute un point de couplage
                        lappend liste_points_o $clef_point
                        set dico_caract_points($clef_point.appli) $nom_appli
                        set dico_caract_points($clef_point.comp) $nom_composant
                        # Retrouve le nom du champ
                        set pos [string length "$clef_comp." ]
                        set nom_champ [string range $clef_point $pos end-2]
                        set dico_caract_points($clef_point.champ) $nom_champ
                    }
                # Si le point de couplage est en entrée
                } else {
                    
                    # Si le point de couplage n'existait pas auparavant
                    if { [lsearch $liste_clefs_points_i $clef_point] == -1} {
                        # Ajoute un point de couplage
                        lappend liste_points_i $clef_point
                        set dico_caract_points($clef_point.appli) $nom_appli
                        set dico_caract_points($clef_point.comp) $nom_composant
                        # Retrouve le nom du champ
                        set pos [string length "$clef_comp." ]
                        set nom_champ [string range $clef_point $pos end-2]
                        set dico_caract_points($clef_point.champ) $nom_champ
                    }
                }
            }
            
            # Init liste des composants ou fichiers touchés par les connexions supprimées
            set liste_comp_touches {}
            # Pour tous les points de couplage qui existaient auparavant
            foreach clef_point [concat $liste_clefs_points_i $liste_clefs_points_o] {
                # Si le point de couplage n'existe plus
                if { [lsearch $liste_pts_couplage $clef_point] == -1} {
                    # Teste si le champ est connecté
                    set lcnx ""
                    catch {set lcnx $dico_caract_points($clef_point.lcnx)}
                    # Pour toutes les connexions entrant ou sortant de ce point
                    foreach num_cnx $lcnx {
                        # Si c'est une connexion entrante
                        if { $num_cnx == "i" } {
                            set clef_cnx_in $clef_point
                            # Memorise le composant source de la connexion
                            set appli_source $dico_caract_cnx($clef_cnx_in.app_source)
                            set comp_source  $dico_caract_cnx($clef_cnx_in.comp_source)
                            set comp_touche $appli_source.$comp_source
                        } else {
                            # C'est une connexion sortante : le numéro $num_cnx vaut "o1", "o2" ou "o#"....
                            # Enlève la lettre "o" qui est en tête
                            set num [string range $num_cnx 1 end]
                            # Clef de la cnx sortante
                            set clef_cnx_out "$clef_point$num"
                            # Clef de la connexion : point de couplage cible de la connexion
                            set clef_cnx_in $dico_cnx_out($clef_cnx_out)
                            # Memorise le composant cible de la connexion
                            set appli_cible $dico_caract_cnx($clef_cnx_in.app_cible)
                            set comp_cible  $dico_caract_cnx($clef_cnx_in.comp_cible)
                            set comp_touche $appli_cible.$comp_cible
                        }
                        # Met a jour la liste des composants touchés
                        lappend liste_comp_touches $comp_touche
                        # Supprime la connexion
                        comm_remove $clef_cnx_in
                    }
                    # Si c'est une point de couplage en entrée
                    if { [string range $clef_point end end] == "i" } {
                        # Met a jour la liste des points en entrée
                        set liste_points_i [lsearch -not -all -inline -glob $liste_points_i "$clef_point"]
                    } else {
                        # Met a jour la liste des points en sortie
                        set liste_points_o [lsearch -not -all -inline -glob $liste_points_o "$clef_point"]
                    }
                    # Supprime les caractéristiques du point
                    array unset dico_caract_points "$clef_point.*"
                }
            }
            
            # Met à jour en mémoire les champs du composant et leurs attributs
            array unset dico_applis "app.$nom_appli.comp.$nom_composant.champ.*"
            array set dico_applis [array get dico_ajout "app.$nom_appli.comp.$nom_composant.champ.*"]
            
            # Met à jour en mémoire la liste des champs du composant
            set dico_applis(app.$nom_appli.comp.$nom_composant.lchamps) $dico_ajout(app.$nom_appli.comp.$nom_composant.lchamps)

            # Met a jour les attributs du composant
            foreach attrib {long_name oasis4_version simulated proc.min_value proc.max_value proc.increment} {
                set dico_applis(app.$nom_appli.comp.$nom_composant.$attrib) $dico_ajout(app.$nom_appli.comp.$nom_composant.$attrib)
            }
            
            # Pour tous les composants touchés
            foreach composant $liste_comp_touches {
                # Redessine le composant
                Draw_one_unit $composant
            }

            # Affiche le nouveau composant sur le graphe
            Draw_one_unit $clef_comp
            # Redessine les connexions du composant
            Draw_comm $clef_comp

        }
    }
}

ret  {minimenu_comm} (type i) {
#
    global entityselected objectselected tagselected oldcolor

    # Deselectionne les points de couplage
    comm_new menage -1

    set w .gui.pr.cpd22.03

    # Si il y avait un autre objet selectionne
    if {$objectselected != ""} {
        # Deselectionne ce composant sur le graphe
        $w itemconfigure $tagselected -fill $oldcolor
    }

    # Change la couleur de l'element sélectionné sur le graphe
    set objectselected $i
    set tagselected tag_fils_connexions($i)
    set oldcolor [$w itemcget $tagselected  -fill ]
    $w itemconfigure $tagselected -fill red

    # Changer le type d'éléments listes et refaire la liste
    # et sélectionner le bon élément dans la liste
    set entityselected CONNECTION
    control_entity $entityselected $i
}

ret  {minimenu_unit} (type i) {
#
    global entityselected objectselected tagselected oldcolor

    # Désélectionne les points de couplage
    comm_new menage -1

    set w .gui.pr.cpd22.03

    # Si il y avait un autre composant sélectionné
    if {$tagselected != ""} {
        # Désélectionne ce composant sur le graphe
        $w itemconfigure $tagselected -fill $oldcolor
    }

    # Change la couleur du composant sélectionné sur le graphe
    set tagselected unitpoint_color($i)
    set oldcolor [$w itemcget $tagselected  -fill ]
    $w itemconfigure $tagselected -fill red

    # Changer le type d'éléments listes et refaire la liste
    # et sélectionner le bon élément dans la liste
    
    # Si il s'agit d'un fichier NetCDF
    if { [string match ///file///.* $i] } {
        set entityselected FILE
    } else {
        set entityselected COMPONENT
    }
    control_entity $entityselected $i
    set objectselected $i
}

ret  {notice_show} (type mesg , optional icon =info) {
#
#**** notice_show - notice show
#
#     Purpose:
#     --------
#     Show a dialog box with a message and chosen icon
#
#     Interface:
#     ----------
#         notice_show $mesg info
#
#         Inputs :
#         --------
#           mesg : variable containing the message to be written
#           info : the chosen icon (info, error)
#
#***  Externals:
#     ----------
#     This code is using Tcl/Tk
#
#     References:
#     -----------
#     Effective Tcl/Tk Programming, M. Harrison and M. McLennan,
#     Addison-Wesley professional computing series, 1998
#
#     History:
#     -------
#       Version   Programmer     Date        Description
#       -------   ----------     ----        -----------
#       0.0       Anne         1999/01/11       created
#*----------------------------------------------------------------
#
#** Declaration
#

  set top [dialog_create Notice]
  set x [expr [winfo rootx .gui]+200]
  set y [expr [winfo rooty .gui]+200]
  wm geometry $top "+$x+$y"
  set info [dialog_info $top]
  label $info.icon -bitmap $icon
  pack $info.icon -side left -padx 8 -pady 8
  label $info.mesg -text $mesg -wraplength 4i
  pack $info.mesg -side right -expand yes -fill both  -padx 8 -pady 8
  set cntls [dialog_controls $top]
  button $cntls.dismiss -command "destroy $top" -text OK
  pack $cntls.dismiss -pady 4
  return $top
}

ret  {open_file} (type file , type mode) {
set f [open $file $mode]
    if {$mode == "w" || $mode == "a"} {
      fconfigure $f -translation lf
    }
    return $f
}

ret  {printer_create} (type top , type filename) {
global prInfo
    global global_font

    set top [dialog_create Printer $top]

    set info [dialog_info $top]
    radiobutton $info.printer  -text "Send to printer with command: "  -variable prInfo($top-where) -value "printer" -font $global_font
    entry $info.printerCmd -font $global_font -background white
    radiobutton $info.file  -text "Save output in file: "  -variable prInfo($top-where) -value "file" -font $global_font

    entry $info.fileName -font $global_font -background white

    grid $info.printer    -row 0 -sticky w
    grid $info.printerCmd -row 1 -sticky ew
    grid rowconfigure $info 2 -minsize 6
    grid $info.file       -row 3 -sticky w
    grid $info.fileName   -row 4 -sticky ew

    $info.printerCmd insert 0 "lpr"
    $info.fileName insert 0 "$filename.eps"

    $info.printer invoke

    bind $info.printerCmd <FocusIn> "$info.printer invoke"
    bind $info.fileName <FocusIn> "$info.file invoke"

    set cntls [dialog_controls $top]
    button $cntls.ok -command "set prInfo($top-status) 1" -font $global_font
    pack $cntls.ok -side left -expand yes
    focus $cntls.ok

    button $cntls.cancel -command "set prInfo($top-status) 0" -font $global_font
    pack $cntls.cancel -side left -expand yes

    wm protocol $top WM_DELETE_WINDOW "$cntls.cancel invoke"
    wm withdraw $top


    return $top
}

ret  {printer_print} (type top , type cmd , optional ok =Print , optional cancel =Cancel) {
global prInfo
global file_lue

    set cntls [dialog_controls $top]
    $cntls.ok configure -text $ok
    $cntls.cancel configure -text $cancel

    dialog_wait $top prInfo($top-status)

    if {$prInfo($top-status)} {
        switch $prInfo($top-where) {
            printer {
                set info [dialog_info $top]

                set print [format {
                    exec %s << [%s]
                } [$info.printerCmd get] $cmd]

                if {[catch $print result] != 0} {
                    notice_show $result error
                } elseif {[string trim $result] != ""} {
                    notice_show $result info
                } else {
                    notice_show "Document printed" info
                }
            }
            file {
                set info [dialog_info $top]
                set fname [$info.fileName get]
        if {[file pathtype $fname] == "relative"} {
            set fname [file dirname $file_lue]/$fname
        }
                set print [format {
                    set fid [open_file %s w]
                    puts -nonewline $fid [%s]
                    close $fid
                } $fname $cmd]

                if {[catch $print result] != 0} {
                    notice_show $result error
                } else {
                    notice_show "Output saved in file \"$fname\"" info
                }
            }
        }
    }
}

ret  {quit_gui_oasis} () {
#
    if {![file isdirectory  ~/.OASIS]} {catch {file mkdir ~/.OASIS}}
    catch {set f [open_file ~/.OASIS/gui_oasis_window w]
        puts $f "[winfo geometry .gui]"
        close $f
    }

    global dico_applis
    set quitter 1

    # S'il y a un couplage a l'ecran (au moins une appli chargee)    
    set liste_applis {}
    catch { set liste_applis $dico_applis(lapplis) }
    if {[llength $liste_applis]} {
        set rep [tk_messageBox -message "Save current coupling configuration ?" -type yesno -icon question]
        if {$rep == "yes"} {
            set quitter [sauve_tout]
        }
    }
    if {$quitter == 1} {exit}
}

ret  {read_AD_files} (type file_, type list) {
#
    global entityselected
    # Liste des composants ajoutés
    set liste_comp_ajoutes {}
    array set dico_ajout {}
    
    # Lit les fichiers XML : AD et les PMIOD relatifs
    foreach file $file_list {
        if {$file != ""} {
            lit_fichier_AD $file dico_ajout liste_comp_ajoutes
        }
    }
    # Met à jour les données et le graphe avec les composants ajoutes
    maj_composants_ajoutes dico_ajout $liste_comp_ajoutes
    
    if { $entityselected == "COMPONENT" } {
        control_entity $entityselected
    }
}

ret  {scrollform_create} (type win) {
# ----------------------------------------------------------------------
#  USAGE:  scrollform_resize <win>
#
#  Used internally to handle size changes in the form area within
#  a scrollform assembly.  Updates the canvas to recognize the new
#  scrolling area.
# ----------------------------------------------------------------------
proc scrollform_resize {win} {
    set bbox [$win.vport bbox all]
    set wid [winfo width $win.vport.form]
    $win.vport configure -width $wid  -scrollregion $bbox -yscrollincrement 0.1i
}

# ----------------------------------------------------------------------
#  USAGE:  scrollform_interior <win>
#
#  Returns the name of the interior frame that represents the
#  body of the scrollform.  Widgets should be packed in this
#  frame to build the form.
# ----------------------------------------------------------------------
proc scrollform_interior {win} {
    return "$win.vport.form"
}

# ----------------------------------------------------------------------
#  EXAMPLE: use the canvas to build a scrollable form
# ----------------------------------------------------------------------
#  Effective Tcl/Tk Programming
#    Mark Harrison, DSC Communications Corp.
#    Michael McLennan, Bell Labs Innovations for Lucent Technologies
#    Addison-Wesley Professional Computing Series
# ======================================================================
#  Copyright (c) 1996-1997  Lucent Technologies Inc. and Mark Harrison
# ======================================================================

# ----------------------------------------------------------------------
#  USAGE:  scrollform_create <win>
#
#  Creates an empty scrollform assembly.  The interior frame for this
#  form can be found by calling "scrollform_interior".  Widgets packed
#  into the interior can be scrolled in the vertical direction.
# ----------------------------------------------------------------------
frame $win -class Scrollform

scrollbar $win.sbar -command "$win.vport yview"
pack $win.sbar -side right -fill y

canvas $win.vport -yscrollcommand "$win.sbar set"
pack $win.vport -side left -fill both -expand true

frame $win.vport.form
$win.vport create window 0 0 -anchor nw -window $win.vport.form

bind $win.vport.form <Configure> "scrollform_resize $win"

return $win
}

ret  {unit_delete} (type clef_, type unit) {
# Quand l'utilisateur appuie sur la touche <delete> sur une unité (composant ou fichier) dans le graphe
#   ceci provoque la suppression de cette unité (pour les fichiers seulement, pour l'instant)
#
    global dico_applis dico_units dico_caract_fichiers
    global oldcolor tagselected

    set nom_unit $dico_units($clef_unit)
    # Extrait de la clef le nom de l'appli
    set len_unit [string length $nom_unit]
    incr len_unit
    set nom_appli [string range $clef_unit 0 end-$len_unit]
    
    # Si l'unité est un fichier 
    if { $nom_appli == "///file///" } {
        # Supprime le fichier
        NetCDF_file_delete $clef_unit
    }
}

ret  {unit_edit} (type clef_, type unit) {
# Quand l'utilisateur double-clique sur une unité (composant ou fichier) dans le graphe
#   ceci provoque la saisie des paramètres de cette unité
#
# Cette fonction appelle la procédure qu'il faut selon que l'unité en question 
# est un fichier ou un composant d'application
#
    global dico_applis dico_units dico_caract_fichiers
    global oldcolor tagselected

    set nom_unit $dico_units($clef_unit)
    # Extrait de la clef le nom de l'appli
    set len_unit [string length $nom_unit]
    incr len_unit
    set nom_appli [string range $clef_unit 0 end-$len_unit]
    
    # Si l'unité est un fichier 
    if { $nom_appli == "///file///" } {
        NetCDF_file_edit $nom_unit
        tkwait window .mod_file
        
        # L'utilisateur a pu changer le nom du fichier
        # ==> raffiche le fichier sur le graphe
        Draw_one_unit $clef_unit
        Draw_comm $clef_unit

    } else {
        component_edit $clef_unit
        tkwait window .mod_component
        # La couleur a pu changer : raffiche le composant sur le graphe
        Draw_one_unit $clef_unit
    }

    # Si cette unité était sélectionnée
    if {$tagselected == "unitpoint_color($clef_unit)"} {
        # Change la couleur de l'objet sélectionné
        set w .gui.pr.cpd22.03
        set oldcolor [$w itemcget $tagselected  -fill ]
        $w itemconfigure $tagselected -fill red
    }
}

ret  {unit_init} () {
# Initialise arbitrairement les données graphiques des unités sur le graphe de couplage
    global dico_applis liste_fichiers dico_units 

    # Position de la 1ère unité sur le graphe : en haut à gauche
    # Les autres seront alignés sur une diagonale a travers l'écran
    set position_x 80
    set position_y 25
            
    # Pour toutes les applications
    foreach nom_appli $dico_applis(lapplis) {
        # Pour tous les composants de cette application
        foreach nom_composant $dico_applis(app.$nom_appli.lcomp) {
            set clef_comp $nom_appli.$nom_composant
            
            # Si l'élément apparait sur le graphe
            if { [info exists dico_units($clef_comp)] } {
                # Position en x et y, couleur et mode d'affichage
                set dico_units($clef_comp.coor_x) $position_x
                set dico_units($clef_comp.coor_y) $position_y
                set dico_units($clef_comp.colour) [color_rgb [expr int(rand()*254)] [expr int(rand()*254)] [expr int(rand()*254)]]
                set dico_units($clef_comp.expand) 1
                incr position_x 30
                incr position_y 80
            }
        }
    }
    
    # Pour tous les fichiers NetCDF
    foreach id_fichier $liste_fichiers {
        set clef_fichier ///file///.$id_fichier
        
        # Si l'élément apparait sur le graphe
        if { [info exists dico_units($clef_fichier)] } {
            # Position en x et y, couleur et mode d'affichage
            set dico_units($clef_fichier.coor_x) $position_x
            set dico_units($clef_fichier.coor_y) $position_y
            set dico_units($clef_fichier.colour) [color_rgb [expr int(rand()*254)] [expr int(rand()*254)] [expr int(rand()*254)]]
            set dico_units($clef_fichier.expand) 1
            incr position_x 30
            incr position_y 80
        }
    }
}

ret  {unitplotdown} (type w , type x , type y , type i) {
# plotDown --
# This procedure is invoked when the mouse is pressed over one of the
# data points.  It sets up state to allow the point to be dragged.
#
# Arguments:
# w -       The canvas window.
# x, y -    The coordinates of the mouse press.
    global plot
    global unitindex
    global plotdown

    set plotdown "active"
    $w dtag selected
    $w addtag selected withtag UNIT_tag($i)
    set plot(lastX) $x
    set plot(lastY) $y
    set plot(firstX) $x
    set plot(firstY) $y
}

ret  {unitplotmove} (type w , type x , type y) {
# plotMove --
# This procedure is invoked during mouse motion events.  It drags the
# current item.
#
# Arguments:
# w -       The canvas window.
# x, y -    The coordinates of the mouse.
    global plot
    $w move selected [expr $x-$plot(lastX)] [expr $y-$plot(lastY)]
    set plot(lastX) $x
    set plot(lastY) $y
}

ret  {unitplotrelease} (type w , type x , type y , type i) {
#
    global zoomfactor
    global dico_units
    global plot
    global plotdown
    global tagselected

    if {$plotdown == "active"} {
        $w dtag selected
        set plot(lastX) $x
        set plot(lastY) $y
        set dico_units($i.coor_x) [expr $dico_units($i.coor_x) + ($plot(lastX) - $plot(firstX))/$zoomfactor]
        set dico_units($i.coor_y) [expr $dico_units($i.coor_y) + ($plot(lastY) - $plot(firstY))/$zoomfactor]
        
        Draw_one_unit $i
        # Si le composant est sélectionné
        if {$tagselected == "unitpoint_color($i)"} {
            # remet la couleur rouge de l'objet sélectionné 
            $w itemconfigure $tagselected -fill red
        }
        update
        Draw_comm $i
        set plotdown "inactive"
    }
}

ret  {user_name} () {
global env
   return $env(USER)
}

ret  {window.font} (optional init_font ={helvetica 12) texttoedit} {
global dxf
    .gui configure -cursor watch
    update
    set dxf(tmp) ""
    catch {destroy .choose_font}
     w =  .choose_font
    toplevel $w
    wm withdraw $w
    wm protocol $w WM_DELETE_WINDOW " dxf = (tmp) \"\"; destroy $w"
    catch {wm transient $w .appearance}
    wm title $w "Text edit"


    label $w.l11 -text "Font:"
    label $w.l12 -text "Size:"
    label $w.l13 -text "Color:"
    label $w.l14 -text "Justification:"


    combobox_lim $w.cb_name [lsort [font families]] font_view_update dxf(choose_font_cb_name) 30 $dxf(choose_font_cb_name)
/*     bind $w.cb_name.e <Return> "font_view_update"*/

    combobox_lim $w.cb_size [list 8 10 12 14 16 18 20 24 36] font_view_update dxf(choose_font_cb_size) 4 $dxf(choose_font_cb_size)
/*     bind $w.cb_size.e <Return> "font_view_update"*/

    combobox_lim $w.cb_color [list black red blue green cyan magenta yellow pink grey20 grey50 grey80] font_view_update dxf(choose_font_cb_color) 10 $dxf(choose_font_cb_color)
/*     bind $w.cb_color.e <Return> "font_view_update"*/

    combobox_lim $w.cb_justify [list left right center] font_view_update dxf(choose_font_cb_justify) 10 $dxf(choose_font_cb_justify)
/*     bind $w.cb_justify.e <Return> "font_view_update"*/

    checkbutton $w.c_bold -highlightthickness 0 -indicatoron 0 -text "B" -font {Times 12 bold} -onvalue bold -offvalue ""  -command "font_view_update" -variable dxf(choose_font_c_bold)
    checkbutton $w.c_italic -highlightthickness 0 -indicatoron 0 -text "I" -font {Times 12 italic} -onvalue italic -offvalue ""  -command "font_view_update" -variable dxf(choose_font_c_italic)
    checkbutton $w.c_underline -highlightthickness 0 -indicatoron 0 -text "U" -font {Times 12 underline} -onvalue underline -offvalue ""  -command "font_view_update" -variable dxf(choose_font_c_underline)

    text $w.view  -font "[get_cur_font]" -width 20 -height 5 -background white

    frame $w.f
    button $w.f.ok -text "Ok" -command " dxf = (text) \"\[.choose_font.view get 0.0 end\]\" ; dxf = (tmp) \"\[get_cur_font\]\"; destroy $w" 
    button $w.f.cancel -text "Close" -command " dxf = (tmp) \"\"; destroy $w"   


   grid $w.l11 $w.l12 $w.l13 $w.l14  -row 0 -pady 2 -padx 4 -sticky w
   grid $w.cb_name $w.cb_size $w.cb_color $w.cb_justify $w.c_bold $w.c_italic $w.c_underline -row 1 -padx 4 -sticky w
   grid $w.view -row 2 -columnspan 7 -sticky we -pady 4
   grid $w.f -row 3 -columnspan 7 -sticky we -pady 5 -padx 5
   grid $w.f.ok $w.f.cancel -row 0 -padx 10

   focus $w.view

   wm geometry $w +150+150
    .gui configure -cursor ""
}

ret  {window_position} (type w , optional x =100 , optional y =100) {
#
    set x [expr [winfo rootx .gui]+$x]
    set y [expr [winfo rooty .gui]+$y]
    wm geometry $w "+$x+$y"
}

ret  {write_file_as} () {
set types { { { XML Files} {.xml} } }
    set file [tk_getSaveFile -initialfile "scc.xml" -title "Save configuration file" -filetypes $types -defaultextension .xml ]

    if {$file != ""} {
        if {[file extension $file] != ".xml"} {
            set file  $file.xml
        }
    }

    return $file
}

ret  {main} (type argc , type argv) {
#
    global largfen
    global entity_id
    global OASIS_GUI_DIR
    global entityselected

    # Load "XML support" packages : they are in subdirectory 'packages'
    package require xml
    package require xml::libxml2
    package require dom
    
    global env
    global file_lue
    set file_lue ""
    global DRAW
    set DRAW(unitXcur) 20
    set DRAW(unitYcur) 50
    
    wm title .gui "OASIS"
    if {$argc > 0} {
        set file [lindex $argv 0]

        #
        #** Lecture du fichier .XML
        #
        if {[file exists $file]} {
            .gui configure -cursor watch
            update
            set erreur [lit_fichier_SCC $file]
            .gui configure -cursor ""
            
            if {! $erreur } {
                set file_lue $file
                wm title .gui "OASIS - $file"
            
                global entityselected
                control_entity $entityselected
                drawall
            } else {
                # Efface les traces d'une config qui serait lue de façon incomplète
                config_RAZ
            }
        }
    }

    #==recupere la derniere taille de la fenetre
    catch {
        set f [open_file ~/.OASIS/gui_oasis_window r]
        gets $f geom
        wm geometry .gui $geom
        close $f
    }

    wm protocol .gui WM_DELETE_WINDOW "quit_gui_oasis"
    drawall
    catch {destroy .start_banner}

    set largfen 37
    control_entity $entityselected

    #===creation des images
    
    # Symboles des tranformations
    foreach transform {add multiply remaillage accumulate average interpol} {
        image create photo img_$transform -file [file join $OASIS_GUI_DIR IMAGES $transform.gif]
    }

    # Boutons
    set imag [image create photo  -file [file join $OASIS_GUI_DIR IMAGES open.gif]]
    .gui.pr.toolframe.toolsbox.fobt configure -image $imag
    bind .gui.pr.toolframe.toolsbox.fobt <Any-Enter> ".gui.pr.tools.infolabel configure -text {Open SCC file}"
    bind .gui.pr.toolframe.toolsbox.fobt <Any-Leave> ".gui.pr.tools.infolabel configure -text {}"

    set imag [image create photo  -file [file join $OASIS_GUI_DIR IMAGES save.gif]]
    .gui.pr.toolframe.toolsbox.but32 configure -image $imag
    bind .gui.pr.toolframe.toolsbox.but32 <Any-Enter> ".gui.pr.tools.infolabel configure -text {Save all (SCC and SMIOC)}"
    bind .gui.pr.toolframe.toolsbox.but32 <Any-Leave> ".gui.pr.tools.infolabel configure -text {}"

    set imag [image create photo  -file [file join $OASIS_GUI_DIR IMAGES zoommoins.gif]]
    .gui.pr.zoomframe.zm configure -image $imag
    bind .gui.pr.zoomframe.zm <Any-Enter> ".gui.pr.tools.infolabel configure -text {Zoom -}"
    bind .gui.pr.zoomframe.zm <Any-Leave> ".gui.pr.tools.infolabel configure -text {}"

    set imag [image create photo  -file [file join $OASIS_GUI_DIR IMAGES zoomplus.gif]]
    .gui.pr.zoomframe.zp configure -image $imag
    bind .gui.pr.zoomframe.zp <Any-Enter> ".gui.pr.tools.infolabel configure -text {Zoom +}"
    bind .gui.pr.zoomframe.zp <Any-Leave> ".gui.pr.tools.infolabel configure -text {}"

    set imag [image create photo  -file [file join $OASIS_GUI_DIR IMAGES lunit.gif]]
    .gui.pr.toolframe.toolsbox.but34 configure -image $imag
    bind .gui.pr.toolframe.toolsbox.but34 <Any-Enter> ".gui.pr.tools.infolabel configure -text {Load XML application definition}"
    bind .gui.pr.toolframe.toolsbox.but34 <Any-Leave> ".gui.pr.tools.infolabel configure -text {}"

    set imag [image create photo  -file [file join $OASIS_GUI_DIR IMAGES binary.gif]]
    .gui.pr.toolframe.toolsbox.but35 configure -image $imag
    bind .gui.pr.toolframe.toolsbox.but35 <Any-Enter> ".gui.pr.tools.infolabel configure -text {Load NetCDF file}"
    bind .gui.pr.toolframe.toolsbox.but35 <Any-Leave> ".gui.pr.tools.infolabel configure -text {}"
}

ret  init (type argc , type argv) {
#initialisations
    combobox_init
    #** chemins
    global OASIS_GUI_DIR
    global env
    global zoomfactor
    set zoomfactor 1

    global plotdown
    set plotdown inactive
    
    # Determine le chemin du script en cours d'execution
    global argv0
    set script_file [file normalize [file join [pwd]  $argv0]]
    # Prend le repertoire
    set OASIS_GUI_DIR [file dirname $script_file]

    #LAURE
    # packages : they are in subdirectory 'packages/lib'
    global auto_path
    lappend auto_path [file join $OASIS_GUI_DIR packages/lib]
    # Lit les paramètres de la ligne de commande
    package require cmdline
    set options {
        {silent          "silent mode : no help balloon"}
    }
    set usage ": oasis-gui.tcl \[options] \noptions:"
    array set params [::cmdline::getoptions argv $options $usage]
    # Vérifie si l'option -silent a été mise sur la ligne de commande
    global no_help_balloon
    set no_help_balloon $params(silent)
    
    global plot
    set plot(lastX) 0
    set plot(lastY) 0
    
    global oasis_GUI_param
    
    global global_font
    set global_font "-adobe-helvetica-bold-r-normal--12-180-90-90-m-90-iso8859-1"
    
    global viewcommcheck
    set viewcommcheck 1
    global oasis4_version; set oasis4_version OASIS4_0_2
    
    global dico_applis
    array set dico_applis {}
    global liste_points_i liste_points_o
    set liste_points_i {}
    set liste_points_o {}
    global dico_units
    array set dico_units {}
    global liste_fichiers dico_caract_fichiers
    set liste_fichiers {}
    array set dico_caract_fichiers {}
    
    global liste_cnx_in
    set liste_cnx_in {}
    global dico_cnx_out
    array set dico_cnx_out {}

    #** default order in selection list
    global orderentity
    set orderentity(CONNECTION)    1
    set orderentity(COUPLING_FIELD)        3
    set orderentity(COMPONENT)    0
    set orderentity(FILE)    0
    
    global objectselected tagselected;    set objectselected ""; set tagselected ""
    
    global entityselected
    set entityselected COMPONENT
}

init $argc $argv

/* */
/*  VTCL GENERATED GUI PROCEDURES*/
/* */

ret  vTclWindow. (type base , optional container =0) {
    if {$base == ""} {
        set base .
    }
    ###################
    # CREATING WIDGETS
    ###################
    if {!$container} {
    wm focusmodel $base passive
    wm geometry $base 1x1+0+0; update
    wm maxsize $base 1009 738
    wm minsize $base 1 1
    wm overrideredirect $base 0
    wm resizable $base 1 1
    wm withdraw $base
    wm title $base "vtcl.tcl"
    bindtags $base "$base Vtcl.tcl all"
    }
    ###################
    # SETTING GEOMETRY
    ###################
}

ret  vTclWindow.ballon_object (type base , optional container =0) {
    if {$base == ""} {
        set base .ballon_object
    }
    if {[winfo exists $base] && (!$container)} {
        wm deiconify $base; return
    }

    global widget

    ###################
    # CREATING WIDGETS
    ###################
    if {!$container} {
    toplevel $base -class Toplevel \
        -borderwidth 1 
    wm withdraw .ballon_object
    wm focusmodel $base passive
    wm geometry $base 1x1+0+0; update
    wm maxsize $base 1009 738
    wm minsize $base 1 1
    wm overrideredirect $base 1
    wm resizable $base 1 1
    wm title $base "ballon_object"
    }
    label $base.text \
        -background #fefed4 -font {helvetica 10} -foreground black 
    ###################
    # SETTING GEOMETRY
    ###################
    pack $base.text \
        -in $base -anchor w -expand 0 -fill none -side left 
}

ret  vTclWindow.gui (type base , optional container =0) {
    if {$base == ""} {
        set base .gui
    }
    if {[winfo exists $base] && (!$container)} {
        wm deiconify $base; return
    }

    global widget
    vTcl:DefineAlias "$base.cpd17.settingbutton" "Menubutton1" vTcl:WidgetProc "$base" 1
    vTcl:DefineAlias "$base.pr.toolframe.cpd18.01" "Mclistbox1" vTcl:WidgetProc "$base" 1
    vTcl:DefineAlias "$base.pr.toolframe.toolsbox" "Frame1" vTcl:WidgetProc "$base" 1
    vTcl:DefineAlias "$base.pr.toolframe.toolsbox.but32" "Button2" vTcl:WidgetProc "$base" 1
    vTcl:DefineAlias "$base.pr.toolframe.toolsbox.but34" "Button16" vTcl:WidgetProc "$base" 1
    vTcl:DefineAlias "$base.pr.toolframe.toolsbox.but35" "Button17" vTcl:WidgetProc "$base" 1
    vTcl:DefineAlias "$base.pr.toolframe.toolsbox.fobt" "Button1" vTcl:WidgetProc "$base" 1

    ###################
    # CREATING WIDGETS
    ###################
    if {!$container} {
    toplevel $base -class Toplevel
    wm focusmodel $base passive
    wm geometry $base 1024x695+0+48; update
    wm maxsize $base 1600 1200
    wm minsize $base 400 300
    wm overrideredirect $base 0
    wm resizable $base 1 1
    wm deiconify $base
    wm title $base "OASIS"
    bind $base <Button-4> {
        catch {%W yview scroll -1 units}
    }
    bind $base <Button-5> {
        catch {%W yview scroll 1 units}
    }
    bind $base <Control-Button-4> {
        catch {%W xview scroll -1 units}
    }
    bind $base <Control-Button-5> {
        catch {%W xview scroll 1 units}
    }
    bind $base <Shift-Button-4> {
        catch {%W yview scroll -5 units}
    }
    bind $base <Shift-Button-5> {
        catch {%W yview scroll 5 units}
    }
    }
    frame $base.cpd17 \
        -borderwidth 1 -relief sunken -background #e6e6e6 -height 30 \
        -width 30 
    menubutton $base.cpd17.01 \
        -anchor w -borderwidth 2 -font {helvetica -12 bold} \
        -menu "$base.cpd17.01.02" -padx 4 -pady 3 -text File -underline 0 \
        -width 4 
    bind $base.cpd17.01 <Enter> {
        .gui.pr.tools.infolabel configure -text "Open, save and print"
    }
    bind $base.cpd17.01 <Leave> {
        .gui.pr.tools.infolabel configure -text " "
    }
    menu $base.cpd17.01.02 \
        -cursor {} -tearoff 0 
    $base.cpd17.01.02 add command \
        -accelerator {} -command config_new -image {} -label {New file} 
    $base.cpd17.01.02 add command \
        -accelerator {} -command config_read -image {} -label {Open SCC file} 
    $base.cpd17.01.02 add command \
        -accelerator {} -command sauve_tout -image {} -label {Save all (SCC and SMIOC)} 
    $base.cpd17.01.02 add command \
        -accelerator {} -command sauve_scc -image {} -label {Save SCC file} 
    $base.cpd17.01.02 add command \
        -accelerator {} -command sauve_smioc -image {} -label {Save SMIOC files}
    $base.cpd17.01.02 add separator
    $base.cpd17.01.02 add command \
        -accelerator {} -command load_XML_ad_files -image {} \
        -label {Load Application Descriptions} 
    $base.cpd17.01.02 add command \
        -accelerator {} -command load_NetCDF_files -image {} \
        -label {Load NetCDF files} 
    $base.cpd17.01.02 add separator
    $base.cpd17.01.02 add command \
        -accelerator {} \
        -command {printer_create .print "Oasis"
printer_print .print draw_print} \
        -image {} -label Print 
    $base.cpd17.01.02 add separator
    $base.cpd17.01.02 add command \
        -accelerator {} -command quit_gui_oasis -image {} -label {Quit Oasis} 
    menubutton $base.cpd17.settingbutton \
        -font {helvetica -12 bold} -menu "$base.cpd17.settingbutton.m" \
        -padx 6 -pady 4 -text Settings -underline 0 
    bind $base.cpd17.settingbutton <Enter> {
        .gui.pr.tools.infolabel configure -text "Set display options, colors"
    }
    bind $base.cpd17.settingbutton <Leave> {
        .gui.pr.tools.infolabel configure -text ""
    }
    menu $base.cpd17.settingbutton.m
    $base.cpd17.settingbutton.m add command \
        -accelerator {} -command experiment_settings -image {} \
        -label {Experiment settings ...} 
    $base.cpd17.settingbutton.m add command \
        -accelerator {} -command Draw_settings -image {} \
        -label {Canvas settings ...} 
    frame $base.pr \
        -borderwidth 2 -relief groove -height 75 -width 200 
    frame $base.pr.tools \
        -height 4 -width 300 
    bind $base.pr.tools <Configure> {
        set l [winfo width .gui]
set l [expr ($l-10) / 7.17]
.gui.pr.tools.resizescrl configure -to $l
    }
    label $base.pr.tools.infolabel \
        -anchor w -background grey95 -borderwidth 1 \
        -font {helvetica -12 bold} -relief sunken -text {} 
    scale $base.pr.tools.resizescrl \
        -bigincrement 0.0 -borderwidth 0 \
        -command {.gui.pr.toolframe.cpd18.01 configure -width} -from 1.0 \
        -highlightthickness 0 -orient horizontal -relief ridge \
        -resolution 1.0 -showvalue 0 -sliderlength 10 -tickinterval 0.0 \
        -to 141.0 -troughcolor #d9d9d9 -variable largfen -width 9 
    frame $base.pr.toolframe \
        -borderwidth 0 -relief sunken -height 1063 -width 125 
    frame $base.pr.toolframe.toolsbox \
        -relief groove -background #e6e6e6 -height 75 \
        -highlightbackground #e6e6e6 -highlightcolor #000000 -width 125 
    button $base.pr.toolframe.toolsbox.fobt \
        -borderwidth 2 -command config_read -text l 
    bind $base.pr.toolframe.toolsbox.fobt <Enter> {
        .gui.pr.tools.infolabel configure -text {Read PrePalm file}
    }
    bind $base.pr.toolframe.toolsbox.fobt <Leave> {
        .gui.pr.tools.infolabel configure -text {}
    }
    button $base.pr.toolframe.toolsbox.but34 \
        -command load_XML_ad_files -padx 3m -text u 
    bind $base.pr.toolframe.toolsbox.but34 <Enter> {
        .gui.pr.tools.infolabel configure -text {Load XML application definition}
    }
    bind $base.pr.toolframe.toolsbox.but34 <Leave> {
        .gui.pr.tools.infolabel configure -text {}
    }
    button $base.pr.toolframe.toolsbox.but35 \
        -command load_NetCDF_files -padx 3m -text u 
    bind $base.pr.toolframe.toolsbox.but35 <Enter> {
        .gui.pr.tools.infolabel configure -text {Load NetCDF file}
    }
    bind $base.pr.toolframe.toolsbox.but35 <Leave> {
        .gui.pr.tools.infolabel configure -text {}
    }
    button $base.pr.toolframe.toolsbox.but32 \
        -anchor center -borderwidth 2 -command sauve_tout
    bind $base.pr.toolframe.toolsbox.but32 <Enter> {
        .gui.pr.tools.infolabel configure -text {Save all (SCC and SMIOC)}
    }
    bind $base.pr.toolframe.toolsbox.but32 <Leave> {
        .gui.pr.tools.infolabel configure -text {}
    }
    frame $base.pr.toolframe.entityframe \
        -borderwidth 2 -height 75 -width 177 
    radiobutton $base.pr.toolframe.entityframe.comprb \
        -anchor w -borderwidth 2 -command {control_entity COMPONENT} \
        -font {helvetica -12 bold} -highlightthickness 0 -padx 1 -pady 3 \
        -selectcolor #b03060 -text {Applications and components } -value 0 \
        -variable entity_id -width 25 
    radiobutton $base.pr.toolframe.entityframe.ficrb \
        -anchor w -command {control_entity FILE} -font {helvetica -12 bold} \
        -highlightthickness 0 -padx 1 -pady 3 -text {NetCDF files } -value 3 \
        -variable entity_id 
    radiobutton $base.pr.toolframe.entityframe.cnxrb \
        -anchor w -command {control_entity CONNECTION} \
        -font {helvetica -12 bold} -highlightthickness 0 -padx 1 -pady 3 \
        -text Connections -value 2 -variable entity_id 
    radiobutton $base.pr.toolframe.entityframe.fieldsrb \
        -anchor w -command {control_entity COUPLING_FIELD} \
        -font {helvetica -12 bold} -highlightthickness 0 -padx 1 -pady 3 \
        -text {Coupling fields} -value 1 -variable entity_id -width 27 
    frame $base.pr.toolframe.buttonfrc \
        -height 75 -width 4 
    button $base.pr.toolframe.buttonfrc.editb \
        -command control_edit_entity -font {helvetica -12 bold} -padx 5 \
        -pady 4 -text Edit 
    button $base.pr.toolframe.buttonfrc.deleteb \
        -command control_delete_entity -font {helvetica -12 bold} -padx 5 \
        -pady 4 -state disabled -text Delete 
    frame $base.pr.toolframe.cpd18 \
        -borderwidth 0 -relief raised -height 2 -width 31 
    scrollbar $base.pr.toolframe.cpd18.02 \
        -borderwidth 1 -command "$base.pr.toolframe.cpd18.01 xview" \
        -orient horizontal -width 10 
    scrollbar $base.pr.toolframe.cpd18.03 \
        -borderwidth 1 -command "$base.pr.toolframe.cpd18.01 yview" -width 11 
    ::mclistbox::mclistbox $base.pr.toolframe.cpd18.01 \
        -background #d9d9d9 -borderwidth 2 -font {helvetica -12 bold} \
        -height 278 -labelanchor center -labelborderwidth 1 \
        -labelrelief raised -relief sunken -selectborderwidth 1 \
        -selectmode extended -width 37 \
        -xscrollcommand "$base.pr.toolframe.cpd18.02 set" \
        -yscrollcommand "$base.pr.toolframe.cpd18.03 set" 
    bind $base.pr.toolframe.cpd18.01 <<ListboxSelect>> {
        control_entity_selectionChanged %W
    }
    bind $base.pr.toolframe.cpd18.01 <Key-Delete> {control_delete_entity}
    bind $base.pr.toolframe.cpd18.01 <Double-Button-1> {
        control_edit_entity
    }
    frame $base.pr.zoomframe \
        -relief groove -height 75 -width 125 
    frame $base.pr.zoomframe.viewframe \
        -borderwidth 0 -relief groove -height 75 -width 208 
    checkbutton $base.pr.zoomframe.viewframe.viewcommcheck \
        -command {update
Draw_comm} -font {helvetica -12 bold} -pady 0 \
        -text {View connections} -variable viewcommcheck 
    button $base.pr.zoomframe.zm \
        -borderwidth 0 \
        -command {global zoomfactor
if {$zoomfactor > .4} {set zoomfactor [expr $zoomfactor-0.1]}
drawall} \
        -padx 0 -pady 0 -relief flat -text button 
    bind $base.pr.zoomframe.zm <Enter> {
        .gui.pr.tools.infolabel configure -text {Zoom -}
    }
    bind $base.pr.zoomframe.zm <Leave> {
        .gui.pr.tools.infolabel configure -text {}
    }
    button $base.pr.zoomframe.zp \
        -borderwidth 0 \
        -command {global zoomfactor
if {$zoomfactor < 1.5} {set zoomfactor [expr $zoomfactor +0.1]}
drawall} \
        -padx 0 -pady 0 -relief flat -text button 
    bind $base.pr.zoomframe.zp <Enter> {
        .gui.pr.tools.infolabel configure -text {Zoom +}
    }
    bind $base.pr.zoomframe.zp <Leave> {
        .gui.pr.tools.infolabel configure -text {}
    }
    frame $base.pr.cpd22 \
        -borderwidth 0 -relief raised -height 30 -width 30 
    scrollbar $base.pr.cpd22.01 \
        -borderwidth 1 -command "$base.pr.cpd22.03 xview" -jump 1 \
        -orient horizontal -width 10 
    scrollbar $base.pr.cpd22.02 \
        -borderwidth 1 -command "$base.pr.cpd22.03 yview" -jump 1 -width 10 
    canvas $base.pr.cpd22.03 \
        -background #fefefe -borderwidth 1 -closeenough 1.0 -height 999 \
        -relief ridge -scrollregion {0 0 2000 3000} -width 2000 \
        -xscrollcommand "$base.pr.cpd22.01 set" \
        -yscrollcommand "$base.pr.cpd22.02 set" 
    bind $base.pr.cpd22.03 <B1-Motion> {
        unitplotmove .gui.pr.cpd22.03 %x %y
    }
    bind $base.pr.cpd22.03 <B3-Motion> {
        unitplotmove .gui.pr.cpd22.03 %x %y
    }
    ###################
    # SETTING GEOMETRY
    ###################
    pack $base.cpd17 \
        -in $base -anchor center -expand 0 -fill x -side top 
    pack $base.cpd17.01 \
        -in $base.cpd17 -anchor center -expand 0 -fill none -side left 
    pack $base.cpd17.settingbutton \
        -in $base.cpd17 -anchor center -expand 0 -fill none -side left 
    pack $base.pr \
        -in $base -anchor center -expand 1 -fill x -side right 
    pack $base.pr.tools \
        -in $base.pr -anchor n -expand 0 -fill x -side bottom 
    pack $base.pr.tools.infolabel \
        -in $base.pr.tools -anchor w -expand 0 -fill x -ipadx 15 -side bottom 
    pack $base.pr.tools.resizescrl \
        -in $base.pr.tools -anchor w -expand 1 -fill x -side left 
    pack $base.pr.toolframe \
        -in $base.pr -anchor n -expand 0 -fill both -side left 
    pack $base.pr.toolframe.toolsbox \
        -in $base.pr.toolframe -anchor center -expand 0 -fill x -side top 
    pack $base.pr.toolframe.toolsbox.fobt \
        -in $base.pr.toolframe.toolsbox -anchor center -expand 0 -fill none \
        -ipadx 2 -ipady 2 -side left 
    pack $base.pr.toolframe.toolsbox.but34 \
        -in $base.pr.toolframe.toolsbox -anchor center -expand 0 -fill none \
        -side left 
    pack $base.pr.toolframe.toolsbox.but35 \
        -in $base.pr.toolframe.toolsbox -anchor center -expand 0 -fill none \
        -side left 
    pack $base.pr.toolframe.toolsbox.but32 \
        -in $base.pr.toolframe.toolsbox -anchor s -expand 0 -fill none \
        -ipadx 2 -ipady 2 -side left 
    pack $base.pr.toolframe.entityframe \
        -in $base.pr.toolframe -anchor nw -expand 1 -fill none -padx 5 \
        -pady 5 -side top 
    grid $base.pr.toolframe.entityframe.comprb \
        -in $base.pr.toolframe.entityframe -column 0 -row 0 -columnspan 1 \
        -rowspan 1 -sticky nesw 
    grid $base.pr.toolframe.entityframe.ficrb \
        -in $base.pr.toolframe.entityframe -column 0 -row 1 -columnspan 1 \
        -rowspan 1 -sticky nesw 
    grid $base.pr.toolframe.entityframe.cnxrb \
        -in $base.pr.toolframe.entityframe -column 0 -row 3 -columnspan 1 \
        -rowspan 1 -sticky nesw 
    grid $base.pr.toolframe.entityframe.fieldsrb \
        -in $base.pr.toolframe.entityframe -column 0 -row 2 -columnspan 1 \
        -rowspan 1 -sticky nesw 
    pack $base.pr.toolframe.buttonfrc \
        -in $base.pr.toolframe -anchor n -expand 1 -fill x -side top 
    pack $base.pr.toolframe.buttonfrc.editb \
        -in $base.pr.toolframe.buttonfrc -anchor center -expand 1 -fill x \
        -side left 
    pack $base.pr.toolframe.buttonfrc.deleteb \
        -in $base.pr.toolframe.buttonfrc -anchor center -expand 1 -fill x \
        -side left 
    pack $base.pr.toolframe.cpd18 \
        -in $base.pr.toolframe -anchor w -expand 0 -fill none -side top 
    grid columnconf $base.pr.toolframe.cpd18 0 -weight 1
    grid rowconf $base.pr.toolframe.cpd18 0 -weight 1
    grid $base.pr.toolframe.cpd18.02 \
        -in $base.pr.toolframe.cpd18 -column 0 -row 1 -columnspan 1 \
        -rowspan 1 -sticky ew 
    grid $base.pr.toolframe.cpd18.03 \
        -in $base.pr.toolframe.cpd18 -column 1 -row 0 -columnspan 1 \
        -rowspan 1 -sticky ns 
    grid $base.pr.toolframe.cpd18.01 \
        -in $base.pr.toolframe.cpd18 -column 0 -row 0 -columnspan 1 \
        -rowspan 1 
    pack $base.pr.zoomframe \
        -in $base.pr -anchor center -expand 0 -fill x -side top 
    pack $base.pr.zoomframe.viewframe \
        -in $base.pr.zoomframe -anchor center -expand 0 -fill none \
        -side right 
    pack $base.pr.zoomframe.viewframe.viewcommcheck \
        -in $base.pr.zoomframe.viewframe -anchor center -expand 0 -fill none \
        -ipadx 6 -side left 
    pack $base.pr.zoomframe.zm \
        -in $base.pr.zoomframe -anchor center -expand 0 -fill none -side left 
    pack $base.pr.zoomframe.zp \
        -in $base.pr.zoomframe -anchor center -expand 0 -fill none -side left 
    pack $base.pr.cpd22 \
        -in $base.pr -anchor center -expand 0 -fill none -side left 
    grid columnconf $base.pr.cpd22 0 -weight 1
    grid rowconf $base.pr.cpd22 0 -weight 1
    grid $base.pr.cpd22.01 \
        -in $base.pr.cpd22 -column 0 -row 1 -columnspan 1 -rowspan 1 \
        -sticky ew 
    grid $base.pr.cpd22.02 \
        -in $base.pr.cpd22 -column 1 -row 0 -columnspan 1 -rowspan 1 \
        -sticky ns 
    grid $base.pr.cpd22.03 \
        -in $base.pr.cpd22 -column 0 -row 0 -columnspan 1 -rowspan 1 \
        -sticky nesw 
}

Window show .
Window show .ballon_object
Window show .gui

main $argc $argv