Более компактная и упрощённая реализация команды создания списка:
Код
proc Vvod {a} {
global t
puts stdout { Vvedite a:}
set a [gets stdin]
set t [format "%d" $a]
}
# ----------------------------------------------------------
proc Bez_X {order} {
set len [expr [llength $order] - 1]
set len1 [expr $len + 1]
for {set i 0} {$i <= $len} {incr i} {
for {set j [expr {$i + 1}]} {$j <= $len1} {incr j} {
set qi [lindex $order $i]
set qj [lindex $order $j]
if {$qi == $qj} {
set order [lreplace $order $j $j]
}
}
set len1 [llength $order]
}
return $order
}
# -----------------------------------------------------------
proc Spisok {t} {
for {set k 1} {$k <= $t} {incr k} {
set j [expr {round(rand()*$t)}]
if {$j == 0} {
lappend order [expr {$j + 1}]
} else {
lappend order $j
}
}
return $order
}
# -------------------------------------------------------------
proc Ok_spisok {t} {
set order [Bez_X [Spisok $t]]
for {set x 1} {$x <= $t} {incr x} {
set order [Bez_X [lappend order $x]]
}
return $order
}
# ----------------------------------------------------------------
while 1 {
Vvod a
if {$t == n} {
break }
set order [Ok_spisok $t]
puts stdout "order = $order"
}
Добавлено (16 апреля 2017, 00:55)
---------------------------------------------
Код
proc Ok_spisok {t} {
set order [Bez_X [Spisok $t]]
# При таком цикле получающийся список становится более "случайным"
# игра становится более интересной (сложной)
for {set x $t} {1 <= $x} {incr x -1} {
# -----------------------------------------------------------------
set order [Bez_X [lappend order $x]]
}
return $order
}
Добавлено (14 мая 2017, 13:28)
---------------------------------------------
А вот теперь список становится ещё более "случайным" ...
Код
proc Qwer {t} {
set order_1 [Bez_X [Spisok $t]]
for {set x $t} {1 <= $x} {incr x -1} {
set order_1 [Bez_X [lappend order_1 $x]]
}
set order [Bez_X [Spisok $t]]
foreach valume $order_1 {
set order [Bez_X [lappend order $valume]]
}
return $order
}
Добавлено (22 мая 2017, 20:46)
---------------------------------------------
А теперь у меня просьба!
Мне нужен код который правильно делает то,
что должен по идее делать следующий код:
Код
entry .entry -textvar a
bind .entry <Return> {[eval {Vvod $a}] }
pack .entry -side left
proc Vvod a {
set u [format "%d" a]
puts stdout "u = $u"}
Добавлено (15 июня 2017, 22:09)
---------------------------------------------
И тишина ...
Ладно, вот Вам -
Код
source [file join [file dirname [info script]] chisla.tcl]
package require Tk
. config -bg gray75
set w .search
catch {destroy $w}
toplevel $w
wm title $w "Арабские << >> Римские!"
frame $w.tri
label $w.tri.label3 -text "Это приложение переводит числа из арабской
системы счисления в римскую и обратно!"
pack $w.tri.label3 -side left
frame $w.two
label $w.two.label2 -text "Арабское_число:"
entry $w.two.entry2 -textvar Arab
button $w.two.button3 -text "Вычислить!" -command {tk_messageBox -title "Арабское в Римское " \
-message "Арабское $Arab ==> Римское [eval {Runo $Arab}]" }
bind $w.two.entry2 <Return> { tk_messageBox -title "Арабское в Римское " \
-message "Арабское $Arab ==> Римское [eval {Runo $Arab}]" }
button $w.two.button4 -text "Очистить!" -command {$w.two.entry2 delete 0 [string length $Arab]}
bind $w.two.entry2 <Delete> {$w.two.entry2 delete 0 [string length $Arab]}
pack $w.two.label2 $w.two.entry2 $w.two.button3 $w.two.button4 -side left
frame $w.one
label $w.one.label1 -text "Римское__число:"
entry $w.one.entry1 -textvar Rim
button $w.one.button1 -text "Вычислить!" -command {tk_messageBox -title "Римское в Арабское" \
-message "Римское $Rim ==> Арабское [eval {Run $Rim}]"}
bind $w.one.entry1 <Return> {tk_messageBox -title "Римское в Арабское" \
-message "Римское $Rim ==> Арабское [eval {Run $Rim}]"}
button $w.one.button2 -text "Очистить!" -command {$w.one.entry1 delete 0 [string length $Rim]}
bind $w.one.entry1 <Delete> {$w.one.entry1 delete 0 [string length $Rim]}
pack $w.one.label1 $w.one.entry1 $w.one.button1 $w.one.button2 -side left
pack $w.tri $w.two $w.one -side top
Добавлено (18 июня 2017, 20:00)
---------------------------------------------
А теперь, что бы не загромождать ответ лишним кодом:
Код
set E [expr {.1/$u}]
set R [expr {2.5/$u}]
proc puzzleSwitch {w num} {
global xpos ypos E R
if {(($ypos($num) >= ($ypos(space) - $E))
&& ($ypos($num) <= ($ypos(space) + $E))
&& ($xpos($num) >= ($xpos(space) - $R))
&& ($xpos($num) <= ($xpos(space) + $R)))
|| (($xpos($num) >= ($xpos(space) - $E))
&& ($xpos($num) <= ($xpos(space) + $E))
&& ($ypos($num) >= ($ypos(space) - $R))
&& ($ypos($num) <= ($ypos(space) + $R)))} {
...............................................................................
} }
Теперь прога работает и при размерности 2 и 3!
Следующий кусок кода ограничивает ввод размерности от 3 до 10 включительно.
Размерность 2 убрана потому, что пазлы ( 3 шт ) при ней "ходят по кругу".
Кто не понял - поставте прогу на выполнение ...
Код
if {$a < 3} {
tk_messageBox -title "Предупреждение!" -message "Число a = $a < 3"
exit
} else {
if {$a > 10} {
tk_messageBox -title "Предупреждение!" -message "Число a = $a > 10"
exit
} else {
set u [format "%d" $a]
set d [expr {1.0 / $u}]
set t [expr {round(pow($u, 2)) - 1}]
set order [Qwer $t]
}}
Добавлено (10 июля 2017, 17:01)
---------------------------------------------
Творчески переработанная и улучшенная прога по переводу чисел:
Код
source [file join [file dirname [info script]] chisla.tcl]
package require Tk
. config -bg gray75
set w .search
catch {destroy $w}
toplevel $w
wm title $w "Арабские << >> Римские!"
frame $w.one
label $w.one.label -text "Это приложение переводит числа из арабской системы \
счисления в римскую и обратно!"
pack $w.one.label -side left
frame $w.two
label $w.two.label1 -text "Арабское число:"
entry $w.two.entry1 -textvar Arab -fg red -validate all -vcmd {ValidInt %P}
ttk::button $w.two.button1 -text "Вычислить!" -command { $w.two.entry2 insert 0 "[eval {Arab_Rim $Arab}]"}
bind $w.two.entry1 <Return> { $w.two.entry2 insert 0 "[eval {Arab_Rim $Arab}]" }
ttk::button $w.two.button2 -text "Очистить!" -command {$w.two.entry1 delete 0 end; $w.two.entry2 delete 0 end}
bind $w.two.entry1 <Delete> {$w.two.entry1 delete 0 end; $w.two.entry2 delete 0 end}
label $w.two.label2 -text " Римское число:"
entry $w.two.entry2 -textvar myVar -fg blue
pack $w.two.label1 $w.two.entry1 $w.two.button1 \
$w.two.button2 $w.two.label2 $w.two.entry2 -side left
frame $w.three
label $w.three.label1 -text "Римское число:"
entry $w.three.entry1 -textvar Rim -fg blue -validate all -vcmd {ValidIM %P}
ttk::button $w.three.button1 -text "Вычислить!" -command {$w.three.entry2 insert 0 "[eval {Rim_Arab $Rim}]"}
bind $w.three.entry1 <Return> {$w.three.entry2 insert 0 "[eval {Rim_Arab $Rim}]"}
ttk::button $w.three.button2 -text "Очистить!" -command {$w.three.entry1 delete 0 end; $w.three.entry2 delete 0 end}
bind $w.three.entry1 <Delete> {$w.three.entry1 delete 0 end; $w.three.entry2 delete 0 end}
label $w.three.label2 -text " Арабское число:"
entry $w.three.entry2 -textvar myVar_2 -fg red
pack $w.three.label1 $w.three.entry1 $w.three.button1 \
$w.three.button2 $w.three.label2 $w.three.entry2 -side left
pack $w.one $w.two $w.three -side top
Код
proc ValidInt {Arab} {
return [expr {[string is integer $Arab]
&& [expr {$Arab < 4000}]}]
}
Код
proc ValidIM {Rim} {
return [regexp {^(M{0,3})(C[MD]|D?C{0,3})(X[CL]|L?X{0,3})(I[XV]|V?I{0,3})$} $Rim]
}
Добавлено (01 августа 2017, 15:33)
---------------------------------------------
Упрощённый интерфейс проги:
Код
source [file join [file dirname [info script]] chisla.tcl]
package require Tk
. config -bg gray75
set w .search
catch {destroy $w}
toplevel $w
wm title $w "Арабские << >> Римские!"
frame $w.one
label $w.one.label -text "Это приложение переводит числа из арабской системы \
счисления в римскую и обратно!"
pack $w.one.label -side left
frame $w.two
label $w.two.label1 -text "Арабское число:"
entry $w.two.entry1 -textvar Arab -fg red -validate all -vcmd {ValidInt %P}
entry $w.two.entry2 -textvar Rim -fg blue -validate all -vcmd {ValidIM %P}
ttk::button $w.two.button1 -text "Вычислить!" -command {$w.two.entry2 insert 0 "[eval {Arab_Rim $Arab}]" ;\
$w.two.entry1 insert 0 "[eval {Rim_Arab $Rim }]"}
ttk::button $w.two.button2 -text "Очистить!" -command {$w.two.entry1 delete 0 end; $w.two.entry2 delete 0 end}
bind $w.two.entry1 <Return> {$w.two.entry2 insert 0 "[eval {Arab_Rim $Arab}]"}
bind $w.two.entry2 <Return> {$w.two.entry1 insert 0 "[eval {Rim_Arab $Rim }]"}
bind $w.two.entry1 <Delete> {$w.two.entry1 delete 0 end; $w.two.entry2 delete 0 end}
bind $w.two.entry2 <Delete> {$w.two.entry1 delete 0 end; $w.two.entry2 delete 0 end}
label $w.two.label2 -text " Римское число:"
pack $w.two.label1 $w.two.entry1 $w.two.button1 \
$w.two.button2 $w.two.label2 $w.two.entry2 -side left
pack $w.one $w.two -side top
Добавлено (01 августа 2017, 17:44)
---------------------------------------------
Была найдена ошибка и переформатирован текст:
Код
source [file join [file dirname [info script]] chisla.tcl]
package require Tk
. config -bg gray75
set w .search
catch {destroy $w}
toplevel $w
wm title $w "Арабские << >> Римские!"
frame $w.one
label $w.one.label -text "Это приложение переводит числа из арабской системы \
счисления в римскую и обратно!"
pack $w.one.label -side left
frame $w.two
label $w.two.label1 -text " Арабское число:"
label $w.two.label2 -text " Римское число:"
entry $w.two.entry1 -textvar Arab -fg red -validate all -vcmd {ValidInt %P}
entry $w.two.entry2 -textvar Rim -fg blue -validate all -vcmd {ValidIM %P}
ttk::button $w.two.button1 -text "Вычислить!" -command {$w.two.entry2 insert 0 "[eval {Arab_Rim $Arab}]"}
ttk::button $w.two.button3 -text "Вычислить!" -command {$w.two.entry1 insert 0 "[eval {Rim_Arab $Rim }]"}
bind $w.two.entry1 <Return> {$w.two.entry2 insert 0 "[eval {Arab_Rim $Arab}]"}
bind $w.two.entry2 <Return> {$w.two.entry1 insert 0 "[eval {Rim_Arab $Rim }]"}
ttk::button $w.two.button2 -text "Очистить!" -command {$w.two.entry1 delete 0 end; $w.two.entry2 delete 0 end}
bind $w.two.entry1 <Delete> {$w.two.entry1 delete 0 end; $w.two.entry2 delete 0 end}
bind $w.two.entry2 <Delete> {$w.two.entry1 delete 0 end; $w.two.entry2 delete 0 end}
pack $w.two.label1 $w.two.entry1 $w.two.button1 \
$w.two.button2 $w.two.label2 $w.two.entry2 $w.two.button3 -side left
pack $w.one $w.two -side top
Добавлено (09 августа 2017, 04:57)
---------------------------------------------
Улучшенная версия проги:
Код
source [file join [file dirname [info script]] chisla.tcl]
package require Tk
. config -bg gray75
set w .search
catch {destroy $w}
toplevel $w
wm title $w "Арабские << >> Римские!"
frame $w.one
label $w.one.label -text "Это приложение переводит числа из арабской системы \
счисления в римскую и обратно!"
pack $w.one.label -side left
frame $w.two
frame $w.three
label $w.two.label -text " Арабское число:"
label $w.three.label -text " Римское число:"
entry $w.two.entry -textvar Arab -fg red -validate all -vcmd {ValidInt %P}
entry $w.three.entry -textvar Rim -fg blue -validate all -vcmd {ValidIM %P}
ttk::button $w.two.button -text "Вычислить!" -command {$w.three.entry insert 0 "[eval {Arab_Rim $Arab}]"}
ttk::button $w.three.button -text "Вычислить!" -command {$w.two.entry insert 0 "[eval {Rim_Arab $Rim }]"}
bind $w.two.entry <Return> {$w.three.entry insert 0 "[eval {Arab_Rim $Arab}]"}
bind $w.three.entry <Return> {$w.two.entry insert 0 "[eval {Rim_Arab $Rim }]"}
ttk::button $w.two.button1 -text "Очистить!" -command {$w.two.entry delete 0 end}
ttk::button $w.three.button1 -text "Очистить!" -command {$w.three.entry delete 0 end}
bind $w.two.entry <Delete> {$w.two.entry delete 0 end}
bind $w.three.entry <Delete> {$w.three.entry delete 0 end}
pack $w.two.label $w.two.entry $w.two.button $w.two.button1 -side left
pack $w.three.label $w.three.entry $w.three.button $w.three.button1 -side left
pack $w.one $w.two $w.three -side top
Добавлено (13 сентября 2017, 02:58)
---------------------------------------------
Код
proc Vvod {a} {
global t
puts stdout { Vvedite a =}
set a [gets stdin]
set t [format "%d" $a]
}
proc ldelete_val {list val} {
set ix [lsearch -exact $list $val]
if {$ix >= 0} {
return [lreplace $list $ix $ix]
} else {
return $list
}
}
proc Qwer {t} {
set order {0}
set q 0
while {$q < $t} {
set k 0
set n [expr {round(rand()*$t)}]
if {$n != 0} {
foreach i $order {if {$i != $n} {
incr k
}
}
set w [llength $order]
if {$w == $k} {
set order [ldelete_val [lappend order $n] 0]
}
}
set order1 $order
set q [llength $order1]
}
return $order1
}
while 1 {
Vvod a
if {$t == "n"} {
break }
set order [Qwer $t]
puts stdout "order = $order"
}
Добавлено (05 октября 2017, 22:28)
---------------------------------------------
Код
proc Qwer {t} {
set order {0}; set q 0
while {$q <= $t} {
set k 0; set n [expr {round(rand()*$t)}]
if {$n != 0} {
foreach i $order {if {$i != $n} {
incr k}
}
set w [llength $order]
if {$w == $k} {
set order [lappend order $n]}
}
set q [llength $order]
}
set order1 [ldelete_val $order 0]
}
Добавлено (16 октября 2017, 19:21)
---------------------------------------------
Изменённый фрагмент кода:
Код
#--------------------------------------------------------------------------------------------
set i 0
for {set x 0} {$x < $u} {incr x} {
for {set y 0} {$y < $u} {incr y} {
if {($x == $u - 1) && ($y == $u - 1)} {continue}
set num [lindex $order $i]
set xpos($num) [expr {$x*$d}]
set ypos($num) [expr {$y*$d}]
ttk::button $w.frame.$num -text $num -command "puzzleSwitch $w $num"
place $w.frame.$num -relx $xpos($num) -rely $ypos($num) \
-relwidth $d -relheight $d
incr i
}
}
#----------------------------------------------------------------------------------------------------
Добавлено (20 ноября 2017, 00:22)
---------------------------------------------
Код
proc Qwer {t} {
set order {0}; set q 0
while {$q <= $t} {
set k 0; set n [expr {round(rand()*$t)}]
foreach i $order {if {$i != $n} {incr k}}
set w [llength $order]
if {$w == $k} {set order [lappend order $n]}
set q [llength $order]
}
set order1 [ldelete_val $order 0]
}
Добавлено (02 Ноября 2018, 16:23)
---------------------------------------------
Игра "жизнь"
Код
#Live.tcl
label .label -text "Введите размерность жизненого пространства:"
entry .entry -textvar razmer -validate all -vcmd {Valid %P}
ttk::button .button_1 -text "Вычислить!" -command {source [file join [file dirname [info script]] forma.tcl]}
bind .entry <Return> {source [file join [file dirname [info script]] forma.tcl]}
ttk::button .button_2 -text "Очистить!" -command {.entry delete 0 end}
bind .entry <Delete> {.entry delete 0 end}
ttk::button .button_3 -text "New!" -command {set order [pokolenie $order]; tablica $order}
bind .button_3 <Return> {set order [pokolenie $order]; tablica $order}
pack .label .entry .button_1 .button_2 .button_3 -side left
# --------------------------------------------------------------------------------------------------
proc Valid {razmer} {
return [regexp {^(3{0,1}|4{0,1}|5{0,1}|6{0,1}|7{0,1}|8{0,1}|9{0,1}|10{0,1}| \
|11{0,1}|12{0,1}|13{0,1}|14{0,1}|15{0,1}|16{0,1})$} $razmer]
}
Код
#forma.tcl
source [file join [file dirname [info script]] tablica.tcl]
source [file join [file dirname [info script]] spisok.tcl]
set u [format "%d" $razmer]
set d [expr {1.0 / $u}]
set t [expr {pow($u, 2)}]
set order [Spisok $t]
package require Tk
set w .puzzle
catch {destroy $w}
toplevel $w
set font 04ddd84
label $w.msg -font $font -wraplength 4i -justify left -text "Жизненное пространство - $u на $u."
pack $w.msg -side top
wm title $w "Игра \"Жизнь\""
wm iconname $w "$t - Жизнь"
scrollbar $w.s
if {[tk windowingsystem] eq "aqua"} {set frameSize 600} else {set frameSize 530}
frame $w.frame -width $frameSize -height $frameSize -borderwidth 2 \
-relief sunken -bg [$w.s cget -troughcolor]
pack $w.frame -side top -pady 1c -padx 1c
destroy $w.s
tablica $order
Код
#tablica.tcl
source [file join [file dirname [info script]] pokolenie.tcl]
proc tablica {order } {
global u d w t
for {set i 0} {$i < $t} {incr i} {
destroy $w.frame.$i
set num [lindex $order $i]
set xpos [expr {($i%$u)*$d}]
set ypos [expr {($i/$u)*$d}]
ttk::button $w.frame.$i -text $num -command {set order [pokolenie $order]; tablica $order}
place $w.frame.$i -relx $xpos -rely $ypos -relwidth $d -relheight $d
}
}
Код
#pokolenie.tcl
proc pokolenie {order} {
global u t
set Q {lindex $order $f}
set W {set Xs [expr {$Xs+1}]}
set E {lappend order1 ""}
set R {lappend order1 "X"}
for {set i 0} {$i < $t} {incr i} {
set Xs 0; set q [expr {($i+1)%$u}]
if {([set f [expr {$i-$u}]] >= 0 && [eval $Q] == "X" && [eval $W]) |
([set f [expr {$i-$u+1}]] >= 0 && $q != 0 && [eval $Q] == "X" && [eval $W]) |
([set f [expr {$i+1}]] < $t && $q != 0 && [eval $Q] == "X" && [eval $W]) |
([set f [expr {$i+$u+1}]] < $t && $q != 0 && [eval $Q] == "X" && [eval $W]) |
([set f [expr {$i+$u}]] < $t && [eval $Q] == "X" && [eval $W]) |
([set f [expr {$i+$u-1}]] < $t && $q != 1 && [eval $Q] == "X" && [eval $W]) |
([set f [expr {$i-1}]] >= 0 && $q != 1 && [eval $Q] == "X" && [eval $W]) |
([set f [expr {$i-$u-1}]] >= 0 && $q != 1 && [eval $Q] == "X" && [eval $W])} {
switch -- $Xs {
1 {eval $E}
2 {if {[lindex $order $i] == "X"} then {eval $R} else {eval $E}}
3 {eval $R}
4 {eval $E}
5 {eval $E}
6 {eval $E}
7 {eval $E}
8 {eval $E}
}
} else {eval $E}
}
return $order1
}
Код
#spisok.tcl
proc Spisok {t} {
for {set i 0} {$i < $t} {incr i} {
set n [expr {round(rand()*1)}]
if {$n == 1} then {lappend order "X"} \
else {lappend order ""}
}
return $order
}