El codigo siguiente, se basa principalmente en esta pagina del "Tcl wiki":
http://wiki.tcl.tk/9888
# --------------------------------
#
# loteria
# heavily based on http://wiki.tcl.tk/9888
# --------------------------------
console show
package require Tk
package require Img
if {$tcl_platform(platform) == "unix"} {
sdltk textinput off
borg spinner on;borg toast "Shuffling..."
}
package require struct
package require htmlparse
package require http
set onLine 0
proc iota2 n {
global onLine
::struct::tree t
set url "http://www.random.org/sequences/?min=1&max=54&col=1&format=html&rnd=new"
set http [::http::geturl $url]
set html [::http::data $http]
htmlparse::2tree $html t
htmlparse::removeVisualFluff t
htmlparse::removeFormDefs t
if { [catch {walk {1 4 1 0}} base] } {
tk_messageBox -message "Web Page not available 1"
set onLine 0
t destroy
reset
return
}
if {$base == ""} {
tk_messageBox -message "Web Page not available 2"
set onLine 0
t destroy
reset
return
}
#set base [walk {1 4 1 0}]
set listado [t get $base data]
puts "type(tag): [t get $base type]\n"
set ctr 0
foreach card $listado {
puts "[incr ctr]: $card"
}
t destroy
return $listado
}
proc walkf {n p} {
foreach idx $p {
if {$n == ""} {break}
set n [lindex [t children $n] $idx]
}
return $n
}
proc walk {p} {
return [walkf root $p]
}
# -------------
# parameters
# -------------
proc randomColor {} {format #%06x [expr {int(rand() * 0xFFFFFF)}]}
# name color file
for {set i 1} {$i < 55} {incr i} {
set ctr [format "%02d" $i]
lappend parms [list flower$i [randomColor] lote$ctr.jpg]
}
proc reset {} {
global las54 onLine tcl_platform
.name config -text ""
if {$tcl_platform(platform) == "unix"} {borg spinner on;borg toast "Shuffling..."}
#set las54 [iota1 54]
if $onLine {
set las54 [iota2 54]
} else {
set las54 [iota1 54]
}
foreach i $::list { .0 itemconf $i -state hidden }
for {set i 1} {$i < 55} {incr i} {
.$i itemconf 1 -state hidden
}
.btn configure -state normal
.ckOnLine configure -state normal
if {$tcl_platform(platform) == "unix"} {borg spinner off;borg toast "Ready..."}
}
proc dala {} {
global las54 onLine
.ckOnLine configure -state disabled
if $onLine {
puts "on-line"
set i [ldrawOL las54]
} else {
set i [ldraw las54]
}
bind .$i <1> [list select $i]
set quedan [llength $las54]
.name config -text [expr {54 - $quedan}]
if {$quedan == 0} {
.btn configure -state disabled
}
select $i
}
proc iota1 n {
set res {}
for {set i 1} {$i<=$n} {incr i} {lappend res $i}
set res
}
proc ldraw _list {
puts "local"
upvar 1 $_list list
set pos [expr {int(rand()*[llength $list])}]
K [lindex $list $pos] [set list [lreplace $list $pos $pos]]
}
proc ldrawOL _list {
puts "on-line"
upvar 1 $_list list
set pos 0
K [lindex $list $pos] [set list [lreplace $list $pos $pos]]
}
proc K {a b} {set a}
if $onLine {
set las54 [iota2 54]
} else {
set las54 [iota1 54]
}
# -------------
# nmage/bimage packages
# -------------
# create a canvas with n images
proc nmage {w args} \
{
# take size from the first image
set image [lindex $args 0]
set ww [image width $image]
set hh [image height $image]
# center coordinates
set x [expr {$ww / 2}]
set y [expr {$hh / 2}]
# create canvas
puts "creating canvas $w"
canvas $w -width $ww -height $hh -highlightt 0
# create the images
foreach image $args {
set id [$w create image $x $y -anchor center -image $image -state hidden]
puts "creating $w > $id"
}
}
# create a canvas with a mini image
proc bimage {n} \
{
# take size from the full image
set image $::names($n)
set ww [image width $image]
set hh [image height $image]
# create the mini image from the full image
foreach {type factor} {mini 4} \
{
set ww2 [expr {$ww / $factor}]
set hh2 [expr {$hh / $factor}]
image create photo ${type}$n -width $ww2 -height $hh2
${type}$n copy $image -subsample $factor
}
# create a canvas with the mini image
nmage .$n mini$n
}
# -------------
# mechanism
# -------------
# called on n-th choice (click on canvas)
proc select {n} \
{
# select the little image
#foreach i $::list { choose $i $n }
.$n itemconf 1 -state normal
.0 raise $n
.0 itemconf $n -state normal
if 0 {
foreach i $::list { .0 itemconf $i -state hidden }
.0 itemconf $n -state normal
}
# show its name
# .name config -text $::names($n)
# set background color
set color $::colors($n)
foreach w {. .name .0} { $w config -bg $color }
foreach i $::list { .$i config -bg $color }
}
# choose between the mini & the micro image
proc choose {i n} \
{
set a 1; set b 2
if {$i == $n} { set a 2; set b 1 }
puts "b = $b"
.$i itemconf $b -state normal
}
# -------------
# create images from files
# -------------
set i 0
foreach item $parms \
{
foreach {name color file} $item break
lappend list [incr i]
set names($i) $name
set colors($i) $color
set files($i) $file
}
foreach i $list { image create photo $names($i) -file $files($i) }
# -------------
# create widgets
# -------------
# the canvas with the full size images
foreach i $list { lappend images $names($i) }
eval [linsert $images 0 nmage .0]
# the label with the name
label .name -font {Times -24}
# the selection canvas
# -------------
# place & display widgets
# -------------
button .btn -text Next -command dala
grid .btn -row 1 -column 0 -sticky nswe
button .btnReset -text Reset -command reset
checkbutton .ckOnLine -text "On-Line" -variable onLine -onvalue 1 -offvalue 0
grid .btnReset -row 6 -column 5 -columnspan 3 -sticky nsew
grid .ckOnLine -row 6 -column 8 -columnspan 3
grid .name -row 0 -column 0
grid .0 -row 2 -column 0 -rowspan 5
for {set i 1} {$i < 55} {incr i} {
set row [format "%0.0f" [expr {ceil ($i/10.0)}]]
set col [format "%0.0f" [expr {((($i/10.0) - $row) + 1) * 10}]]
bimage $i
grid .$i -row $row -column $col
#bind .$i <1> [list select $i]
}
# -------------
# do it!
# -------------
wm title . loteria!
after idle {
if {$tcl_platform(platform) == "unix"} {borg spinner off;borg toast "Ready..."}
}
No comments:
Post a Comment