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

  1. package require Tcl 8.5
  2. package require Tk
  3. namespace path {tcl::mathop tcl::mathfunc}
  4.  
  5. array set p {
  6. dx 1.0
  7. dt 0.5
  8. k 1.0
  9. rho 1.0
  10. C 1.0
  11. Q 1.0
  12. nodos 21
  13. q 9.0
  14. }
  15. set bc newmann
  16. set conv Si
  17.  
  18. proc reset {} {
  19. global p tvec norma conv
  20.  
  21. set tvec [lrepeat $p(nodos) 10.0]
  22. lset tvec end 20.0
  23.  
  24. # no cambiar esto
  25. after cancel [after info]
  26. enablesteps
  27. redraw
  28. }
  29.  
  30. proc step {} {
  31. global p bc tvec norma conv
  32.  
  33. set new [list]
  34. for {set i 1} {$i <= [llength $tvec] - 2} {incr i} {
  35. lassign [lrange $tvec $i-1 $i+1 ] t-1 t t+1
  36. lappend new [expr {
  37. $t +
  38. $p(dt)/($p(rho)*$p(C)) *
  39. ( ($p(k)/$p(dx)**2) * (${t-1}-2*$t+${t+1}) + $p(Q))
  40. }]
  41. }
  42.  
  43. set new [linsert $new 0 [lindex $tvec 0]]
  44. if {[string index $bc 0] eq "d"} {
  45. # dirichlet
  46. lappend new [lindex $tvec end]
  47. } else {
  48. # neumann
  49. lappend new [expr {[lindex $tvec end-1] - ($p(q) * $p(dx) / $p(k))}]
  50. }
  51.  
  52. set max 0
  53. foreach act $tvec fut $new {
  54. set dif [abs [- $fut $act]]
  55. set max [expr {$dif > $max ? $dif : $max}]
  56. }
  57. set norma [format %.3g $max]
  58. set tvec $new
  59. }
  60.  
  61. proc converge? {args} {
  62. global p conv
  63.  
  64. if {1 - 2 * ($p(dt) * $p(k)) / ($p(dx)**2 * $p(rho) * $p(C)) >= 0} {
  65. set conv "Si"
  66. .ac.conv configure -background white -foreground black
  67. } else {
  68. set conv "No"
  69. .ac.conv configure -background red2 -foreground yellow
  70. }
  71. }
  72.  
  73. proc redraw {} {
  74. global tvec p
  75.  
  76. set min [min {*}$tvec]; set max [max {*}$tvec]
  77. set w [winfo width .c]; set h [winfo height .c]
  78.  
  79. lassign {20 40 70 20 5} oar oab oiz ode gap
  80. set ry [- $max $min]
  81. set cry [- $h $oar $oab]
  82.  
  83. for {set i 0} {$i <= 10} {incr i} {
  84. set y [expr {$min + $ry / 10.0 * $i}]
  85. set cy [expr {($h - $oab) - $cry / $ry * ($y - $min)}]
  86. .c itemconfigure label&&$i -text [format %.2f $y]
  87. .c coords label&&$i [- $oiz $gap $gap] $cy
  88. .c coords grid&&$i [- $oiz $gap] $cy [- $w $ode -$gap] $cy
  89. }
  90.  
  91. set mul1 [expr {double($w - $ode - $oiz) / ($p(nodos) - 1)}]
  92. set mul2 [expr {($h - $oab - $oar) / ($max - $min)}]
  93. set idx 0
  94. foreach node $tvec {
  95. set x [expr {$oiz + $mul1 * $idx}]
  96. set y [expr {($h - $oab) - $mul2 * ($node - $min)}]
  97. lappend coords $x $y
  98. incr idx
  99. }
  100.  
  101. .c coords plot $coords
  102. .c coords rect \
  103. [- $oiz $gap] [- $oar $gap] [- $w $ode -$gap] [- $h $oab -$gap]
  104. }
  105.  
  106. proc dostep { steps } {
  107. if {$steps == 0} {
  108. enablesteps
  109. return
  110. }
  111. step
  112. redraw
  113. after idle [list after 1 dostep [incr steps -1]]
  114. }
  115.  
  116. proc enablesteps {} {
  117. .st.go configure -state normal
  118. }
  119.  
  120. proc disablesteps {} {
  121. .st.go configure -state disabled
  122. }
  123.  
  124. proc showvalue {x y} {
  125. global tvec
  126. set idx [.c index plot @$x,$y]
  127. lassign [lrange [.c coords plot] $idx $idx+1] cx cy
  128. .c coords idot [- $cx 3] [- $cy 3] [+ $cx 3] [+ $cy 3]
  129. .c coords itext $cx [- $cy 6]
  130. .c itemconfigure itext -text [format %.3f [lindex $tvec [/ $idx 2]]]
  131. }
  132.  
  133. proc edit_reset {} {
  134. toplevel .edit
  135. pack [set t [text .edit.t]]
  136. $t insert end [info body reset]
  137. focus $t
  138. bind .edit <Double-Escape> [list update_reset $t]
  139. wm protocol .edit WM_DELETE_WINDOW [list update_reset $t]
  140. wm transient .edit .
  141. wm group .edit .
  142. grab set .edit
  143. }
  144.  
  145. proc update_reset { t } {
  146. proc reset {} [$t get 1.0 end]
  147. grab release .edit
  148. destroy .edit
  149. reset
  150. }
  151.  
  152. proc ttk::optionMenu {w var args} {
  153. upvar $var local
  154. set mbargs $w
  155. if {[info exists local]} {
  156. lappend mbargs -text $local
  157. }
  158. ttk::menubutton {*}$mbargs
  159. set m [menu $w.m -tearoff false]
  160. foreach item $args {
  161. $m add radiobutton \
  162. -variable $var \
  163. -value $item \
  164. -label $item \
  165. -command "
  166. set $var $item
  167. $w configure -text $item
  168. "
  169. }
  170. $w configure -menu $m
  171. return $w
  172. }
  173.  
  174. #######################################################################
  175. # GUI
  176. #
  177. option add *Spinbox.width 8
  178. option add *Spinbox.from -100000.0
  179. option add *Spinbox.to 100000.0
  180. option add *Spinbox.increment 0.05
  181.  
  182. if {[tk windowingsystem] eq "x11"} {
  183. ttk::setTheme clam
  184. option add *Menu.background snow
  185. option add *Menu.activeBorderWidth 0
  186. option add *Menu.activeForeground white
  187. option add *Menu.activeBackground #4a6984
  188. }
  189. set po {-padx 3 -pady 3}
  190. wm title . "Simulador calor 1D"
  191. tk appname "Calor1D"
  192.  
  193. #######################################################################
  194. # el canvas (grafico)
  195. ttk::frame .bg; place .bg -x 0 -y 0 -relwidth 1.0 -relheight 1.0
  196. canvas .c -bg white -width 600
  197. .c create line {0 0 0 0} -tags plot -fill blue3
  198. .c create text {0 0} -tags itext -anchor s
  199. .c create oval {0 0 0 0} -tags idot -fill red -outline green
  200. .c create rectangle {0 0 0 0} -width 2 -tags rect
  201. for {set i 0} {$i <= 10} {incr i} {
  202. .c create text {0 0} -anchor e -tags [list label $i]
  203. .c create line {0 0 0 0} -dash - -fill green3 -tags [list grid $i]
  204. }
  205. .c lower grid
  206. ttk::optionMenu .c.m bc dirichlet newmann
  207. .c.m configure -width 10
  208. place .c.m -anchor se -relx 1.0 -rely 1.0
  209.  
  210. #######################################################################
  211. # los parametros de la simulacion
  212. ttk::labelframe .params -text " Par\u00e1metros "
  213. foreach {w t} [list \
  214. dx "Paso espacial\n\[m\]" \
  215. dt "Paso temporal\n\[s\]" \
  216. k "Conductividad\n\[W/(m.\u00b0K)\]" \
  217. rho "Densidad\n\[kg/m\u00b3\]" \
  218. C "Calor espec\u00edfico\n\[J/(kg.\u00b0K)\]" \
  219. Q "Calor aportado\n\[J/m\]" \
  220. q "Vector normal\n\[W/m\u00b2\]"
  221. ] {
  222. set l [ttk::label .params.l$w -text $t -anchor e -justify right]
  223. set s [spinbox .params.val$w -textvariable p($w)]
  224. grid $l $s -sticky news {*}$po
  225. }
  226. set l [ttk::label .params.lnodos -text Nodos\n -anchor e -justify right]
  227. set s [spinbox .params.nodos -command reset\
  228. -textvariable p(nodos) -from 3 -to 1001 -increment 2]
  229. grid $l $s -sticky news {*}$po
  230. grid columnconfigure .params 0 -weight 1
  231.  
  232. #######################################################################
  233. # la convergencia
  234. ttk::labelframe .ac -text " An\u00e1lisis de convergencia "
  235. foreach {var t} [list \
  236. conv "Converge?" \
  237. norma "Norma de\nconvergencia" \
  238. ] {
  239. set l [ttk::label .ac.l$var -text $t -anchor e -justify right]
  240. set s [label .ac.$var -textvariable $var -width 8\
  241. -anchor w -relief sunken -background white]
  242. grid $l $s -sticky ew {*}$po
  243. }
  244. grid columnconfigure .ac 0 -weight 1
  245.  
  246. #######################################################################
  247. # el control de pasos de calculo
  248. ttk::labelframe .st -text " Pasos "
  249. ttk::label .st.lnstep -text "Nº pasos"
  250. spinbox .st.nstep \
  251. -textvariable numpasos -values {1 10 100 1000 10000}
  252. ttk::button .st.go -text "Comenzar" \
  253. -command {disablesteps; dostep $numpasos}
  254. grid .st.lnstep .st.nstep -sticky news {*}$po
  255. grid .st.go - -sticky news {*}$po
  256. grid columnconfigure .st 0 -weight 1
  257.  
  258. #######################################################################
  259. # el control del simulador
  260. ttk::labelframe .co -text " Control "
  261. ttk::button .co.reset -text "Reset" -command reset
  262. ttk::button .co.exit -text "Salir" -command exit
  263. pack .co.reset .co.exit -fill x {*}$po
  264.  
  265. #######################################################################
  266. # page layout
  267. grid .c .params -sticky news {*}$po
  268. grid ^ .ac -sticky news {*}$po
  269. grid ^ .st -sticky news {*}$po
  270. grid ^ .co -sticky new {*}$po
  271. grid columnconfigure . 0 -weight 1
  272. grid rowconfigure . 3 -weight 1
  273.  
  274. #######################################################################
  275. # bindings
  276. bind .c <Configure> redraw
  277. bind .c <Enter> {
  278. bind .c <Motion> [list showvalue \x25x \x25y]
  279. .c itemconfigure itext||idot -state normal
  280. }
  281. bind .c <Leave> {
  282. bind .c <Motion> {}
  283. .c itemconfigure itext||idot -state hidden
  284. }
  285. bind all <Control-E> {edit_reset}
  286. bind all <Control-e> {edit_reset}
  287.  
  288. #######################################################################
  289. # Listo. Empieza el simulador
  290. reset
  291. trace add variable p write converge?