wizard.tcl

Go to the documentation of this file.

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

/* */
/* BEGIN combobox*/

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
}

/* END combobox*/
/* */
/* BEGIN procedures*/

/*  Procedure appelee sur click sur bouton <NEXT>*/
ret  {on_next_page} () {

    # Valide la page en cours
    if {[validate_page true]} {
        # Choisit la page suivante
        choose_next_page
        # Affiche la page
        display_page
    }
}


/*  Procedure appelee sur click sur bouton <PREVIOUS>*/
ret  {on_previous_page} () {

    # Valide la page en cours
    validate_page false
    # Choisit la page precedente
    choose_previous_page
    # Affiche la page
    display_page
}

ret  {validate_page} (type if_, type valid_, type required) {
    global Type_page
    # Lit les donnees saisies dans la page
    switch $Type_page {
        0 { set valid [validate_application_page $if_valid_required] }
        1 { set valid [validate_component_page $if_valid_required] }
        2 { set valid [validate_field_page $if_valid_required] }
        3 { set valid 1 }
    }
    return $valid
}

/*  Affiche et initialise une page de saisie*/
ret  {display_page} () {
    # Donnees de l'application
    global Data
    # Type de page d'ecran en cours :
    global Type_page
    # Numero de composant en cours de saisie
    global Num_composant
    # Numero de champ de couplage en cours de saisie
    global Num_champ

    # Des-affiche la page en cours
    pack forget .initial .comp_name .component .field .terminal

    # Affiche la page interessante
    array set page_names {0 .initial 1 .component 2 .field 3 .terminal}
    set page_name $page_names($Type_page)
    pack $page_name -after .intro -side top -expand 1
    
    # Si page de composant ou de champ
    if {$Type_page == 1 || $Type_page == 2} {
        # Affiche le titre du composant
        pack .comp_name -after .intro -side top -pady 5
    }
    
    # Initialise les donnees de la page
    switch $Type_page {
        0 { init_application_page }
        1 { init_component_page }
        2 { init_field_page }
        3 { init_terminal_page }
    }
    # Affiche les boutons de validation adequats
    switch $Type_page {
        0 {
            # C'est la premiere page
            pack forget .buttons.previous .buttons.ok
            pack .buttons.next -side right -expand 1 -padx 10
        }
        1 -
        2 {
            # Page intermediaire
            pack forget .buttons.ok
            pack .buttons.previous -side left -expand 1 -padx 10
            pack .buttons.next -side right -expand 1 -padx 10
        }
        3 {
            # Page terminale
            pack forget .buttons.next
            pack .buttons.previous -side left -expand 1 -padx 10
            pack .buttons.ok -side right -expand 1 -padx 10
        }
    }
}


/*  Determine le type de page a afficher */
/*  apres appui sur le bouton <Next>*/
ret  {choose_next_page} () {
    global Data Type_page Num_composant Num_champ
    switch $Type_page {
        0 { 
            # Page initiale
            # S'il y a au moins un composant dans l'appli
            if {[llength $Data(l_composants)] > 0} {
                set Type_page 1
                set Num_composant 0
            } else {
                set Type_page 3
            }
        }
         1 {
            # Page initiale d'un composant
            # Nom du composant
            set nom_comp [lindex $Data(l_composants) $Num_composant]
            # S'il y a au moins un champ dans le composant
            if {[llength $Data(comp.$nom_comp.lchamps)]} {
                set Type_page 2
                set Num_champ 0
            } else {
                # Passe au composant suivant ou a la page terminale
                incr Num_composant
                if { $Num_composant < [llength $Data(l_composants)]} {
                    set Type_page 1
                } else {
                    set Type_page 3
                }
            }
        }
        2 {
            # Page d'un champ d'un composant
            # Nom du composant
            set nom_comp [lindex $Data(l_composants) $Num_composant]
            # Si ce n'est pas le dernier champ dans le composant
            incr Num_champ
            if {$Num_champ < [llength $Data(comp.$nom_comp.lchamps)]} {
                set Type_page 2
            } else {
                # Passe au composant suivant ou a la page terminale
                incr Num_composant
                if { $Num_composant < [llength $Data(l_composants)]} {
                    set Type_page 1
                } else {
                    set Type_page 3
                }
            }
        }

    }
}


/*  Determine le type de page a afficher */
/*  apres appui sur le bouton <Previous>*/
ret  {choose_previous_page} () {
    global Data Type_page Num_composant Num_champ

    switch $Type_page {
        1 {
            # Page initiale d'un composant
            # Si c'est le premier composant
            if {$Num_composant == 0} {
                set Type_page 0
            } else {
                # Passe au composant precedent
                incr Num_composant -1
                # Nom du composant
                set nom_comp [lindex $Data(l_composants) $Num_composant]
                # Nombre de champs
                set nb_champs [llength $Data(comp.$nom_comp.lchamps)]
                if {$nb_champs > 0} {
                    # Passe au dernier champ du composant precedent
                    set Num_champ [expr $nb_champs - 1]
                    set Type_page 2
                } else {
                    # Passe a la page initiale du composant precedent
                    set Type_page 1
                }
            }
        }
        2 {
            # Page d'un champ d'un composant
            # Nom du composant
            set nom_comp [lindex $Data(l_composants) $Num_composant]
            # Si ce n'est pas le premier champ dans le composant
            incr Num_champ -1
            if {$Num_champ >= 0} {
                set Type_page 2
            } else {
                # Passe a la page initiale du composant
                set Type_page 1
            }
        }
        3 { 
            # Page terminale
            # S'il y a au moins un composant dans l'appli
            set nb_composants [llength $Data(l_composants)]
            if {$nb_composants} {
                set Num_composant [expr $nb_composants - 1]
                set nom_comp [lindex $Data(l_composants) $Num_composant]
                # S'il y a au moins un champs dans le dernier composant
                set nb_champs [llength $Data(comp.$nom_comp.lchamps)]
                if {$nb_champs > 0} {
                    # Passe au dernier champ du composant
                    set Num_champ [expr $nb_champs - 1]
                    set Type_page 2
                } else {
                    # Passe a la page initiale du composant
                    set Type_page 1
                }
            } else {
                set Type_page 0
            }
        }

    }
}

/*  Cree les champs de saisie de la page initiale*/
/*  Cette page s'appelle .initial*/
ret  {create_application_page} () {
    global Data
    # Variables de saisie
    global start_mode coupling_mode
        
    labelframe .initial -text "Application main attributes"
    set w .initial
    set r 0
    
    #== Name
    label $w.label1 -text "Symbolic name : " -fg #ee3333
    entry $w.entry1 -textvariable Data(name) -width 20 -background white
    grid $w.label1 $w.entry1 -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {Enter here the application name, which should match argument appl_name of PSMILe call prism_init}
    help_attach_balloon $w.entry1 $help_text
    incr r
    
    #== Long name
    label $w.label2 -text "Description : "
    entry $w.entry2 -textvariable Data(long_name) -width 35 -background white
    grid $w.label2 $w.entry2 -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {a short description of the application}
    help_attach_balloon $w.entry2 $help_text
    incr r
    
    #== number of processes
    label $w.label3 -text "Number of processes : " -fg #ee3333
    frame $w.frrank
    trace variable Data(nb_procs_min) w {entry_forceRegexp {^[0-9]*$} }
    trace variable Data(nb_procs_min) w {entry_forceRegexp {^[0-9]*$} }
    trace variable Data(nb_procs_incr) w {entry_forceRegexp {^[0-9]*$} }
    pack [entry $w.frrank.e1 -textvariable Data(nb_procs_min) -width 10 -background white] -side left
    pack [label $w.frrank.l1 -text " to "] -side left -padx 2
    pack [entry $w.frrank.e2 -textvariable Data(nb_procs_max) -width 10 -background white] -side left -padx 2
    pack [label $w.frrank.l2 -text " increment "] -side left -padx 2
    pack [entry $w.frrank.e3 -textvariable Data(nb_procs_incr) -width 10 -background white] -side left -padx 2
    grid $w.label3 $w.frrank -row $r -sticky w
    # Ajoute une bulle d'aide pour ce groupe de champs
    set help_text {the total number range of processes the application can run on}
    help_attach_balloon $w.frrank $help_text
    incr r
    
    #== Start mode
    label $w.label4 -text "Start mode : " -fg #ee3333
    combobox_lim $w.cmb4 {spawn notspawn notspawn_or_spawn} {} start_mode 20 "" 1
    grid  $w.label4 $w.cmb4 -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {the mode into which the application may be started.
For the spawn approach, only the OASIS Driver should be started and a full MPI2 implementation is required as the Driver uses the MPI2 MPI_Comm_Spawn_Multiple functionality.
If only MPI1 implementation is available, the Driver and the applications must be all started at once in the run script; this is the so-called not spawn approach (see Oasis User Guide, section: the driver part).}
    help_attach_balloon $w.cmb4 $help_text
    incr r

    #== Coupling mode
    label $w.label5 -text "Coupling mode : " -fg #ee3333
    combobox_lim $w.cmb5 {coupled standalone coupled_or_standalone} {} coupling_mode 20 "" 1
    grid  $w.label5 $w.cmb5 -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {the mode into which the application may run}
    help_attach_balloon $w.cmb5 $help_text
    incr r

    #== Components
    label $w.label7 -text "Components : " -fg #ee3333
    grid  $w.label7 -row $r -column 0 -sticky nw -pady 10
    
    # une "scrollable frame" pour les "components"
    scrollform_create $w.components
    set form [scrollform_interior $w.components]
    $w.components.vport configure -height 140
    $form configure -borderwidth 1 -relief sunken -height 20
    grid [button $form.add -text "Add" -command "edited_list_add $form component"] -sticky w
    grid $w.components -row $r -column 1 -sticky w -pady 10
    # Ajoute une bulle d'aide pour ce champ
    set help_text {the list of components included in the application : each component name that you enter should match the argument comp_name of each PSMILe call prism_init_comp.
In order to remove one item from the list, click on the right mouse button.}
    help_attach_balloon $w.components $help_text
    incr r
}

