| 1 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 2 | # FILE : tolmethods.tcl |
|---|
| 3 | # PURPOSE : Metodos de Tol desde TCL |
|---|
| 4 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 5 | |
|---|
| 6 | |
|---|
| 7 | # includes. 1 -> Include. 0 -> No |
|---|
| 8 | if { 0 } { |
|---|
| 9 | # packages |
|---|
| 10 | package require Tk |
|---|
| 11 | package require BWidget |
|---|
| 12 | # package require BLT |
|---|
| 13 | # |
|---|
| 14 | wm geometry . 1x1+1+1 |
|---|
| 15 | set toltk_script_path [file dirname [info script]] |
|---|
| 16 | # load tclIndex |
|---|
| 17 | set dir $toltk_script_path |
|---|
| 18 | source [file join $toltk_script_path "tclIndex"] |
|---|
| 19 | unset dir |
|---|
| 20 | if { ![info exists toltk_library] } { |
|---|
| 21 | set toltk_library [file join $toltk_script_path ..] |
|---|
| 22 | } |
|---|
| 23 | # messages |
|---|
| 24 | package require msgcat |
|---|
| 25 | namespace import msgcat::* |
|---|
| 26 | # bitmap |
|---|
| 27 | Bitmap::use |
|---|
| 28 | set toltk_script_path [file dirname [info script]] |
|---|
| 29 | #Tol load images: |
|---|
| 30 | set toltk_images_path [file join ${toltk_script_path} images] |
|---|
| 31 | if { [lsearch $Bitmap::path $toltk_images_path] == -1 } { |
|---|
| 32 | #añade la ruta de las imágenes para que Bitmap sepa donde están: |
|---|
| 33 | lappend Bitmap::path [file join $toltk_script_path images] |
|---|
| 34 | } |
|---|
| 35 | } |
|---|
| 36 | |
|---|
| 37 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 38 | # Methods to Serie |
|---|
| 39 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 40 | |
|---|
| 41 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 42 | proc Tol_SerieChartMethod { sergrp fileDest } { |
|---|
| 43 | # |
|---|
| 44 | # PURPOSE: Hook of Chart method |
|---|
| 45 | # |
|---|
| 46 | # PARAMETERS: |
|---|
| 47 | # sergrp -> group of series |
|---|
| 48 | # fileDest -> destination file |
|---|
| 49 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 50 | # cargamos la variable GCFFile de TOL |
|---|
| 51 | set fileGCF [TclGetVar Text GCFFile] |
|---|
| 52 | if {![file exists $fileGCF]} { |
|---|
| 53 | set fileGCF {} |
|---|
| 54 | } |
|---|
| 55 | # MDI |
|---|
| 56 | set tl [::project::CreateForm \ |
|---|
| 57 | -title [mc "Series graph"] \ |
|---|
| 58 | -type Graphs \ |
|---|
| 59 | -iniconfig SeriesGraph \ |
|---|
| 60 | -width 600 -height 200 |
|---|
| 61 | ] |
|---|
| 62 | set top [$tl getframe] |
|---|
| 63 | |
|---|
| 64 | set isphoto [expr {$fileDest ne ""}] |
|---|
| 65 | #Tolcon_Trace "set isphoto [expr {$fileDest ne {}}]" |
|---|
| 66 | set Instance [::SeriesGraph::Create $top.g $sergrp \ |
|---|
| 67 | -photo $isphoto -fileGCF $fileGCF] |
|---|
| 68 | bind $top.g <Destroy> +[list ::tol::seriegrp destroy $sergrp] |
|---|
| 69 | pack $top.g -fill both -expand yes |
|---|
| 70 | update |
|---|
| 71 | |
|---|
| 72 | ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 |
|---|
| 73 | if {$isphoto} { |
|---|
| 74 | ::bayesGraph::TakePhoto $Instance $fileDest |
|---|
| 75 | after idle "destroy $tl" |
|---|
| 76 | } |
|---|
| 77 | } |
|---|
| 78 | |
|---|
| 79 | |
|---|
| 80 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 81 | proc Tol_SerieChart { title source gcfFile geometry filetosave } { |
|---|
| 82 | # |
|---|
| 83 | # PURPOSE: Paint the graph of a set of series |
|---|
| 84 | # |
|---|
| 85 | # PARAMETERS: |
|---|
| 86 | # title -> title for the graph |
|---|
| 87 | # source -> reference to the set |
|---|
| 88 | # gcfFile -> a gcf to aply to the graph |
|---|
| 89 | # geometry -> geometry for the window of the graph |
|---|
| 90 | # filetosave -> if a file name is given the graph is written to disk instead |
|---|
| 91 | # of displayed |
|---|
| 92 | # |
|---|
| 93 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 94 | # GCF |
|---|
| 95 | if {![string length $gcfFile]} { |
|---|
| 96 | set gcfFile [TclGetVar Text GCFFile] |
|---|
| 97 | if {[string length $gcfFile]} { |
|---|
| 98 | eval set gcfFile $gcfFile |
|---|
| 99 | } |
|---|
| 100 | } |
|---|
| 101 | if {![file exists $gcfFile]} { |
|---|
| 102 | set gcfFile {} |
|---|
| 103 | } |
|---|
| 104 | #puts "GCF FILE: $gcfFile" |
|---|
| 105 | # Title |
|---|
| 106 | set wTitle $title |
|---|
| 107 | if {![string length $title]} { |
|---|
| 108 | set wTitle [mc "Series graph"] |
|---|
| 109 | } |
|---|
| 110 | |
|---|
| 111 | # Create Group Series |
|---|
| 112 | #puts "Tol_SerieChart: source = $source" |
|---|
| 113 | set nsource [lindex [TclGetVar Set $source] 0] |
|---|
| 114 | set lstSerie {} |
|---|
| 115 | for {set i 1} {$i <= $nsource} {incr i} { |
|---|
| 116 | lappend lstSerie "Set $source $i" |
|---|
| 117 | } |
|---|
| 118 | set sergrp tableserie[clock clicks] |
|---|
| 119 | set tl "" |
|---|
| 120 | if {[llength $lstSerie]} { |
|---|
| 121 | # MDI |
|---|
| 122 | set tl [::project::CreateForm \ |
|---|
| 123 | -title $wTitle -type Graphs -iniconfig SeriesGraph -geometry $geometry] |
|---|
| 124 | $tl setgeometry $geometry |
|---|
| 125 | set top [$tl getframe] |
|---|
| 126 | #puts "Tol_SerieChart: tol::seriegrp sergrp = $sergrp, lstSerie = $lstSerie" |
|---|
| 127 | eval ::tol::seriegrp create $sergrp $lstSerie |
|---|
| 128 | # Create |
|---|
| 129 | set isphoto [expr {$filetosave ne ""}] |
|---|
| 130 | set Instance [::SeriesGraph::Create $top.g $sergrp \ |
|---|
| 131 | -photo $isphoto -fileGCF $gcfFile -title [list $title]] |
|---|
| 132 | bind $top.g <Destroy> +[list ::tol::seriegrp destroy $sergrp] |
|---|
| 133 | pack $top.g -fill both -expand yes |
|---|
| 134 | update |
|---|
| 135 | # Control Axis |
|---|
| 136 | ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 |
|---|
| 137 | # Save graph ? |
|---|
| 138 | if {$isphoto} { |
|---|
| 139 | ::bayesGraph::TakePhoto $Instance $filetosave |
|---|
| 140 | after idle "destroy $tl" |
|---|
| 141 | } |
|---|
| 142 | } else { |
|---|
| 143 | set msg [mc {No selection information related}] |
|---|
| 144 | ::TolConsole::HciWriter "<W>${msg}</W>" |
|---|
| 145 | } |
|---|
| 146 | return $tl |
|---|
| 147 | } |
|---|
| 148 | |
|---|
| 149 | |
|---|
| 150 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 151 | proc Tol_SerieTabulate { source {title ""} {geometry {}} } { |
|---|
| 152 | # |
|---|
| 153 | # PURPOSE: Tabulates a serie in a TolBase table window |
|---|
| 154 | # |
|---|
| 155 | # PARAMETERS: |
|---|
| 156 | # source -> the tol serie variable or variables (if a list is given) |
|---|
| 157 | # geometry -> geometry specification |
|---|
| 158 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 159 | |
|---|
| 160 | # chek type TOL of source |
|---|
| 161 | set gramVar [GetGlobalUniqueName __tabser__] |
|---|
| 162 | ::tol::console eval "Text $gramVar = Grammar($source);" |
|---|
| 163 | set namGra [string trim [TclGetVar Text $gramVar] {"}];#{"} |
|---|
| 164 | # destroy |
|---|
| 165 | ::tol::console stack release $gramVar |
|---|
| 166 | # list of series tabulate |
|---|
| 167 | set lstSerie {} |
|---|
| 168 | switch $namGra { |
|---|
| 169 | Serie { set lstSerie [ list [ list Serie $source ] ] } |
|---|
| 170 | Set { |
|---|
| 171 | set nsource [lindex [TclGetVar Set $source] 0] |
|---|
| 172 | for {set i 1} {$i <= $nsource} {incr i} { |
|---|
| 173 | lappend lstSerie [list Set $source $i ] |
|---|
| 174 | } |
|---|
| 175 | } |
|---|
| 176 | } |
|---|
| 177 | # lstSerie > 0 ? |
|---|
| 178 | set tl {} |
|---|
| 179 | if {[llength $lstSerie]} { |
|---|
| 180 | # create sergrp |
|---|
| 181 | set sergrp group[clock clicks] |
|---|
| 182 | eval "::tol::seriegrp create $sergrp $lstSerie" |
|---|
| 183 | #title |
|---|
| 184 | if { ![llength $title] } { |
|---|
| 185 | set title [mc "Time series table"] |
|---|
| 186 | } |
|---|
| 187 | # create |
|---|
| 188 | set tl [::project::CreateForm \ |
|---|
| 189 | -title $title \ |
|---|
| 190 | -iniconfig SeriesTable \ |
|---|
| 191 | -type Tables \ |
|---|
| 192 | -geometry $geometry |
|---|
| 193 | ] |
|---|
| 194 | $tl setgeometry $geometry |
|---|
| 195 | set tlf [$tl getframe] |
|---|
| 196 | # configuration |
|---|
| 197 | btable $tlf.t -parent $tl \ |
|---|
| 198 | -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ |
|---|
| 199 | -iniconfig btable |
|---|
| 200 | $tlf.t fillSerie $sergrp |
|---|
| 201 | bind $tlf.t <Destroy> +[list ::tol::seriegrp destroy $sergrp] |
|---|
| 202 | $tl bind <Control-F4> [list $tl kill] |
|---|
| 203 | pack $tlf.t -fill both -expand yes |
|---|
| 204 | update |
|---|
| 205 | } |
|---|
| 206 | return $tl |
|---|
| 207 | } |
|---|
| 208 | |
|---|
| 209 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 210 | proc Tol_SerieAutocor { source {title ""} {geometry {}} } { |
|---|
| 211 | # |
|---|
| 212 | # PURPOSE: Tabulates a serie in a TolBase table window |
|---|
| 213 | # |
|---|
| 214 | # PARAMETERS: |
|---|
| 215 | # source -> the tol serie variable or variables (if a list is given) |
|---|
| 216 | # geometry -> geometry specification |
|---|
| 217 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 218 | |
|---|
| 219 | # name |
|---|
| 220 | if {[llength $source] > 1} { |
|---|
| 221 | set nameSerie [lindex [::tol::info variable $source] 1] |
|---|
| 222 | } else { |
|---|
| 223 | set nameSerie $source |
|---|
| 224 | } |
|---|
| 225 | #title |
|---|
| 226 | if { ![llength $title] } { |
|---|
| 227 | set title "[mc "Autocorrelation graph"]: $nameSerie" |
|---|
| 228 | } |
|---|
| 229 | # create |
|---|
| 230 | set tl [::project::CreateForm \ |
|---|
| 231 | -title $title \ |
|---|
| 232 | -iniconfig AutocorGraph \ |
|---|
| 233 | -type Graphs \ |
|---|
| 234 | -geometry $geometry -helpkey "Tb4GraAco" |
|---|
| 235 | ] |
|---|
| 236 | $tl setgeometry $geometry |
|---|
| 237 | set tlf [$tl getframe] |
|---|
| 238 | # configuration |
|---|
| 239 | ::AutocorGraph::Create $tlf.g $source |
|---|
| 240 | $tl bind <Control-F4> "$tl kill; break" |
|---|
| 241 | pack $tlf.g -fill both -expand yes |
|---|
| 242 | update |
|---|
| 243 | return $tl |
|---|
| 244 | } |
|---|
| 245 | |
|---|
| 246 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 247 | # Methods to Set |
|---|
| 248 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 249 | |
|---|
| 250 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 251 | proc Tol_SetChartMethod { title source gcfFile geometry filetosave lstNames |
|---|
| 252 | type lstPairs {holdon ""}} { |
|---|
| 253 | # |
|---|
| 254 | # PURPOSE: Hook of Chart method |
|---|
| 255 | # |
|---|
| 256 | # PARAMETERS: |
|---|
| 257 | # title -> title for the graph |
|---|
| 258 | # source -> reference to the set |
|---|
| 259 | # gcfFile -> a gcf to aply to the graph |
|---|
| 260 | # geometry -> geometry for the window of the graph |
|---|
| 261 | # file -> if a file name is given the graph is written to disk instead of displayed |
|---|
| 262 | # lstNames -> names for the series/points,.. |
|---|
| 263 | # type -> 0 for custom association of data columns |
|---|
| 264 | # -> 1 for all data columns to first one |
|---|
| 265 | # -> 2 for all data columns to generic |
|---|
| 266 | # -> 3 for even data columns to odd ones |
|---|
| 267 | # lstPairs -> when type is 0 pairs is the list of correspondence beetwen index |
|---|
| 268 | # columns to data columns (x-y pairs) |
|---|
| 269 | # holdon -> tell if the new graph goes into a new context or an existing one |
|---|
| 270 | # |
|---|
| 271 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 272 | # GCF |
|---|
| 273 | if {![string length $gcfFile]} { |
|---|
| 274 | set gcfFile [TclGetVar Text GCFFile] |
|---|
| 275 | } |
|---|
| 276 | if {![file exists $gcfFile]} { |
|---|
| 277 | set gcfFile {} |
|---|
| 278 | } |
|---|
| 279 | # Title |
|---|
| 280 | set wTitle $title |
|---|
| 281 | if {![string length $title]} { |
|---|
| 282 | set wTitle [mc "Set graph"] |
|---|
| 283 | } |
|---|
| 284 | # MDI |
|---|
| 285 | if {$holdon ne "" && (![winfo exists $holdon] || [winfo class $holdon] ne "Mdidoc")} { |
|---|
| 286 | Tol_HciWriter "<W>[mc {Graphic requested to be drawn on %s but that graphic context does not exist or is not a valid grafic windows} $holdon]</W>" |
|---|
| 287 | set holdon "" |
|---|
| 288 | } |
|---|
| 289 | if {[winfo exists $holdon]} { |
|---|
| 290 | set tl $holdon |
|---|
| 291 | } else { |
|---|
| 292 | puts "no existe '$holdon' por eso ... ::project::CreateForm" |
|---|
| 293 | |
|---|
| 294 | set tl [::project::CreateForm \ |
|---|
| 295 | -title $wTitle -type Graphs -iniconfig SetGraph -geometry $geometry] |
|---|
| 296 | $tl setgeometry $geometry |
|---|
| 297 | } |
|---|
| 298 | set top [$tl getframe] |
|---|
| 299 | # if source is a list is interpreted as a set name and indexes accesing a element |
|---|
| 300 | if {0} { |
|---|
| 301 | if { [llength $source] > 1 } { |
|---|
| 302 | set setname [GetUniqueName Set] |
|---|
| 303 | set sourcename [lindex $source 0] |
|---|
| 304 | set strtoeval "Set ${setname} = ${sourcename}" |
|---|
| 305 | for {set i 1} {$i < [llength $source]} {incr i} { |
|---|
| 306 | set elem [lindex $source $i] |
|---|
| 307 | set strtoeval "${strtoeval}\[$elem\]" |
|---|
| 308 | } |
|---|
| 309 | ::tol::console eval $strtoeval |
|---|
| 310 | set source $setname |
|---|
| 311 | } |
|---|
| 312 | } |
|---|
| 313 | set cmd tableset[clock clicks] |
|---|
| 314 | ::tol::tableset create $cmd [linsert $source 0 Set] |
|---|
| 315 | set Instance [::SetGraphDialog::DrawSet $top.g $cmd $source $type $lstPairs \ |
|---|
| 316 | $lstNames $gcfFile [list $title]] |
|---|
| 317 | if {$holdon ne ""} { |
|---|
| 318 | ::tol::tableset destroy $cmd |
|---|
| 319 | if { [llength $source] > 1} { |
|---|
| 320 | ::tol::stack release $source |
|---|
| 321 | } |
|---|
| 322 | } else { |
|---|
| 323 | bind $top.g <Destroy> +[list ::tol::tableset destroy $cmd] |
|---|
| 324 | if { [llength $source] > 1} { |
|---|
| 325 | bind $top.g <Destroy> +[list ::tol::stack release $source] |
|---|
| 326 | } |
|---|
| 327 | pack $top.g -fill both -expand yes |
|---|
| 328 | update |
|---|
| 329 | ::bayesGraph::GrapOptApplyAxisTicks $Instance ${Instance}::options gr,0 |
|---|
| 330 | if { [string length $filetosave] } { |
|---|
| 331 | ::bayesGraph::TakePhoto $Instance $filetosave |
|---|
| 332 | after idle "destroy $tl" |
|---|
| 333 | } |
|---|
| 334 | } |
|---|
| 335 | return $tl |
|---|
| 336 | } |
|---|
| 337 | |
|---|
| 338 | |
|---|
| 339 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 340 | proc Tol_SetTabulate { set {title ""} {geometry {}} } { |
|---|
| 341 | # |
|---|
| 342 | # PURPOSE: Tabulates a set in a TolBase table window |
|---|
| 343 | # |
|---|
| 344 | # PARAMETERS: |
|---|
| 345 | # source -> the tol set variable |
|---|
| 346 | # geometry -> geometry specification |
|---|
| 347 | #///////////////////////////////////////////////////////////////////////////// |
|---|
| 348 | |
|---|
| 349 | if {[llength $set] > 1} { |
|---|
| 350 | set nameSet [lindex [::tol::info variable $set] 1] |
|---|
| 351 | set setref $set |
|---|
| 352 | } else { |
|---|
| 353 | set nameSet $set |
|---|
| 354 | set setref [ list Set $set ] |
|---|
| 355 | } |
|---|
| 356 | |
|---|
| 357 | if { ![llength $title] } { set title "[mc "Set table"]: $nameSet" } |
|---|
| 358 | |
|---|
| 359 | set setgrp group[clock clicks] |
|---|
| 360 | |
|---|
| 361 | set tl {} |
|---|
| 362 | if { ![ catch { ::tol::tableset create $setgrp $setref } ] } { |
|---|
| 363 | # create |
|---|
| 364 | set tl [::project::CreateForm \ |
|---|
| 365 | -title $title \ |
|---|
| 366 | -iniconfig SetTable \ |
|---|
| 367 | -type Tables \ |
|---|
| 368 | -geometry $geometry |
|---|
| 369 | ] |
|---|
| 370 | $tl setgeometry $geometry |
|---|
| 371 | set tlf [$tl getframe] |
|---|
| 372 | # config |
|---|
| 373 | btable $tlf.t -parent $tl \ |
|---|
| 374 | -posteditcmd [list ::TolConsole::TableRecentUpdate $tlf.t] \ |
|---|
| 375 | -iniconfig btable |
|---|
| 376 | $tlf.t fillSet $setgrp |
|---|
| 377 | pack $tlf.t -fill both -expand yes |
|---|
| 378 | bind $tlf.t <Destroy> +[list ::tol::tableset destroy $setgrp] |
|---|
| 379 | $tl bind <Control-F4> [list $tl kill] |
|---|
| 380 | update |
|---|
| 381 | } else { |
|---|
| 382 | tk_messageBox -type ok -icon warning -message [mc "Set not tabulable"]\ |
|---|
| 383 | -parent . -title [mc Warning] |
|---|
| 384 | # -parent $w_tabset -title [mc Warning] |
|---|
| 385 | } |
|---|
| 386 | return $tl |
|---|
| 387 | } |
|---|
