Posted to tcl by emiliano at Mon Jun 15 14:21:09 GMT 2009view pretty

package require Tcl 8.5
package require Tk
namespace path {tcl::mathop tcl::mathfunc}

array set p {
    dx    1.0
    dt    0.5
    k     1.0
    rho   1.0
    C     1.0
    Q     1.0
    nodos 21
    q     9.0
}
set bc newmann
set conv Si

proc reset {} {
    global p tvec norma conv

    set tvec [lrepeat $p(nodos) 10.0]
    lset tvec end 20.0

    # no cambiar esto
    after cancel [after info]
    enablesteps
    redraw
}

proc step {} {
    global p bc tvec norma conv

    set new [list]
    for {set i 1} {$i <= [llength $tvec] - 2} {incr i} {
        lassign [lrange $tvec $i-1 $i+1 ] t-1 t t+1
        lappend new [expr { 
            $t + 
            $p(dt)/($p(rho)*$p(C)) * 
                ( ($p(k)/$p(dx)**2) * (${t-1}-2*$t+${t+1}) + $p(Q))
        }]
    }

    set new [linsert $new 0 [lindex $tvec 0]]
    if {[string index $bc 0] eq "d"} {
        # dirichlet
        lappend new [lindex $tvec end]
    } else {
        # neumann
        lappend new [expr {[lindex $tvec end-1] - ($p(q) * $p(dx) / $p(k))}]
    }

    set max 0
    foreach act $tvec fut $new {
        set dif [abs [- $fut $act]]
        set max [expr {$dif > $max ? $dif : $max}]
    }
    set norma [format %.3g $max]
    set tvec  $new
}

proc converge? {args} {
    global p conv

    if {1 - 2 * ($p(dt) * $p(k)) / ($p(dx)**2 * $p(rho) * $p(C)) >= 0} {
        set conv "Si"
        .ac.conv configure -background white -foreground black
    } else {
        set conv "No"
        .ac.conv configure -background red2 -foreground yellow
    }
}

proc redraw {} {
    global tvec p

    set min [min {*}$tvec]; set max [max {*}$tvec]
    set w [winfo width .c]; set h [winfo height .c]

    lassign {20 40 70 20 5} oar oab oiz ode gap
    set ry  [- $max $min]
    set cry [- $h $oar $oab]

    for {set i 0} {$i <= 10} {incr i} {
        set y  [expr {$min + $ry / 10.0 * $i}]
        set cy [expr {($h - $oab) - $cry / $ry * ($y - $min)}]
        .c itemconfigure label&&$i -text [format %.2f $y]
        .c coords label&&$i [- $oiz $gap $gap] $cy
        .c coords grid&&$i [- $oiz $gap] $cy [- $w $ode -$gap] $cy
    }

    set mul1 [expr {double($w - $ode - $oiz) / ($p(nodos) - 1)}]
    set mul2 [expr {($h - $oab - $oar) / ($max - $min)}]
    set idx 0
    foreach node $tvec {
        set x [expr {$oiz + $mul1 * $idx}]
        set y [expr {($h - $oab) - $mul2 * ($node - $min)}]
        lappend coords $x $y
        incr idx
    }

    .c coords plot $coords
    .c coords rect \
        [- $oiz $gap] [- $oar $gap] [- $w $ode -$gap] [- $h $oab -$gap]
}

proc dostep { steps } {
    if {$steps == 0} {
        enablesteps
        return
    }
    step
    redraw
    after idle [list after 1 dostep [incr steps -1]]
}

proc enablesteps {} {
    .st.go configure -state normal
}

proc disablesteps {} {
    .st.go configure -state disabled
}

proc showvalue {x y} {
    global tvec
    set idx [.c index plot @$x,$y]
    lassign [lrange [.c coords plot] $idx $idx+1] cx cy
    .c coords idot [- $cx 3] [- $cy 3] [+ $cx 3] [+ $cy 3]
    .c coords itext $cx [- $cy 6]
    .c itemconfigure itext -text [format %.3f [lindex $tvec [/ $idx 2]]]
}

proc edit_reset {} {
    toplevel .edit
    pack [set t [text .edit.t]]
    $t insert end [info body reset]
    focus $t
    bind .edit <Double-Escape> [list update_reset $t]
    wm protocol .edit WM_DELETE_WINDOW [list update_reset $t]
    wm transient .edit .
    wm group .edit .
    grab set .edit
}

proc update_reset { t } {
    proc reset {} [$t get 1.0 end]
    grab release .edit
    destroy .edit
    reset
}

proc ttk::optionMenu {w var args} {
    upvar $var local
    set mbargs $w
    if {[info exists local]} {
        lappend mbargs -text $local
    }
    ttk::menubutton {*}$mbargs
    set m [menu $w.m -tearoff false]
    foreach item $args {
        $m add radiobutton \
            -variable $var \
            -value $item \
            -label $item \
            -command "
                set $var $item
                $w configure -text $item
            "
    }
    $w configure -menu $m
    return $w
}