/*  Cree les champs de saisie de la page initiale d'un composant        */
/*  Cette page s'appelle .component*/
ret  {create_component_page} () {
    
    # Donnees associees aux champs de saisie
    global Comp_long_name
    global Comp_procs_min Comp_procs_max Comp_procs_incr
    global Comp_simul Comp_default
    
    labelframe .component -text "Component main attributes"
    set w .component
    set r 0
    
    #== Long name
    label $w.label2 -text "Description : "
    entry $w.entry2 -textvariable Comp_long_name -width 35 -background white
    grid $w.label2 $w.entry2 -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {a short general description of the component model}
    help_attach_balloon $w.entry2 $help_text
    incr r
    
    #== Simulated
    label $w.label3 -text "Simulated : " -fg #ee3333
    set Comp_simul ""
    combobox_lim $w.cmb3 {ocean sea_ice ocean_biogeochemistry atmosphere atmospheric_chemistry land} {} Comp_simul 25 $Comp_simul -1
    grid  $w.label3 $w.cmb3 -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {the simulated part of the climate system.
if an application contains more than one component simulating the same part of the climate system, the user will have to choose among these components at coupling configuration time.}
    help_attach_balloon $w.cmb3 $help_text
    incr r
    
    #== Default
    label $w.label4 -text "Default component : " -fg #ee3333
    set Comp_default yes
    combobox_lim $w.cmb4 {yes no} {} Comp_default 10 $Comp_default 1
    grid  $w.label4 $w.cmb4 -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {whether or not this component is always active in the application}
    help_attach_balloon $w.cmb4 $help_text
    incr r
    
    #== number of processes
    label $w.label5 -text "Number of processes : " -fg #ee3333
    frame $w.frrank
    trace variable Comp_procs_min  w {entry_forceRegexp {^[0-9]*$} }
    trace variable Comp_procs_max  w {entry_forceRegexp {^[0-9]*$} }
    trace variable Comp_procs_incr w {entry_forceRegexp {^[0-9]*$} }
    pack [entry $w.frrank.e1 -textvariable Comp_procs_min -width 10 -background white] -side left
    pack [label $w.frrank.l1 -text " to "] -side left -padx 2
    pack [entry $w.frrank.e2 -textvariable Comp_procs_max -width 10 -background white] -side left -padx 2
    pack [label $w.frrank.l2 -text " increment "] -side left -padx 2
    pack [entry $w.frrank.e3 -textvariable Comp_procs_incr -width 10 -background white] -side left -padx 2
    grid $w.label5 $w.frrank -row $r -sticky w
    # Ajoute une bulle d'aide pour ce groupe de champs
    set help_text {the total number range of processes on which the component can run}
    help_attach_balloon $w.frrank $help_text
    incr r

    # S�arateur
    frame $w.sep2 -width 200 -height 2 -borderwidth 1 -relief sunken
    grid  $w.sep2 -row $r -columnspan 2 -pady 15
    incr r

    #== Grids and periodicity

    label $w.label6 -text "Grids : " -fg #ee3333
    scrollform_create $w.grids
    set form [scrollform_interior $w.grids]
    button $w.insert_grid -text "Add" -command "grid_insert $form"
    grid  $w.label6 $w.insert_grid -row $r -sticky w
    incr r

    $w.grids.vport configure -height 80
    grid $w.grids -row $r -sticky w 
    # Ajoute une bulle d'aide pour ce groupe de champs
    set help_text {Enter all the grids possibles for a component and the direction of periodicity if there is ; the grid name must fit the argument of prism_def_grid}
    help_attach_balloon $w.grids $help_text
    incr r
    # une frame et un label pour le titre
    frame $w.fr2 
    grid $w.fr2 -row $r -sticky w -columnspan 4
    label $w.fr2.title1 -text "                                     Name               I periodic       J periodic       K periodic" -borderwidth 1 -justify left
    pack $w.fr2.title1 -anchor w
    incr r
    # une frame scrollable pour les "grilles"
    grid $w.grids -row $r -column 1 -sticky ew 
    grid $w.grids -row $r -sticky ew 
    $form configure -borderwidth 1 -relief sunken
    # insertion des boutons pour les grilles existantes
    incr r

    #== Fields
    label $w.label7 -text "Coupling fields : " -fg #ee3333
    grid  $w.label7 -row $r -column 0 -sticky nw -pady 10
    
    # une "scrollable frame" pour les "fields"
    scrollform_create $w.fields
    set form [scrollform_interior $w.fields]
    $w.fields.vport configure -height 140
    $form configure -borderwidth 1 -relief sunken -height 20
    grid [button $form.add -text "Add" -command "edited_list_add $form field"] -sticky w
    grid $w.fields -row $r -column 1 -sticky w -pady 10
    # Ajoute une bulle d'aide pour cette liste
    set help_text {Enter here all coupling/IO fields possibly received or provided by the component model from/to its external environment (another model or a disk file) through prism_get or prism_put calls.
Each field name must match 2nd argument in the corresponding PSMILe call prism_def_var.

In order to remove one item from the list, click on the right mouse button.}
    help_attach_balloon $w.fields $help_text
    incr r
}


ret  {grid_boutons_insert} (type form , type grid , type nb_, type grids) {
# Ajoute une ligne au formulaire de saisie des grilles
    global Grid_names
    global Data Num_composant
    global OASIS_GUI_DIR
    
    # Ajoute une ligne
    set no_ligne $nb_grids

    # Nom du composant
    set nom_comp [lindex $Data(l_composants) $Num_composant]
    grid [entry $form.n$grid -textvariable Grid_names($nom_comp.grid.$grid.name) -width 10 -relief groove -background white -borderwidth 1] -row $no_ligne -column 0
    combobox_lim $form.pi$grid {true false} {} Grid_names($nom_comp.grid.$grid.periodi) 10 $Grid_names($nom_comp.grid.$grid.periodi) 1
    grid $form.pi$grid -row $no_ligne -column 1
    combobox_lim $form.pj$grid {true false} {} Grid_names($nom_comp.grid.$grid.periodj) 10 $Grid_names($nom_comp.grid.$grid.periodj) 1
    grid $form.pj$grid -row $no_ligne -column 2
    combobox_lim $form.pk$grid {true false} {} Grid_names($nom_comp.grid.$grid.periodk) 10 $Grid_names($nom_comp.grid.$grid.periodk) 1
    grid $form.pk$grid -row $no_ligne -column 3
    
    set file delete1.xbm
    grid [button  $form.delete$grid -bitmap  @[file join $OASIS_GUI_DIR IMAGES $file] -command "grid_boutons_delete $form $grid; grid_delete $grid" -background white -foreground red -relief groove  -borderwidth 1] -row $no_ligne -column 4
    focus $form.n$grid 
    bind $form.pk$grid <KeyPress-Return> "grid_boutons_next $form $grid"
    bind $form.pk$grid <KeyPress-Tab> "grid_boutons_next $form $grid"
}

ret  {grid_boutons_delete} (type form , type grid) {
# Supprime une ligne du tableau des grilles pour l'appli
# avant que la ligne ait ��supprim� en m�oire de la variable Grid_names
#
    global Grid_names
    global Data Num_composant

    # Nom du composant
    set nom_comp [lindex $Data(l_composants) $Num_composant]

    array set info_grid [grid info $form.n$grid]
    set num_ligne $info_grid(-row)
    
    destroy $form.n$grid; destroy $form.pi$grid; destroy $form.pj$grid; destroy $form.pk$grid; destroy $form.delete$grid

    set grid_suivants [lrange $Grid_names($nom_comp.lgrid) [expr $num_ligne + 1] end]
    # Pour toutes les lignes suivantes
    set i $num_ligne
    foreach grid_suivant $grid_suivants {
        # Change le no de lignes des trois widgets
        grid configure $form.n$grid_suivant $form.pi$grid_suivant $form.pj$grid_suivant $form.pk$grid_suivant $form.delete$grid_suivant -row $i
        incr i
    }
}

ret  {grid_delete} (type grid) {
# Supprime une grille de la liste pour une composante
    global Grid_names
    global Data Num_composant

    # Nom du composant
    set nom_comp [lindex $Data(l_composants) $Num_composant]
    
    # Supprime de la liste
    set Grid_names($nom_comp.lgrid) [lsearch -not -all -inline $Grid_names($nom_comp.lgrid) $grid]
    # Oublie ses parametres
    array unset Grid_names grid.$grid.*
}

ret  {grid_boutons_next} (type form , type grid) {
    global Grid_names
    global Data Num_composant

    # Nom du composant
    set nom_comp [lindex $Data(l_composants) $Num_composant]
    
    # Determine le no de ligne du bouton
    array set info_grid [grid info $form.n$grid]
    set num_ligne $info_grid(-row)
    
    # Si le bouton est en derniere ligne de la table
    if { [lindex [grid size $form] 1] == [expr $num_ligne + 1] } {
        grid_insert $form
    } else {
        set grid_suivant [lindex $Grid_names($nom_comp.lgrid) [expr $num_ligne + 1]]
        focus $form.n$grid_suivant
    }
}

ret  {grid_insert} (type form) {
# Ajoute une nouvelle grille
    global Grid_names
    global Data Num_composant

    # Nom du composant
    set nom_comp [lindex $Data(l_composants) $Num_composant]
    
    set nb_grids [llength $Grid_names($nom_comp.lgrid)]
    # Si d�a des grilles sont listees
    if { $nb_grids != 0 } {
        # D�ermine le no du dernier identifiant de grille (id = num�o)
        set derniere_grid [lindex $Grid_names($nom_comp.lgrid) end]
        # Cr� un nouvel identifiant de grille
        set nouvelle_grid [expr $derniere_grid + 1]
    } else {
        set nouvelle_grid 1
    }
    # Ajoute a la liste
    lappend Grid_names($nom_comp.lgrid) $nouvelle_grid
    set Grid_names($nom_comp.grid.$nouvelle_grid.name) ""
    set Grid_names($nom_comp.grid.$nouvelle_grid.periodi) ""
    set Grid_names($nom_comp.grid.$nouvelle_grid.periodj) ""
    set Grid_names($nom_comp.grid.$nouvelle_grid.periodk) ""

    # Ajoute une ligne au formulaire
    grid_boutons_insert $form $nouvelle_grid $nb_grids
}

/*  Cree les champs de saisie de la page d'un champ de couplage*/
/*  Cette page s'appelle .field*/
ret  {create_field_page} () {
    # Donnees globales
    global CF_standard_name_list
    global Row_in_field_page
    # Donnees associees aux champs de saisie
    global Field_long_name Field_std_name Field_intent 
    global Field_req_but_change Field_gather_scatter 
    global Field_type Field_bundle_size Field_units Field_datatype
    global Field_period_value_1 Field_period_unit_1
    global Field_period_value_2 Field_period_unit_2

    # Initiqlise les champs de saisie de cette page    
    set Field_long_name ""
    set Field_type single
    set Field_bundle_size 1
    set Field_std_name ""
    #== bundle : component standard names
    for {set i 1} {$i < 11} {incr i} {
        global Field_comp_std_name_$i
        set Field_comp_std_name_$i ""
    }    
    set Field_intent ""
    set Field_req_but_change yes
    set Field_gather_scatter no
    set Field_units ""
    set Field_datatype ""
    set Field_period_value_1 1
    set Field_period_unit_1 ""
    set Field_period_value_2 1
    set Field_period_unit_2 ""

    labelframe .field -text "Coupling field attributes"
    set w .field
    set r 0
    
    #== Name
    label $w.label1 -text "Symbolic name : "
    label $w.label11 -relief sunken
    grid $w.label1 $w.label11 -row $r -sticky w
    incr r
    
    # Long name
    label $w.label2a -text "Description : "
    entry $w.entry2a -textvariable Field_long_name -width 35 -background white
    grid $w.label2a $w.entry2a -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {a general description of the field}
    help_attach_balloon $w.entry2a $help_text
    incr r
    
    # Type : Single or bundle
    label $w.label3 -text "Type : " 
    frame $w.fr_type
    set Field_type single
    combobox_lim $w.fr_type.cmb {single bundle} CF_field_type_change Field_type 10 $Field_type 1
    # Ajoute une bulle d'aide pour ce champ
    set help_text {the coupling/IO field physical type}
    help_attach_balloon $w.fr_type.cmb $help_text
    pack $w.fr_type.cmb -side left 
    
    #== Bundle : number of components
    label $w.fr_type.label -text "size : " -fg #ee3333
    entry $w.fr_type.entry -textvariable Field_bundle_size -width 10 -background white    
    # Ajoute une bulle d'aide pour ce champ
    set help_text {the number of bundles}
    help_attach_balloon $w.fr_type.entry $help_text
    # pack $w.fr_type.label $w.fr_type.entry -side left -padx 5
    
    # Type et "Bundle size" sur la meme ligne
    grid  $w.label3 $w.fr_type -row $r -sticky w
    incr r
    
    #== Standard name
    label $w.label2 -text "CF Standard name : " -fg #ee3333
    set Field_std_name ""
    frame $w.stdname
    combobox_lim $w.stdname.cmb $CF_standard_name_list {} Field_std_name 35 $Field_std_name -1
    button $w.stdname.bt -text "Search list" -command "CF_search_list"
    pack $w.stdname.cmb -side left
    pack $w.stdname.bt -side left -padx 5
    grid $w.label2 $w.stdname -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {the standard variable name following the CF convention (if it exists). This uniquely identifies the nature of the coupling/IO field. In case of bundle, more elements need to be specified (one for each bundle component)}
    help_attach_balloon $w.stdname.cmb $help_text
    incr r

    #== Bundle : other standard names
    set Row_in_field_page(other_std_names) $r
    for {set i 1} {$i < 11} {incr i} {
        label "$w.label_std$i" -text "  - name of bundle $i : " -fg #ee3333
        global Field_comp_std_name_$i
        set Field_comp_std_name_$i ""
        combobox_lim $w.cmb_std$i $CF_standard_name_list {} Field_comp_std_name_$i 35 "" -1
        # Ajoute une bulle d'aide pour ce champ
        set help_text {bundle name following the CF convention (if it exists)}
        help_attach_balloon $w.cmb_std$i $help_text
        incr r
    }
    # Execute une procedure a chaque changement de valeur
    trace variable Field_bundle_size w {entry_forceRegexp {^[0-9]*$} }
    trace variable Field_bundle_size w {CF_bundle_size_change}

    # intent : Input/Output
    label $w.label2c -text "Intent : " -fg #ee3333
    set Field_intent ""
    combobox_lim $w.cmb2c {input output {input/output}} {Field_intent_change} Field_intent 10 "" 1
    grid  $w.label2c $w.cmb2c -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {Describes if the coupling/IO field may be exported, through PSMILe prism_put call, or imported, through a prism get_call, or both.}
    help_attach_balloon $w.cmb2c $help_text
    incr r
    
    # required
    set Row_in_field_page(required_but_changeable) $r
    label $w.label2d -text "Required : " 
    combobox_lim $w.cmb2d {yes no} {} Field_req_but_change 10 yes 1
    # on ne l'affiche pas systematiquement
    # grid  $w.label2d $w.cmb2d -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {If input of the coupling/IO field (imported through a prism_get) is required in the component code, set this attriute to "yes".}
    help_attach_balloon $w.cmb2d $help_text
    incr r

    # Non masked value gathering/scattering
    label $w.label2e -text "Gathering/Scattering : "
    combobox_lim $w.cmb2e {yes no} {} Field_gather_scatter 10 no 1
    grid $w.label2e $w.cmb2e -row $r -sticky w
    # Ajoute une bulle d'aide pour ce champ
    set help_text {Non masked value gathering (input field) or scattering (output field).
This attribute should be specified in the following conditions :

- Input field : when the grid information transfered to the PSMILe covers the whole grid (masked points included), and when the array expected through prism_get API is a vector gathering only the non-masked points.
If this attribute is set to "yes", gathering is performed automatically on an input field below the prism_get by the target PSMILe.

- Output field : when grid information transfered to the PSMILe includes the masked points and when the array transfered to the prism_put API is a vector gathering only the non-masked points.
If this attribute is set to "yes", scattering is performed automatically on an output field below the prism_put by the source PSMILe.}
    help_attach_balloon $w.cmb2e $help_text
    incr r
    
    # Units
    label $w.label4 -text "Units : " -fg #ee3333
    entry $w.entry4 -textvariable Field_units -width 20 -background white
    grid $w.label4 $w.entry4 -row $r -sticky w
    set help_text {the coupling/IO field physical units}
    help_attach_balloon $w.entry4 $help_text
    incr r

    # Datatype
    label $w.label6 -text "Numeric datatype : " -fg #ee3333
    set Field_datatype ""
    combobox_lim $w.cmb6 {real double integer} {} Field_datatype 10 $Field_datatype 1
    grid  $w.label6 $w.cmb6 -row $r -sticky w
    set help_text {the coupling/IO field numeric type}
    help_attach_balloon $w.cmb6 $help_text
    incr r
    
    #=== Minimal exchange period
    grid [label $w.label8 -text "Minimal exchange period : " -fg #ee3333] -row $r -column 0 -sticky w

    grid [frame $w.frexch1] -row $r -column 1 -sticky w
    trace variable Field_period_value_1 w {entry_forceRegexp {^[0-9]*$} }
    pack [entry $w.frexch1.en -takefocus 1 -textvariable Field_period_value_1 -width 10 -background white] -side left
    set liste_unites {seconds minutes hours days months years}
    combobox_lim $w.frexch1.cmb $liste_unites {} Field_period_unit_1 28 "" 1
    pack $w.frexch1.cmb -side left -padx 2
    set help_text {the period at which the prism_put or prism_get is called in the code (to define this period the developer may specify a number of seconds, minutes, hours, days, months, or years)}
    help_attach_balloon $w.frexch1 $help_text
    incr r

    #=== Minimal exchange period 2 (quand le champ est en input et output)
    set Row_in_field_page(min_period) $r
    label $w.label9 -text "Minimal period (Out) :    " -fg #ee3333

    frame $w.frexch2
    trace variable Field_period_value_2 w {entry_forceRegexp {^[0-9]*$} }
    pack [entry $w.frexch2.en -takefocus 1 -textvariable Field_period_value_2 -width 10 -background white] -side left
    combobox_lim $w.frexch2.cmb $liste_unites {} Field_period_unit_2 28 "" 1
    pack $w.frexch2.cmb -side left -padx 2
    set help_text {the period at which the prism_put is called in the code}
    help_attach_balloon $w.frexch2 $help_text
    # L'affichage de cette ligne est conditionnel    
    # grid $w.label9 $w.frexch2 -row $r -sticky w
    incr r

}

/*  Ecran terminal*/
/* */
/*  Cree les champs d'affichage de la page terminale*/
/*  */
ret  create_terminal_page () {

    labelframe .terminal -text "Validation"
    set w .terminal
    
    frame $w.fr
    label $w.fr.titre -justify left -text "Files to be created :" -font {helvetica -12 bold underline} 
    label $w.fr.titre2 -justify left -text " (Note: existing ones will be replaced) "
    pack $w.fr.titre $w.fr.titre2 -side left
    pack $w.fr -side top -anchor w -fill x -padx 10 -pady 5
    #== Liste des fichiers générés : text to be determined later
    label $w.label1 -anchor w -justify left -text ""  -relief sunken -bg white
    pack $w.label1 -side top -fill x -padx 15 -pady 5
    
    label $w.label2 -justify center -text "Please, click on OK to validate all the data you entered
and generate the above XML files that describe the application and its components"
    pack $w.label2 -side top -fill x -padx 10 -pady 20
        
}

ret  {init_application_page} () {
    global Data
    global List_data
    # Variables de saisie
    global start_mode coupling_mode

    #== Start mode
    set start_mode $Data(start_mode)
    set indice [lsearch {spawn notspawn notspawn_or_spawn} $start_mode]
    if {$indice != -1} { .initial.cmb4 select $indice }

    #== Coupling mode
    set coupling_mode $Data(coupling_mode)
    set indice [lsearch {coupled standalone coupled_or_standalone} $coupling_mode]
    if {$indice != -1} { .initial.cmb5 select $indice }

    # Insertion des lignes pour les "components" existant
    # ---------------------------------------------------

    set form [scrollform_interior .initial.components]
    set nb_components 0
    set List_data(component.liste) {}
    foreach component_name $Data(l_composants) {
        set id_component $nb_components
        lappend List_data(component.liste) $id_component
        set List_data(component.$id_component) $component_name
        edited_list_widget_insert $form component $id_component $nb_components
        incr nb_components
    }
    # Ajoute une ligne vierge dans la liste des "components"
    edited_list_insert $form component
    # Met le focus sur le 1er champ
    focus .initial.entry1
}

/*  Initialise les donnees de la page initiale d'un composant        */
ret  {init_component_page} () {
    # Donnees
    global Data Num_composant
    # Donnees associees aux champs de saisie
    global Comp_long_name
    global Comp_simul Comp_default
    global Comp_procs_min Comp_procs_max Comp_procs_incr
    global Grid_names
    # Donnees saisies dans une liste 
    global List_data

    
    # Nom du composant
    set nom_comp [lindex $Data(l_composants) $Num_composant]

    #== Affiche le nom du composant
    .comp_name.label11 configure -text $nom_comp
    #== Long name
    set Comp_long_name ""
    catch {set Comp_long_name $Data(comp.$nom_comp.long_name)}
    
    #== Simulated
    set Comp_simul ""
    catch {set Comp_simul $Data(comp.$nom_comp.simul)}
    set indice [lsearch {ocean sea_ice ocean_biogeochemistry atmosphere atmospheric_chemistry land} $Comp_simul]
    if {$indice != -1} { .component.cmb3 select $indice }
    
    #== Default
    set Comp_default ""
    catch {set Comp_default $Data(comp.$nom_comp.default)}
    set indice [lsearch {yes no} $Comp_default]
    if {$indice != -1} { .component.cmb4 select $indice }
    
    #== number of processes
    # Test le nombre de composants dans l'application
    if { [llength $Data(l_composants)] > 1 } {
        set Comp_procs_min  1
        set Comp_procs_max  1
        set Comp_procs_incr 1
    } else {
        set Comp_procs_min $Data(nb_procs_min)
        set Comp_procs_max $Data(nb_procs_max)
        set Comp_procs_incr $Data(nb_procs_incr)
    }
    
    catch {set Comp_procs_min  $Data(comp.$nom_comp.procs_min)}
    catch {set Comp_procs_max  $Data(comp.$nom_comp.procs_max)}
    catch {set Comp_procs_incr $Data(comp.$nom_comp.procs_incr)}
    

    # Insertion des lignes pour les "fields" existant
    # -----------------------------------------------

    set form [scrollform_interior .component.fields]
    set nb_fields 0
    set List_data(field.liste) {}
    foreach field_name $Data(comp.$nom_comp.lchamps) {
        set id_field $nb_fields
        lappend List_data(field.liste) $id_field
        set List_data(field.$id_field) $field_name
        edited_list_widget_insert $form field $id_field $nb_fields
        incr nb_fields
    }
    # Ajoute une ligne vierge dans la liste des "fields"
    edited_list_insert $form field

    # Insertion des lignes pour les "grilles" existantes
    # -----------------------------------------------

    set form [scrollform_interior .component.grids]
    set nb_grids 0
    foreach id_grid $Grid_names($nom_comp.lgrid) {
        grid_boutons_insert $form $id_grid $nb_grids
        incr nb_grids
    }
}

/*  Initialise les donnees de la page d'un champ de couplage*/
ret  {init_field_page} () {
    # Donnees
    global Data Num_composant Num_champ
    # Donnees associees aux champs de saisie
    global Field_long_name Field_std_name Field_intent 
    global Field_req_but_change Field_gather_scatter 
    global Field_type Field_bundle_size Field_units Field_datatype
    global Field_period_value_1 Field_period_unit_1
    global Field_period_value_2 Field_period_unit_2
    
    # Nom du composant
    set nom_comp [lindex $Data(l_composants) $Num_composant]
    # Nom du champ
    set nom_champ [lindex $Data(comp.$nom_comp.lchamps) $Num_champ]
    # Clef d'acces aux attributs du champ
    set clef_champ comp.$nom_comp.field.$nom_champ

    #== Affiche le nom du composant
    .comp_name.label11 configure -text $nom_comp
    #== Affiche le nom du champ
    .field.label11 configure -text $nom_champ
    # Long name
    catch {set Field_long_name $Data($clef_champ.long_name)}    
    
    # Single or bundle
    catch {set Field_type $Data($clef_champ.type)}
    set indice [lsearch {single bundle} $Field_type]
    if {$indice != -1} { .field.fr_type.cmb select $indice }
    # Bundle size
    catch {set Field_bundle_size $Data($clef_champ.bundle_size)}
    
    #== Standard name
    catch {set Field_std_name $Data($clef_champ.std_name)}
    #== bundle : component standard names
    for {set i 1} {$i < 11} {incr i} {
        global Field_comp_std_name_$i
        catch {set Field_comp_std_name_$i $Data($clef_champ.std_name_$i)}
    }    
    
    # intent : Input/Output
    catch {set Field_intent $Data($clef_champ.intent)}
    set indice [lsearch {input output {input/output}} $Field_intent]
    if {$indice != -1} { .field.cmb2c select $indice }
    
    # required_but_changeable
    catch {set Field_req_but_change $Data($clef_champ.req_but_change)}
    set indice [lsearch {yes no} $Field_req_but_change]
    if {$indice != -1} { .field.cmb2d select $indice }
    
    # Non masked value gathering/scattering
    catch {set Field_gather_scatter $Data($clef_champ.gather_scatter)}
    set indice [lsearch {yes no} $Field_gather_scatter]
    if {$indice != -1} { .field.cmb2e select $indice }
    
    # Units
    catch {set Field_units $Data($clef_champ.units)}

    # Datatype
    catch {set Field_datatype $Data($clef_champ.datatype)}
    set indice [lsearch {real double integer} $Field_datatype]
    if {$indice != -1} { .field.cmb6 select $indice }

    #=== Minimal exchange period
    if {$Field_intent == "output"} {
        set direction out
    } else {
        set direction in
    }
    catch {set Field_period_value_1 $Data($clef_champ.period_value_$direction)}

    catch {set Field_period_unit_1 $Data($clef_champ.period_unit_$direction)}
    set indice [lsearch {seconds minutes hours days months years} $Field_period_unit_1]
    if {$indice != -1} { .field.frexch1.cmb select $indice }

    #=== Minimal exchange period OUTPUT (quand le champ est en Input et Output)
    if {$Field_intent == "input/output"} {
        catch {set Field_period_value_2 $Data($clef_champ.period_value_out)}
    
        catch {set Field_period_unit_2 $Data($clef_champ.period_unit_out)}
        set indice [lsearch {seconds minutes hours days months years} $Field_period_unit_2]
        if {$indice != -1} { .field.frexch2.cmb select $indice }
    }

    # Met a jour les champs de saisie en fct du type single/bundle
    CF_field_type_change .field.fr_type.cmb $Field_type
    # Met a jour les champs de saisie en fct du sens Entree/Sortie 
    Field_intent_change .field.cmb2c $Field_intent
 }

/*  Valide les champs de saisie de la page initiale*/
ret  {validate_application_page} (type if_, type valid_, type required) {
    global Data
    global List_data
    # Variables de saisie
    global start_mode coupling_mode
    global Grid_names
    
    if {$if_valid_required == "true"} {
        # Si aucun nom n'a été saisi
        if {$Data(name) == ""} {
            dialog_notice_show "Please, give a symbolic name to this application."
            focus .initial.entry1
            # Indique une erreur
            return 0
        }
        # Si le champ "start mode" ou "coupling mode" n'a pas été rempli
        if {$start_mode == "" || $coupling_mode == ""} {
            dialog_notice_show "Please, fill this field : it is mandatory."
            if {$start_mode == ""} {
                focus .initial.cmb4
            } else {
                focus .initial.cmb5
            }
            # Indique une erreur
            return 0
        }
    }   
    
    # Mémorise les données saisies dans les listes déroulantes
    set Data(start_mode) $start_mode
    set Data(coupling_mode) $coupling_mode

    # Recopie la liste des composants saisis
    set Data(l_composants) {}
    foreach component_id $List_data(component.liste) {
        # Si ligne pas vide
        set component_name [string trim $List_data(component.$component_id)]
        if {$component_name != ""} {
            lappend Data(l_composants) $component_name
        }
    }
    
    # Supprime les champs de saisie de cette liste
    set form [scrollform_interior .initial.components]
    foreach component_id $List_data(component.liste) {
        destroy $form.n$component_id
    }

    # Initialise la liste des champs des nouveaux composants
    foreach component_name $Data(l_composants) {
        if {! [info exists Data(comp.$component_name.lchamps)]} {
            set Data(comp.$component_name.lchamps) {}
            # definit un seule ligne vierge de grille pour chaque composant
        set Grid_names($component_name.lgrid) "1"
        set Grid_names($component_name.grid.1.name) ""
        set Grid_names($component_name.grid.1.periodi) ""
        set Grid_names($component_name.grid.1.periodj) ""
        set Grid_names($component_name.grid.1.periodk) ""
        }
    }
    # Pas d'erreur
    return 1
}

/*  Initialise les champs affiches dans la page terminale*/
ret  {init_terminal_page} () {
    global Data
    
    set file_list {}
    set AD_file_name $Data(name)_ad.xml
    lappend file_list $AD_file_name
    
    # Pour tous les composants de l'appli
    foreach nom_comp $Data(l_composants) {
        # Nom du fichier PMIOD : dérivé du nom de l'appli et du composant
        set nom_fichier_PMIOD "$Data(name)_${nom_comp}_pmiod.xml"
        lappend file_list $nom_fichier_PMIOD
    }
    
    .terminal.label1 configure -text [join $file_list "\n"]
}

/*  Valide les champs de saisie de la page initiale d'un composant*/
ret  {validate_component_page} (type if_, type valid_, type required) {
    # Donnees
    global Data Num_composant Num_champ
    # Donnees associees aux champs de saisie
    global Comp_long_name
    global Comp_simul Comp_default
    global Comp_procs_min Comp_procs_max Comp_procs_incr
    # Donnees saisies dans une liste 
    global List_data
    global Grid_names
    
    # Nom du composant
    set nom_comp [lindex $Data(l_composants) $Num_composant]
    
    if {$if_valid_required == "true"} {
        # Si le champ "simulated" ou "default" n'a pas été rempli
        if {$Comp_simul == "" || $Comp_default == ""} {
            dialog_notice_show "Please, fill this field : it is mandatory."
            if {$Comp_simul == ""} {
                focus .component.cmb3
            } else {
                focus .component.cmb4
            }
            # Indique une erreur
            return 0
        }
        # Verifie les noms des champs de couplage
        foreach field_id $List_data(field.liste) {
            set field_name [string trim $List_data(field.$field_id)]
            # Si le nom est mal saisi
            if {! [string is wordchar $field_name]} {
                dialog_notice_show "Coupling field name must be one word using only alphanumeric or underscore characters."
                # Met le focus sur le champ de saisie en faute
                set form [scrollform_interior .component.fields]
                focus $form.n$field_id
                return 0
            }
        }
        # Verifie les noms des grilles et leurs attributs de periodicite
        foreach grid_id $Grid_names($nom_comp.lgrid) {
            set grid_name [string trim $Grid_names($nom_comp.grid.$grid_id.name)]
            # Si le nom est mal saisi
            if {! [string is wordchar $grid_name]} {
                dialog_notice_show "Grid name must be one word using only alphanumeric or underscore characters."
                # Met le focus sur le champ de saisie en faute
                set form [scrollform_interior .component.grids]
                focus $form.n$grid_id
                return 0
            }
            
            # Si il y a un nom de grille saisi
            if {$grid_name != ""} {

                # Verifie si un des champs "periodic" en i,j ou k n'est pas rempli
                set form [scrollform_interior .component.grids]
                if {$Grid_names($nom_comp.grid.$grid_id.periodi) == ""} {
                    set champ_fautif $form.pi$grid_id
                } else {
                    if {$Grid_names($nom_comp.grid.$grid_id.periodj) == ""} {
                        set champ_fautif $form.pj$grid_id
                    } else {
                        if {$Grid_names($nom_comp.grid.$grid_id.periodk) == ""} {
                            set champ_fautif $form.pk$grid_id
                        } else {
                            set champ_fautif ""
                        }
                    }
                }
                
                if { $champ_fautif != ""} {
                    dialog_notice_show "Please, fill in the grid periodicity."
                    # Met le focus sur le champ de saisie en faute
                    focus $champ_fautif
                    return 0
                }
            }
        }
    }   
    
    # Recopie en memoire les donnees saisies : les attributs du composant
    foreach name {long_name simul default procs_min procs_max procs_incr} {
        set Data(comp.$nom_comp.$name) [set Comp_$name]
    }

    # Recopie la liste des "fields" saisies
    set Data(comp.$nom_comp.lchamps) {}
    foreach field_id $List_data(field.liste) {
        # Si ligne pas vide
        set field_name [string trim $List_data(field.$field_id)]
        if {$field_name != ""} {
            lappend Data(comp.$nom_comp.lchamps) $field_name
        }
    }
    
    # Supprime les champs de saisie de cette liste
    set form [scrollform_interior .component.fields]
    foreach field_id $List_data(field.liste) {
        destroy $form.n$field_id
    }

    # Supprime la liste des grilles
    set form [scrollform_interior .component.grids]
    foreach grid_id $Grid_names($nom_comp.lgrid) {
        destroy $form.n$grid_id $form.pi$grid_id $form.pj$grid_id $form.pk$grid_id $form.delete$grid_id
    }
    
    # Initialise la liste des dependences des nouveaux champs
    foreach field_name $Data(comp.$nom_comp.lchamps) {
        if {! [info exists Data(comp.$nom_comp.field.$field_name.l_dependents)]} {
            set Data(comp.$nom_comp.field.$field_name.l_dependents) {}
        }
    }
    # Pas d'erreur
    return 1
}

/*  Valide les champs de saisie de la page d'un champ de couplage*/
ret  {validate_field_page} (type if_, type valid_, type required) {
    # Donnees
    global Data Num_composant Num_champ
    # Donnees associees aux champs de saisie
    global Field_long_name Field_std_name Field_intent 
    global Field_req_but_change Field_gather_scatter 
    global Field_type Field_bundle_size Field_units Field_datatype
    global Field_period_value_1 Field_period_unit_1
    global Field_period_value_2 Field_period_unit_2

    # Validation
    # ----------
    
    if {$if_valid_required == "true"} {
        set valid 1
        
        # Si le champ "CF standard name" n'a pas été rempli
        if {$Field_std_name == ""} {
            set field_name .field.stdname.cmb
            set valid 0
        } else {
            # Si le champ "intent" n'a pas été rempli
            if {$Field_intent == ""} {
                set field_name .field.cmb2c
                set valid 0
            } else {
                # Si le champ "numeric datatype" n'a pas été rempli
                if {$Field_datatype == ""} {
                    set field_name .field.cmb6
                    set valid 0
                } else {
                    # Si le champ "minimal period" n'a pas été rempli
                    if {$Field_period_unit_1 == ""} {
                        set field_name .field.frexch1.cmb
                        set valid 0
                    } else {
                    }
                }
            }
        }
        
        # Si pas d'erreur et le champ de couplage est "bundle"
        if {$valid && $Field_type == "bundle"} {
            # Pour tous les elements du "bundle"
            for {set i 1} {$i <= $Field_bundle_size} {incr i} {
                global Field_comp_std_name_$i
                # Si le champ "CF standard name" n'a pas été rempli
                if {[set Field_comp_std_name_$i] == ""} {
                    set field_name ".field.cmb_std$i"
                    set valid 0
                    break
                }
            }
        }
        
        # Si pas d'erreur et le champ de couplage est a la fois "input" et "output"
        if {$valid && $Field_intent == "input/output"} {
            # Si le deuxieme champ "minimal period" n'a pas été rempli
            if {$Field_period_value_2  == "" || $Field_period_unit_2 == ""} {
                if {$Field_period_value_2  == ""} {
                    set field_name .field.frexch2.en
                } else {
                    set field_name .field.frexch2.cmb
                }
                set valid 0
            }
        }
        
        # Si un des champs obligatoires n'a pas été rempli
        if {! $valid} {
            dialog_notice_show "Please, fill this field : it is mandatory."
            focus $field_name
            # Indique une erreur
            return 0
        }
    }   
    
    # Lecture des champs saisis a l'ecran
    # -----------------------------------
    
    # Nom du composant
    set nom_comp [lindex $Data(l_composants) $Num_composant]
    # Nom du champ
    set nom_champ [lindex $Data(comp.$nom_comp.lchamps) $Num_champ]
    # Clef d'acces aux attributs du champ
    set clef_champ comp.$nom_comp.field.$nom_champ

    # Recopie en memoire les champs saisis
    foreach name { long_name std_name intent gather_scatter type units datatype } {
        set Data($clef_champ.$name) [set Field_$name]
    }
    
    # required_but_changeable
    if {$Field_intent != "output"} {
        set Data($clef_champ.req_but_change) $Field_req_but_change
    }
    
    #== bundle : Recopie en memoire les "standard names" des composantes
    if {$Field_type == "bundle"} {
        # Bundle size
        set Data($clef_champ.bundle_size) $Field_bundle_size
        
        for {set i 1} {$i <= $Field_bundle_size} {incr i} {
            global Field_comp_std_name_$i
            catch {set Data($clef_champ.std_name_$i) [set Field_comp_std_name_$i]}
        }
    }

    #=== Minimal exchange period
    if {$Field_intent == "output"} {
        set direction out
    } else {
        set direction in
    }
    set Data($clef_champ.period_value_$direction) $Field_period_value_1
    set Data($clef_champ.period_unit_$direction)  $Field_period_unit_1
    
    #=== Minimal exchange period OUTPUT (quand le champ est en Input et Output)
    if {$Field_intent == "input/output"} {
        set Data($clef_champ.period_value_out) $Field_period_value_2
        set Data($clef_champ.period_unit_out)  $Field_period_unit_2
    }
    # Pas d'erreur
    return 1
}

/*  Field_intent_change*/
/* */
/*  Procedure appelee quand l'utilisateur change le sens I/O d'un champ de couplage*/
/* */
ret  {Field_intent_change} (type win , type value) {
    global Row_in_field_page
    global Field_intent

    # Si le champ de couplage est en Entree
    if {$Field_intent != "output"} {
        # Affiche une ligne supplementaire de saisie pour "required_but_changeable"
        grid .field.label2d .field.cmb2d -row $Row_in_field_page(required_but_changeable) -sticky w
    } else {
        # Cache cette ligne supplementaire
        grid forget .field.label2d .field.cmb2d 
    }

    # Si le champ de couplage est en Entree et en Sortie
    if {$Field_intent == "input/output"} {
        # Affiche une ligne supplementaire de saisie pour "Minimal period (Out)"
        grid .field.label9 .field.frexch2 -row $Row_in_field_page(min_period) -sticky w
        # Renomme la !ere ligne de saisie
        .field.label8 configure -text "Minimal period (In) :"
    } else {
        # Cache une ligne supplementaire de saisie
        grid forget .field.label9 .field.frexch2
        # Renomme la !ere ligne de saisie
        .field.label8 configure -text "Minimal exchange period : "
    }
}

ret  {edited_list_widget_delete} (type form , type tag , type num_, type elem) {
# Supprime une ligne du tableau contenu dans la fenetre $form
# avant que la ligne ait été supprimée en mémoire de la variable $List_data(tag)
#
    global List_data
    
    array set info_liste [grid info $form.n$num_elem]
    set num_ligne $info_liste(-row)
    
    destroy $form.n$num_elem

    set elems_suivants [lrange $List_data($tag.liste) [expr $num_ligne + 1] end]
    # Pour toutes les lignes suivantes
    set i $num_ligne
    foreach elem_suivant $elems_suivants {
        # Change le no de lignes des widgets de cette ligne (decale la ligne vers le haut)
        grid configure $form.n$elem_suivant -row $i
        incr i
    }
    # Renumerote la ligne contenant le bouton <Add>
    grid configure $form.add -row $i
}

ret  {edited_list_widget_insert} (type form , type tag , type num_, type elem , type nb_, type elems) {
    # Ajoute une ligne au formulaire de saisie d'une liste d'elements (indiquee par $tag)
    global List_data
    global OASIS_GUI_DIR
    
    # Ajoute une ligne
    set no_ligne $nb_elems
    
    grid forget $form.add
    grid [entry $form.n$num_elem -textvariable List_data($tag.$num_elem) -width 20 -relief groove -background white -borderwidth 1] -row $no_ligne -column 0
    grid $form.add -sticky w
    
    # Scroll canvas to the bottom
    set canvas_name [string range $form 0 end-5]
    $canvas_name yview scroll 1 pages
    
    bind $form.n$num_elem <KeyPress-Return> "edited_list_widget_next $form $tag $num_elem"
    bind $form.n$num_elem <KeyPress-Tab> "edited_list_widget_next $form $tag $num_elem"
    
    # Crée un menu popup pour supprimer plus tard cette ligne, si besoin
    menu $form.n$num_elem.popup
    $form.n$num_elem.popup add command -label "delete" -command "edited_list_widget_delete $form $tag $num_elem; edited_list_delete $tag $num_elem"
    # Le menu sera appelé sur "clic droit"
    bind $form.n$num_elem <ButtonPress-3> "tk_popup $form.n$num_elem.popup %X %Y"

}

ret  {edited_list_widget_next} (type form , type tag , type num_, type elem) {
    global List_data

    # Determine le no de ligne du bouton
    array set info_liste [grid info $form.n$num_elem]
    set num_ligne $info_liste(-row)
    # Si le bouton est en derniere ligne de la table
    if { [lindex [grid size $form] 1] == [expr $num_ligne + 2] } {
        # Ajoute une ligne à la table
        set nouvel_elem [edited_list_insert $form $tag]
        # Met le curseur dans cette ligne ajoutée
        focus $form.n$nouvel_elem
    } else {
        set elem_suivant [lindex $List_data($tag.liste) [expr $num_ligne + 1]]
        focus $form.n$elem_suivant
    }
}

ret  {edited_list_add} (type form , type tag) {
    # Ajoute une ligne en fin de table
    set nouvel_elem [edited_list_insert $form $tag]
    # Met le curseur dans cette ligne ajoutée
    focus $form.n$nouvel_elem
}

ret  {edited_list_delete} (type tag , type num_, type elem) {
# Supprime un element d'une liste
    global List_data
    
    # Supprime de la liste
    set List_data($tag.liste) [lsearch -not -all -inline $List_data($tag.liste) $num_elem]
    # Oublie ses parametres
    array unset List_data $tag.$num_elem
}

ret  {edited_list_insert} (type form , type tag) {
# Ajoute une nouvel element a une liste indiquee par $tag
# Retourne le numéro de l'élément ajouté
    global List_data
    
    set nb_elems [llength $List_data($tag.liste)]
    # Si déja des elements sont listés
    if { $nb_elems != 0 } {
        # Détermine le no du dernier element
        set dernier_num_elem [lindex $List_data($tag.liste) end]
        # Crée un nouvel identifiant (nouveau numero d'element)
        set nouvel_elem [expr $dernier_num_elem + 1]
    } else {
        set nouvel_elem 1
    }
    # Ajoute a la liste
    lappend List_data($tag.liste) $nouvel_elem
    set List_data($tag.$nouvel_elem) ""

    # Ajoute une ligne au formulaire
    edited_list_widget_insert $form $tag $nouvel_elem $nb_elems
    
    return $nouvel_elem
}


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  {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}
    upvar /* 0 $cb_textvar textvar*/
     textvar =  $cb_opt
    combobox $window -editable $edita -textvariable  $cb_textvar -width $cb_width -background white
    /*  eval $window list insert end $loclist*/
    foreach elem $loclist {
        $window list insert end $elem
    }
    /*  Sélectionne la valeur initiale dans la liste*/
     indice =  [lsearch $loclist $cb_opt]
    if {$indice != -1} { $window select $indice }
    /*  Complete la configuratiom*/
    $window configure -command $cmdret  
}