#######################################################################
# GUI
#
option add *Spinbox.width     8
option add *Spinbox.from      -100000.0
option add *Spinbox.to        100000.0
option add *Spinbox.increment 0.05

if {[tk windowingsystem] eq "x11"} {
    ttk::setTheme clam
    option add *Menu.background        snow
    option add *Menu.activeBorderWidth 0
    option add *Menu.activeForeground  white
    option add *Menu.activeBackground  #4a6984
}
set po {-padx 3 -pady 3}
wm title . "Simulador calor 1D"
tk appname "Calor1D"

#######################################################################
# el canvas (grafico)
ttk::frame .bg; place .bg -x 0 -y 0 -relwidth 1.0 -relheight 1.0
canvas .c -bg white -width 600
.c create line {0 0 0 0} -tags plot -fill blue3
.c create text {0 0} -tags itext -anchor s
.c create oval {0 0 0 0} -tags idot -fill red -outline green
.c create rectangle {0 0 0 0} -width 2 -tags rect
for {set i 0} {$i <= 10} {incr i} {
    .c create text {0 0} -anchor e -tags [list label $i]
    .c create line {0 0 0 0} -dash - -fill green3 -tags [list grid $i]
}
.c lower grid
ttk::optionMenu .c.m bc dirichlet newmann
.c.m configure -width 10
place .c.m -anchor se -relx 1.0 -rely 1.0

#######################################################################
# los parametros de la simulacion
ttk::labelframe .params  -text " Par\u00e1metros "
foreach {w t} [list \
        dx  "Paso espacial\n\[m\]" \
        dt  "Paso temporal\n\[s\]" \
        k   "Conductividad\n\[W/(m.\u00b0K)\]" \
        rho "Densidad\n\[kg/m\u00b3\]" \
        C   "Calor espec\u00edfico\n\[J/(kg.\u00b0K)\]" \
        Q   "Calor aportado\n\[J/m\]" \
        q   "Vector normal\n\[W/m\u00b2\]"
        ] {
    set l [ttk::label .params.l$w -text $t -anchor e -justify right]
    set s [spinbox .params.val$w -textvariable p($w)]
    grid $l $s -sticky news {*}$po
}
set l [ttk::label .params.lnodos -text Nodos\n -anchor e -justify right]
set s [spinbox .params.nodos -command reset\
    -textvariable p(nodos) -from 3 -to 1001 -increment 2]
grid $l $s -sticky news {*}$po
grid columnconfigure .params 0 -weight 1

#######################################################################
# la convergencia
ttk::labelframe .ac -text " An\u00e1lisis de convergencia "
foreach {var t} [list \
        conv   "Converge?" \
        norma  "Norma de\nconvergencia" \
        ] {
    set l [ttk::label .ac.l$var -text $t -anchor e -justify right]
    set s [label .ac.$var -textvariable $var -width 8\
        -anchor w -relief sunken -background white]
    grid $l $s -sticky ew {*}$po
}
grid columnconfigure .ac 0 -weight 1

#######################################################################
# el control de pasos de calculo
ttk::labelframe .st   -text " Pasos "
ttk::label   .st.lnstep -text "NÂș pasos"
spinbox .st.nstep \
    -textvariable numpasos -values {1 10 100 1000 10000}
ttk::button  .st.go -text "Comenzar" \
    -command {disablesteps; dostep $numpasos}
grid .st.lnstep .st.nstep -sticky news {*}$po
grid .st.go - -sticky news {*}$po
grid columnconfigure .st 0 -weight 1

#######################################################################
# el control del simulador
ttk::labelframe .co -text " Control "
ttk::button .co.reset -text "Reset" -command reset
ttk::button .co.exit  -text "Salir" -command exit
pack .co.reset .co.exit -fill x {*}$po

#######################################################################
# page layout
grid .c .params -sticky news {*}$po
grid ^  .ac     -sticky news {*}$po
grid ^  .st     -sticky news {*}$po
grid ^  .co     -sticky new  {*}$po
grid columnconfigure .  0 -weight 1
grid rowconfigure    .  3 -weight 1

#######################################################################
# bindings
bind .c <Configure> redraw
bind .c <Enter> {
    bind .c <Motion> [list showvalue \x25x \x25y]
    .c itemconfigure itext||idot -state normal
}
bind .c <Leave> {
    bind .c <Motion> {}
    .c itemconfigure itext||idot -state hidden
}
bind all <Control-E> {edit_reset}
bind all <Control-e> {edit_reset}

#######################################################################
# Listo. Empieza el simulador
reset
trace add variable p write converge?