proc (type scrollform_, type create) {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.*/
/*  ----------------------------------------------------------------------*/
ret  scrollform_resize (type 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.*/
/*  ----------------------------------------------------------------------*/
ret  scrollform_interior (type 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 "
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
}

/*  CF_search_list*/
/* */
/*  Cherche dans la liste des noms standards CF*/
/*  un nom saisi au clavier dans le champ de saisie "Field_std_name"*/
/* */
ret  {CF_search_list} () {
    # Liste des noms std
    global CF_standard_name_list
    # Donnee associee au champ de saisie
    global Field_std_name
    
    # Sélectionne la valeur initiale dans la liste
    set indice [lsearch -glob $CF_standard_name_list "*${Field_std_name}*"]
    if {$indice != -1} { .field.stdname.cmb select $indice }
}

/*  CF_field_type_change*/
/* */
/*  Procedure appelee chaque fois qu'on change de type de champ de couplage :*/
/*    qui est de type Single ou Bundle*/
/* */
/*  Single : il n'y a qu'un seul nom CF*/
/*  Bundle : il y en a un nombre indefini*/
/* */
ret  {CF_field_type_change} (type win , type value) {
    global Row_in_field_page
    global Field_type Field_bundle_size
    
    switch $value {
        single {
            # N'affiche pas le champ de saisie de la taille du "bundle"
            pack forget .field.fr_type.label .field.fr_type.entry
            # N'affiche pas les champs des composantes de "bundle"
            for {set i 1} {$i < 11} {incr i} {
                grid forget .field.label_std$i .field.cmb_std$i
            }
        }
        bundle {
            # Affiche le champ de saisie de la taille du "bundle"
            pack .field.fr_type.label .field.fr_type.entry -side left -padx 5

            # Affiche les champs de saisie des composantes du "bundle"
            set r $Row_in_field_page(other_std_names)
            for {set i 1} {$i <= $Field_bundle_size} {incr i} {
                grid .field.label_std$i .field.cmb_std$i -row $r -sticky w
                incr r
            }
            # N'affiche pas les champs des autres composantes
            for {} {$i < 3} {incr i} {
                grid forget .field.label_std$i .field.cmb_std$i
            }
        }
    }
}

/*  CF_bundle_size_change*/
/* */
/*  Procedure appelee quand l'operateur change le nombre de composantes d'un "bundle"*/
/* */
ret  {CF_bundle_size_change} (type name , type el , type op) {
    global Row_in_field_page
    global Field_bundle_size

    # Affiche les champs de saisie des composantes du "bundle"
    set r $Row_in_field_page(other_std_names)
    for {set i 1} {$i <= $Field_bundle_size} {incr i} {
        grid .field.label_std$i .field.cmb_std$i -row $r -sticky w
        incr r
    }
    # N'affiche pas les champs des autres composantes
    for {} {$i < 11} {incr i} {
        grid forget .field.label_std$i .field.cmb_std$i
    }
}

/*  Récupere par liaison HTTP sur le site du PCMDI (LLNL, Californie)*/
/*  le fichier XML contenant la table des noms de champs standard CF*/
/*  PAS UTILISEE*/
/*  */
/*  - filename : nom du fichier a créer*/
/* */
ret  CF_update_standard_name_table (type filename) {
    package require http
    set f [open $filename w]
    set si_erreur [catch { http::geturl
        set token [http://cf-pcmdi.llnl.gov/documents/cf-standard-names/standard-name-table/12/cf-standard-name-table.xml -channel $f]
         } erreur]

puts "http::ncode http::code : [http::ncode $token] [http::code $token]"
    if {! $si_erreur} {
        http::cleanup $token
    }
    close $f
}


ret  {help_attach_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  {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 == ""} {
         x =  [expr [winfo rootx $w]]
         y =  [expr [winfo rooty $w] + [winfo height $w] - 10]
    }
    /*   after 500*/
     u =  .ballon_object
    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

    /*  Place la bulle d'aide au dessus de la zone de saisie*/
    incr x [winfo width $w]
    incr x 5
    wm geometry $u +$x+$y

    wm deiconify $u
    raise $u
}

ret  {help_object_hide} () {
    catch {wm withdraw .ballon_object}
}

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
}


/* **** dialog_notice_show*/
/* */
/*      Purpose:*/
/*      --------*/
/*      Show a dialog box with a message and chosen icon*/
/* */
/*      Interface:*/
/*      ----------*/
/*          dialog_notice_show $mesg info*/
/* */
/*          Inputs :*/
/*          --------*/
/*            mesg : variable containing the message to be written*/
/*            info : the chosen icon (info, error)*/
/* */
/*      References:*/
/*      -----------*/
/*      Effective Tcl/Tk Programming, M. Harrison and M. McLennan,*/
/*      Addison-Wesley professional computing series, 1998*/
/* *----------------------------------------------------------------*/
/* */
ret  {dialog_notice_show} (type mesg , optional icon =info) {
    set top [dialog_create Notice]
    set x [expr [winfo rootx .]+200]
    set y [expr [winfo rooty .]+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
}

/*  on_terminate : Procedure appelee a la fin de la saisie*/
/* */
/*  Elle ecrit toutes les donnees saisies dans des fichiers XML :*/
/*    - 1 fichier AD*/
/*    - des fichiers PMIOD, un par composant saisi*/
/* */
ret  {on_terminate} () {
    global Data
    
    # Nom du fichier AD : dérivé du nom de l'appli
    set nom_fichier_AD "$Data(name)_ad.xml"
    # Genere ce fichier
    XML_genere_Appli_Desc $nom_fichier_AD
    
    # Pour tous les composants de l'appli
    foreach nom_comp $Data(l_composants) {
        # Nom du fichier PMIOD : dérivé du nom de l'appli et du composant
        set nom_fichier_PMIOD "$Data(name)_${nom_comp}_pmiod.xml"
        # Genere ce fichier
        XML_genere_PMIOD $nom_comp $nom_fichier_PMIOD
    }
}

/*  Genere le fichier AD de l'application*/
/*  a partir des donnees saisies*/
/* */
ret  {XML_genere_Appli_Desc} (type nom_, type fichier_, type AD) {
    global Data
    
    # Crée le document XML
    set doc [dom::DOMImplementation create]

    # Crée l'élément racine <application>
    set appli_element [::dom::document createElement $doc application]
    # Ses attributs
    dom::element setAttribute $appli_element xmlns "http://www.cerfacs.fr/PRISM/XML/1.1"
    dom::element setAttribute $appli_element "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance"
    dom::element setAttribute $appli_element "xsi:schemaLocation" "http://www.cerfacs.fr/PRISM/XML/1.1"
    dom::element setAttribute $appli_element local_name $Data(name)
    if {$Data(long_name) != ""} {
        dom::element setAttribute $appli_element  long_name $Data(long_name)
    }
    dom::element setAttribute $appli_element oasis4_version OASIS4_0_2
    dom::element setAttribute $appli_element start_mode $Data(start_mode)
    dom::element setAttribute $appli_element coupling_mode $Data(coupling_mode)
        
    # Crée l'élément "nbr_procs"
    set nbr_procs_elt [::dom::document createElement $appli_element nbr_procs]
    # Crée l'élément "min_value"
    set node [::dom::document createElement $nbr_procs_elt min_value]
    ::dom::document createTextNode $node $Data(nb_procs_min)
    # Crée l'élément "max_value"
    set node [::dom::document createElement $nbr_procs_elt max_value]
    ::dom::document createTextNode $node $Data(nb_procs_max)
    # Crée l'élément "increment"
    set node [::dom::document createElement $nbr_procs_elt increment]
    ::dom::document createTextNode $node $Data(nb_procs_incr)

    # Pour tous les composants saisis
    foreach nom_comp $Data(l_composants) {
        # Crée l'élément "component"
        set component_elt [::dom::document createElement $appli_element component]
        # Ses attributs
        dom::element setAttribute $component_elt local_name $nom_comp
        if {$Data(comp.$nom_comp.long_name) != ""} {
            dom::element setAttribute $component_elt long_name  $Data(comp.$nom_comp.long_name)
        }
        dom::element setAttribute $component_elt simulated  $Data(comp.$nom_comp.simul)
        set is_default $Data(comp.$nom_comp.default)
        if {$is_default == "yes"} { set is_default "true"} else { set is_default "false"}
        dom::element setAttribute $component_elt default $is_default

        # Crée l'élément "nbr_procs"
        set nbr_procs_elt [::dom::document createElement $component_elt nbr_procs]
        # Crée l'élément "min_value"
        set node [::dom::document createElement $nbr_procs_elt min_value]
        ::dom::document createTextNode $node $Data(comp.$nom_comp.procs_min)
        # Crée l'élément "max_value"
        set node [::dom::document createElement $nbr_procs_elt max_value]
        ::dom::document createTextNode $node $Data(comp.$nom_comp.procs_max)
        # Crée l'élément "increment"
        set node [::dom::document createElement $nbr_procs_elt increment]
        ::dom::document createTextNode $node $Data(comp.$nom_comp.procs_incr)
    }

    # Traduit en texte à syntaxe XML
    set texte_xml [::dom::DOMImplementation serialize $doc -indent 1]
    # Libère la mémoirein
    ::dom::DOMImplementation destroy $doc
    # Ecrit le texte dans le fichier
    set fichier_XML [open $nom_fichier_AD w]
    puts $fichier_XML $texte_xml
    close $fichier_XML
}

/*  Génère un fichier PMIOD pour un composant saisi*/
/* */
/*    - nom_comp : nom symbolique du composant*/
/*    - nom_fichier_PMIOD : nom du fichier a créer*/
/* */
ret  {XML_genere_PMIOD} (type nom_, type comp , type nom_, type fichier_, type PMIOD) {
    global Data
    global Grid_names
    
    # Crée le document XML
    set doc [dom::DOMImplementation create]

    # Crée l'élément racine <prismcomponent>
    set component_elt [::dom::document createElement $doc prismcomponent]
    # Ses attributs
    dom::element setAttribute $component_elt xmlns "http://www.cerfacs.fr/PRISM/XML/1.1"
    dom::element setAttribute $component_elt "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance"
    dom::element setAttribute $component_elt "xsi:schemaLocation" "http://www.cerfacs.fr/PRISM/XML/1.1"
    dom::element setAttribute $component_elt local_name $nom_comp
    if {$Data(comp.$nom_comp.long_name) != ""} {
        dom::element setAttribute $component_elt  long_name $Data(comp.$nom_comp.long_name)
    }
    dom::element setAttribute $component_elt oasis4_version OASIS4_0_2
        dom::element setAttribute $component_elt simulated  $Data(comp.$nom_comp.simul)
    # Ecriture des caracteristiques des grilles
    foreach id_grid $Grid_names($nom_comp.lgrid) {
        # Nom de la grille
        set grid_name $Grid_names($nom_comp.grid.$id_grid.name)
        # Si il y a un nom de grille saisi
        if {$grid_name != ""} {
            set grid_elt [::dom::document createElement $component_elt grid]
            dom::element setAttribute $grid_elt local_name $grid_name
            # Indexing dimensions
            set periodi_elt [::dom::document createElement $grid_elt indexing_dimension]
            dom::element setAttribute $periodi_elt index 1
            dom::element setAttribute $periodi_elt periodic $Grid_names($nom_comp.grid.$id_grid.periodi)
            set periodj_elt [::dom::document createElement $grid_elt indexing_dimension]
            dom::element setAttribute $periodj_elt index 2
            dom::element setAttribute $periodj_elt periodic $Grid_names($nom_comp.grid.$id_grid.periodj)
            set periodk_elt [::dom::document createElement $grid_elt indexing_dimension]
            dom::element setAttribute $periodk_elt index 3
            dom::element setAttribute $periodk_elt periodic $Grid_names($nom_comp.grid.$id_grid.periodk)
        }
    }    
    # Pour tous les champs de couplage
    foreach nom_champ $Data(comp.$nom_comp.lchamps) {
        # Clef d'acces aux attributs du champ
        set clef_champ comp.$nom_comp.field.$nom_champ
    
        # Crée l'élément <transient>
        set transient_elt [::dom::document createElement $component_elt transient]
        # Ses attributs
        dom::element setAttribute $transient_elt local_name $nom_champ
        if {$Data($clef_champ.long_name) != ""} {
            dom::element setAttribute $transient_elt long_name  $Data($clef_champ.long_name)
        }
        
        # Crée l'élément <transient_standard_name>
        set node [::dom::document createElement $transient_elt transient_standard_name]
        ::dom::document createTextNode $node $Data($clef_champ.std_name)
    
        # Si le champ de couplage est "bundle"
        if {$Data($clef_champ.type) == "bundle"} {
            # Bundle size
            set nb_elem $Data($clef_champ.bundle_size)
            # Pour tous les elements du "bundle"
            for {set i 1} {$i <= $nb_elem} {incr i} {
                # ajoute un élément <transient_standard_name>
                set node [::dom::document createElement $transient_elt transient_standard_name]
                ::dom::document createTextNode $node $Data($clef_champ.std_name_$i)
            }
        }
        
        # Crée un sous-élément <physics>
        set physics_elt [::dom::document createElement $transient_elt physics]
        # Son attribut "transient_type"
        dom::element setAttribute $physics_elt transient_type $Data($clef_champ.type)
        
        # Si les unités physiques sont renseignées
        if {$Data($clef_champ.units) != "" } {
            # Crée l'élément <physical_units>
            set node [::dom::document createElement $physics_elt physical_units]
            ::dom::document createTextNode $node $Data($clef_champ.units)
        }
        # Si le champ est un "bundle"
        if {$Data($clef_champ.type) == "bundle"} {
            # Crée l'élément <nbr_bundles>
            set node [::dom::document createElement $physics_elt nbr_bundles]
            ::dom::document createTextNode $node $Data($clef_champ.bundle_size)
        }

        # Crée un sous-élément <numerics>
        set numerics_elt [::dom::document createElement $transient_elt numerics]
        # Son attribut "datatype"
        dom::element setAttribute $numerics_elt datatype xs:$Data($clef_champ.datatype)

        # Crée un sous-élément <intent>
        set intent_elt [::dom::document createElement $transient_elt intent]

        # Si le champ est en "input" ou "input and output"
        if {$Data($clef_champ.intent) != "output"} {
            # Crée un sous-élément <input>
            set input_elt [::dom::document createElement $intent_elt input]
            # Son attribut "required_but_changeable"
            if {$Data($clef_champ.req_but_change) == "yes"} {set req_but_change "true"} else {set req_but_change "false"}
            dom::element setAttribute $input_elt required_but_changeable $req_but_change
            # Crée un sous-élément <minimal_period>
            XML_genere_element_min_period $input_elt $Data($clef_champ.period_unit_in) $Data($clef_champ.period_value_in)

            # Si le champ a l'option "non masked value gathering"
            if { $Data($clef_champ.gather_scatter) == "yes" } {
                # Crée un arborescence de sous-éléments
                # <target_transformation>
                #    <target_local_transformation>
                #       <gathering\>
                set node [::dom::document createElement $input_elt target_transformation]
                set node [::dom::document createElement $node      target_local_transformation]
                set node [::dom::document createElement $node      gathering]
            }
        }

        # Si le champ est en "output" ou "input and output"
        if {$Data($clef_champ.intent) != "input"} {
            # Crée un sous-élément <output>
            set output_elt [::dom::document createElement $intent_elt output]
            # Son attribut "transi_out_name"
            dom::element setAttribute $output_elt transi_out_name ${nom_champ}_out1
            # Crée un sous-élément <minimal_period>
            XML_genere_element_min_period $output_elt $Data($clef_champ.period_unit_out) $Data($clef_champ.period_value_out)

            # Si le champ a l'option "non masked value scattering"
            if { $Data($clef_champ.gather_scatter) == "yes" } {
                # Crée un arborescence de sous-éléments
                # <source_transformation>
                #    <source_local_transformation>
                #       <scattering>
                set node [::dom::document createElement $output_elt source_transformation]
                set node [::dom::document createElement $node      source_local_transformation]
                set node [::dom::document createElement $node      scattering]
            }
        }
    }
    
    # Traduit en texte à syntaxe XML
    set texte_xml [::dom::DOMImplementation serialize $doc -indent 1]
    # Libère la mémoire
    ::dom::DOMImplementation destroy $doc
    # Ecrit le texte dans le fichier
    set fichier_XML [open $nom_fichier_PMIOD w]
    puts $fichier_XML $texte_xml
    close $fichier_XML
}

/*  Génère un sous-élément XML de type <minimal_period>*/
/* */
/*  - element_XML    :   element parent*/
/*  - unit_temps     :   unité de temps de la min period*/
/*  - valeur         :   nombre d'unités de temps de la min period*/
/* */
ret  {XML_genere_element_min_period} (type element_, type XML , type unit_, type temps , type valeur) {

    # Crée un sous-élément <minimal_period>
    set min_period_elt [::dom::document createElement $element_XML minimal_period]
    # Traduit l'unité de temps en une abbréviation
    switch $unit_temps  {
        seconds { set unit_temps "secs" }
        minutes { set unit_temps "mins" }
        default {}
    }
    # Crée un sous-élément correspondant à l'unité de temps
    set sous_element [::dom::document createElement $min_period_elt nbr_$unit_temps]
    ::dom::document createTextNode $sous_element $valeur
}

ret  {read_CF_standard_name_table} () {
# Lit la liste des "CF Standard names" dans un fichier XML
# Ce fichier s'appelle CF_standard_name_table.xml dans le repertoire courant
#
# Met les infos dans une variable globale de type liste : CF_standard_name_list
#
    global CF_standard_name_list 
    set CF_standard_name_list {}
    # Liste des "unites canoniques"
    set canonical_units_list {}
    # Liste des descriptions
    set description_list {}
    
    # Lit le document à manipuler
    set nom_fichier cf-standard-name-table.xml
    if { [file exists $nom_fichier] } {
        set f_handle [open $nom_fichier]
    
        set text [read $f_handle]
        if { [string trim $text] != "" } {
            set code_erreur [catch {set doc [dom::parse $text]} msg_erreur]
            if {$code_erreur} {
                dialog_notice_show "Error parsing file \"$nom_fichier\" :\n $msg_erreur"
                return 1
            }
        } else {
            # Fichier vide
            dialog_notice_show "Error parsing file \"$nom_fichier\" :\n file is empty"
            return 1
        }
        
        # Récupère le premier élément du document
        # C'est l'élément principal (qui est de type <standard_name_table>)
        set element1 [dom::document configure $doc -documentElement]
        if { [dom::node configure $element1 -nodeName] != "standard_name_table" } {
            # Fichier vide
            dialog_notice_show "Content of file \"$nom_fichier\" is unexpected"
            return 1
        }
        
        # 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 {
                    
                    entry {
                        set entry_OK 0
                        # Lit les attributs de l'élément <entry>
                        set att [dom::node configure $element -attributes]
                        # Pour tous les attributs (normalement, il n'y en a qu'un : id)
                        foreach {name value} [array get $att] {
                            if {$name == "id"} {
                                lappend CF_standard_name_list $value
                                set entry_OK 1
                            }
                        }
                        
                        if {$entry_OK} {
                            # Lit les sous-elements de l'element <entry>
                            set paire [lit_sous_element_entry $element]
                            lappend canonical_units_list [lindex $paire 0]
                            lappend description_list     [lindex $paire 1]
                        }
                    }
        
                    # Info inutilisée pour l'instant
                    version_number {
                        set version_number [lit_XML_texte $element]
                    }
                    # Info inutilisée pour l'instant
                    last_modified {
                        set last_modified [lit_XML_texte $element]
                    }
                    # Info inutilisée pour l'instant
                    institution {
                        set institution [lit_XML_texte $element]
                    }
                    # Info inutilisée pour l'instant
                    contact {
                        set contact [lit_XML_texte $element]
                    }
                }
            }
        }
    } else {
        # Fichier XML manquant
        set CF_standard_name_list { {} "Missing file \"$nom_fichier\"..."}
    }
}

ret  {lit_sous_element_entry} (type element) {
# Lit certains sous-éléments d'un élément <entry>
# à savoir <canonical_units> et <description>
# Retourne une liste composée de ces deux infos

    # Lit les sous-éléments de l'élément <entry>
    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 {
                
                canonical_units {
                    set canonical_units [lit_XML_texte $element]
                }
                description {
                    set description [lit_XML_texte $element]
                }
            }
        }
    }
    
    return [list $canonical_units $description]
}

ret  {lit_XML_texte} (type element_, type XML) {
# Lit le texte de\'un élément XML atomique
# c.a.d qui ne contient pas de sous-éléments mais du texte
    
    # Lit les sous-éléments de l'élément XML
    # jusqu'a un sous-élément de type Texte
    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]
            return $value
        }
    }
}

/* */

/* BEGIN main*/

/*  Variables globales*/

/*  Numero de la page d'ecran en cours de saisie*/
 Num = _page 1
/*  Type de page d'ecran en cours :*/
/*    0: page initiale (attributs de l'appli)*/
/*    1: page d'un composant*/
/*    2: page d'un champ*/
/*    3: page terminale (de confirmation)*/
 Type = _page 0

/*  Numero de composant en cours de saisie*/
 Num = _composant 0
/*  Numero de champ de couplage en cours de saisie*/
 Num = _champ 0

/*  Liste des noms des composants de l'appli*/
 Data = (l_composants) {}
/*  Nombre de processus de l'appli*/
 Data = (nb_ret s_min) 1
set Data(nb_procs_max) 1
set Data(nb_procs_incr) 1
# autres attributs
set Data(start_mode) ""
set Data(coupling_mode) ""

# Liste des noms standard de champs
set CF_standard_name_list ()

# Initialisation
# --------------

# Initialise le module combobox (liste deroulante)
combobox_init

# 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]
unset script_file

# packages : they are in subdirectory 'packages/lib'
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"}
}
 usage =  ": wizard.tcl \[options] \noptions:"
array  params =  [::cmdline::getoptions argv $options $usage]
/*  Vérifie si l'option -silent a été mise sur la ligne de commande*/
 no = _help_balloon $params(silent)

/*  Load "XML support" packages : they are in subdirectory 'packages'*/
global auto_path
lappend auto_path [file join $OASIS_GUI_DIR packages/lib]
package require xml
package require xml::libxml2
package require dom

/*  Lit dans un fichier XML la liste des noms standard de champs*/
read_CF_standard_name_table
/* puts "CF_standard_name_list : "*/
/* foreach n $CF_standard_name_list {*/
/*     puts $n*/
/* }*/


/*  Main window*/
/*  -----------*/

wm title . "OASIS 4 application definition wizard"
wm iconname . "OASIS 4 application definition wizard"
    
wm geometry . "+200+20"

label .intro -justify left -text "This dialog based wizard helps you define your model application parameters
so that XML configuration files are automatically generated at the end from your input.

XML files include :
   - Application Description (AD) file
   - Potential Model Input/Output Description (PMIOD) files"
   
pack .intro -padx 30 -pady 5 -side top

/*  Cadre des boutons <NEXT> et <PREVIOUS>*/
/*  --------------------------------------*/

/*  Separateur*/
frame .sep1 -width 200 -height 2 -borderwidth 1 -relief sunken
pack .sep1 -side top -fill x -pady 2m -expand 1

/*  Cadre*/
frame .buttons
pack .buttons -side bottom -fill x -pady 2m

button .buttons.previous  -text Previous -command "on_previous_page"
button .buttons.next  -text Next -command "on_next_page"
button .buttons.ok  -text OK -command "on_terminate; destroy ."

/*  pack .buttons.previous -side left -expand 1 -padx 10*/
/*  pack .buttons.next -side right -expand 1 -padx 10*/
/*  pack .buttons.ok -side right -expand 1 -padx 10*/

/*  Ecran initial*/
create_application_page

/*  En tete de certains ecrans: le nom du composant*/
/*  -----------------------------------------------*/

frame .comp_name
label .comp_name.label1 -text "Component : "
label .comp_name.label11 -relief sunken
pack .comp_name.label1 .comp_name.label11 -side left -padx 5 -pady 5

/*  Ecran initial d'un composant*/
create_component_page

/*  Ecran d'un champ de couplage*/
create_field_page

/*  Ecran terminal*/
create_terminal_page

/* -------------------------------------*/
/* ** bulle aide objet*/
/* -------------------------------------*/
 u =  .ballon_object
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

/*  Display first page*/
display_page

/*  END main*/
/* */