Вторник, 19 Марта 2024, 09:51

Приветствую Вас Гость

[ Новые сообщения · Игроделы · Правила · Поиск ]
  • Страница 1 из 1
  • 1
Форум игроделов » Программирование » Скриптовые языки программирования » Программирование на Tcl'Tk (Проба сил ...)
Программирование на Tcl'Tk
colencorДата: Четверг, 16 Марта 2017, 07:51 | Сообщение # 1
был не раз
Сейчас нет на сайте
Это приложение является GUI для сами знаете чего ... :)
Поставьте на выполнение и увидите ...
Если не знаете - тем более на выполнение!
Код
source [file join [file dirname [info script]] arab_rim.tcl]
source [file join [file dirname [info script]] rim_arab.tcl]
package require Tk
set w .filebox
catch {destroy $w}
toplevel $w
wm title $w "Из римских в арабские!"
wm iconname $w "filebox"
ttk::frame $w._bg
place $w._bg -x 0 -y 0 -relwidth 1 -relheight 1
set font #4ddd84
ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Это приложение переводит числа из римской  системы    счисления,  в  арабскую и обратно!"
pack $w.msg -side top

    set i "Ввести число"
    set g [ttk::frame $w.$i]
    ttk::label  $g.lab    -text "Римское__число: $i: " -anchor e
    ttk::entry  $g.ent    -textvar Rim
    ttk::button $g.but    -text "Вычислить!!!" -command {tk_messageBox  -title "Арабское число"  -message "Римское $Rim  ==>  Арабское [eval {Run $Rim}]"}
    ttk::button $g.but1   -text "Очистить!"    -command {$g.ent delete 0 [string length $Rim]}  
    pack $g.lab  -side left
    pack $g.ent  -side left   -expand yes -fill x
    pack $g.but  -side left
    pack $g.but1 -side left
    pack $g -fill x -padx 1c -pady 3
    
    set j "Ввести_число"
    set f [ttk::frame $w.$j]
    ttk::label  $f.lab1   -text "Арабское число: $j: " -anchor e
    ttk::entry  $f.ent1   -textvar Arab  
    ttk::button $f.but2   -text "Вычислить!!!" -command {tk_messageBox  -title "Римское число"  -message "Арабское $Arab  ==>  Римское [eval {Runo $Arab}]"}
    ttk::button $f.but3   -text "Очистить!"    -command {$f.ent1 delete 0 [string length $Arab]}
    pack $f.lab1  -side left
    pack $f.ent1  -side left   -expand yes   -fill x
    pack $f.but2  -side left
    pack $f.but3  -side left
    pack $f -fill x -padx 1c -pady 3

Необходимое дополнение: код создавался не с нуля, так что некоторые моменты для меня "магия" facepalm
arab_rim.tcl
Код
#!/usr/local/bin/wish
proc Runo {Arab} {
set a_r {I V X L C D M}
set Arabn [split $Arab {}]
set Zx [string reverse $Arabn]
set I 0; set W ""; set W2 ""                       
foreach V $Zx { set I2 [expr 2*$I]; set I1 [expr 2*$I+1]
                set I3 [expr 2*$I+2]; set V1 [expr $V - 5]
            if {$V == 4} {
        append W [lindex $a_r $I1] [lindex $a_r $I2]
      } elseif {$V == 9} {
        append W [lindex $a_r $I3] [lindex $a_r $I2]
      } elseif {$V1 < 0} {
         for {set J 0} {$J < $V} {incr J} {
        append W [lindex $a_r $I2]
      }} else {
      for {set J 0} {$J < $V1} {incr J} {
        append W [lindex $a_r $I2]
                    }
        append W [lindex $a_r $I1]
              }
      incr I
      }
       set L [string reverse $W]
}

rim_arab.tcl
Код
proc Run {Rim} {
set r_a(I) 1; set r_a(V) 5; set r_a(X) 10; set r_a(L) 50;
set r_a(C) 100; set r_a(D) 500; set r_a(M) 1000
#set Rim [gets stdin]
set RimCM [string map {IV IIII IX VIIII XL XXXX XC LXXXX CD CCCC CM DCCCC} $Rim]
set RimN [split $RimCM {}]
set Arab 0
foreach P $RimN {set Arab [expr $Arab + $r_a($P)]}
set T $Arab
}

Следующий код чисто мой!
Код
source [file join [file dirname [info script]] arab_rim.tcl]
source [file join [file dirname [info script]] rim_arab.tcl]

package require Tk
. config -bg gray75
wm title . "Rim << >> Arab"

label  .label1  -text "Римское число:"
entry  .entry1  -textvar Rim
button .button1 -text "Вычислить!" -command {tk_messageBox  -title "Арабское число"  -message "Римское $Rim  ==>  Арабское [eval {Run $Rim}]"}
button .button2 -text "Очистить!"  -command {.entry1 delete 0 [string length $Rim]}
pack   .label1 .entry1 .button1 .button2 -side left

label  .label2  -text "Арабское число:"
entry  .entry2  -textvar Arab
button .button3 -text "Вычислить!" -command {tk_messageBox  -title "Римское число"  -message "Арабское $Arab  ==>  Римское [eval {Runo $Arab}]"}
button .button4 -text "Очистить!"  -command {.entry2 delete 0 [string length $Arab]}
pack   .label2 .entry2 .button3 .button4 -side left

Добавлено (16 марта 2017, 07:51)
---------------------------------------------
Следующее ...
По идее код должен делать следующее:
Создавать список из чисел длиной = a,
без 0, без повторов чисел, без лакун.
Например a = 7 => {2 4 6 7 5 3 1}, но
происходит бесконечный цикл ...
Вопрос - как исправить код что бы он
работал корректно ...

Код
proc Vvod {a} {
       global t
       puts stdout { Vvedite a:}
       set a [gets stdin]
       set t [format "%d" $a]
    }
  proc Ldelete {list value} {
        set ix [lsearch -exact $list $value]
        if {$ix >= 0} {
           return [lreplace $list $ix $ix]
        } else {
           return $list
        }
    }
  proc Bez_X {order} {    
    foreach valume $order {
      set m [lsearch -all $order $valume]
      set y [lrange $m 1 end]
    foreach val $y {
      lset order $val X
              }
      set order [Ldelete $order X]         
    }    
   return $order
}    
  proc Spisok {t} {
    for {set i 1} {$i <= $t } {incr i} {
      set j [expr {round(rand()*$t)}]
    if {$j == 0} {
        set k [expr {$j + 1}]
} else {
      set k $j
        }   
      lappend order $k  
    }    
   puts stdout "order = $order"   
      set order [Bez_X $order]
      puts stdout "order1 = $order"   
      return $order     
      }  
  proc !Spisok {order t} {
      set dlina [llength $order]
    if {$dlina < $t} {
   set q [expr $t - $dlina]   
      set order1 [Spisok $q]
   puts stdout "order11 = $order1"
      set order [concat $order $order1]
   puts stdout "order2 = $order"
# ----------------------------------------------------------------------   
#      set order [Bez_X $order ]
# При присутствии этой команды Bez_X получается бесконечный цикл!   
      puts stdout "order3 = $order"    
      !Spisok $order $t
} else {
      return $order
   }
}
    while 1 {
      Vvod a
      set order [Spisok $t]
      set x [!Spisok $order $t]
      puts stdout "x = $x"   
    }


litl
GudleifrДата: Четверг, 16 Марта 2017, 09:46 | Сообщение # 2
почти ветеран
Сейчас нет на сайте
Цитата colencor ()
Вопрос - как исправить код что бы он
работал корректно ...

1. Выкинуть написанное
2. Решить задачу на бумажке
3. Перенести решение на tcl

Проблема в чем? В любом конкретном месте Вашей программы Вы как бы начинаете решать ее заново - "сейчас надо срочно удалить из списка", "сейчас надо еще срочнее поменять местами" и т.д. и т.п. И за этими деревьями лес совершенно теряется. Зачем удалять? Зачем менять? Может, этот кусок совсем не нужен, и проще прицепить эти действия к предыдущему/последующему?

И, когда будете строить свои циклы (не исправлять! писать заново!), то запомните: главное в цикле - не та переменная, изменение которой приведет к остановке цикла, а те переменные, соотношение которых должно оставаться постоянным при любом повторе цикла, чтобы он не пошел в разнос (это называется инвариантом цикла).


Быдлокодеры любят повторять: "логика, убивающая мозг",- когда их пытаются заставить программировать.
colencorДата: Вторник, 11 Апреля 2017, 19:59 | Сообщение # 3
был не раз
Сейчас нет на сайте
Я являю миру метод Тупого Перебора во всей своей красе!!! crazy
Решать задачу на бумажке deal , да не в жизнь...
А если серьёзно, я просто отчаялся :( , так что если кто то может предложить
более робастный код, или алгоритм - в студию...
Код
  proc Vvod {a} {
       global t
       puts stdout { Vvedite a:}
       set a [gets stdin]
       set t [format "%d" $a]
    }
  proc Ldelete {list value} {
        set ix [lsearch -exact $list $value]
        if {$ix >= 0} {
           return [lreplace $list $ix $ix]
        } else {
           return $list
        }
    }
  proc Bez_X {order} {    
    foreach valume $order {
      set m [lsearch -all $order $valume]
      set y [lrange $m 1 end]
    foreach val $y {
      lset order $val X
              }
      set order [Ldelete $order X]         
    }    
   return $order
}    
  proc Spisok {t} {
    for {set i 1} {$i <= $t } {incr i} {
      set j [expr {round(rand()*$t)}]
    if {$j == 0} {
      set k [expr {$j + 1}]
}   else {
      set k $j}   
      lappend order $k  
    }
   return $order
}    
    while 1 {
    Vvod a
    if {t == n} {
   break}
    while 1 {
   set order [Spisok $t]
      set order [Bez_X $order]   
   set dlina [llength $order]
    if {$dlina == $t} {      
   break         
        }   
    }
   puts stdout "order = $order "
}


Добавлено (19 марта 2017, 23:55)
---------------------------------------------
Да, совсем забыл - a >14 лучше не задавать!

Добавлено (20 марта 2017, 14:43)
---------------------------------------------
Это как ни как форум игроделов, так?
Тогда вот Вам игрушка
Код
# puzzle.tcl
package require Tk

set u [format "%d" $a]
set d [expr {1.0 / $u}]
set t [expr {round(pow($u, 2)) - 1}]

set w .puzzle
catch {destroy $w}
toplevel $w
    
set font #4ddd84
label $w.msg -font $font -wraplength 4i -justify left -text "Пазлы - $t штук."
pack $w.msg -side top

wm title $w "$t - Puzzle Demonstration"
wm iconname $w "$t - Пазлы"

scrollbar $w.s

if {[tk windowingsystem] eq "aqua"} {
    set frameSize 360
} else {
    set frameSize 240}

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

set order ""
set order [Qwer $t]

for {set i 0} {$i < $t} {incr i} {
    set num [lindex  $order $i]
    set xpos($num)  [expr {($i%$u)*$d}]
    set ypos($num)  [expr {($i/$u)*$d}]
    button $w.frame.$num    -relief raised    -text $num    -highlightthickness 0 \
     -command "puzzleSwitch $w $num"
    place $w.frame.$num    -relx $xpos($num)    -rely $ypos($num) \
    -relwidth $d   -relheight $d
}
set xpos(space) .75
set ypos(space) .75

Код
#dot.tcl
label  .label   -text "Введите размерность пазла:"
entry  .entry   -textvar a
button .button  -text "Вычислить!" -command {source [file join [file dirname [info script]] puzzle.tcl]}
pack   .label .entry .button  -side left

proc puzzleSwitch {w num} {
    global xpos ypos
    if   {(($ypos($num) >= ($ypos(space) - .01))
     && ($ypos($num) <= ($ypos(space) + .01))
     && ($xpos($num) >= ($xpos(space) - .26))
     && ($xpos($num) <= ($xpos(space) + .26)))
    || (($xpos($num) >= ($xpos(space) - .01))
     && ($xpos($num) <= ($xpos(space) + .01))
     && ($ypos($num) >= ($ypos(space) - .26))
     && ($ypos($num) <= ($ypos(space) + .26)))} {
    set tmp $xpos(space)
    set xpos(space) $xpos($num)
    set xpos($num) $tmp
    set tmp $ypos(space)
    set ypos(space) $ypos($num)
    set ypos($num) $tmp
    place $w.frame.$num    -relx $xpos($num)    -rely $ypos($num)
    }}    

proc Ldelete {list value} {
      set ix [lsearch -exact $list $value]
    if {$ix >= 0} {
      return [lreplace $list $ix $ix]
        } else {
      return $list
        }
    }
  proc Bez_X {order} {    
    foreach valume $order {
      set m [lsearch -all $order $valume]
      set y [lrange $m 1 end]
    foreach val $y {
      lset order $val X
              }
      set order [Ldelete $order X]         
    }    
   return $order
}    
  proc Spisok {t} {
    for {set i 1} {$i <= $t } {incr i} {
      set j [expr {round(rand()*$t)}]
    if {$j == 0} {
      set k [expr {$j + 1}]
}   else {
      set k $j}   
      lappend order $k  
    }
   return $order
}    
  proc Qwer {t} {
    if {t == n} {
   break}
    while 1 {
   set order [Spisok $t]
      set order [Bez_X $order]   
   set dlina [llength $order]
    if {$dlina == $t} {      
   break         
        }   
    }
   return $order
}

Пока игрушка работает при размерности пазла = 4, и то пазл(картинка) появляется слишком медленно,
а я хочу что бы размерность пазла можно было задавать до 10 включительно.
Если у меня будет быстрый код(алгоритм), тогда я буду "расширять" proc puzzleSwitch ...

Добавлено (21 марта 2017, 16:40)
---------------------------------------------
А вот при таком алгоритме proc Qwer(t) работает намного быстрее hands
Код
proc Qwer {t} {
    if {t == n} {
        break}
          set order [Spisok $t]  
          set order [Bez_X $order]    
    for {set j 1} {$j <= $t } {incr j} {    
          set order [Bez_X [lappend order $j]]   
        }
          return $order    
}


Добавлено (05 апреля 2017, 16:00)
---------------------------------------------
Исправление:
Код
proc Qwer {t} {
    if {$t == n} {
        break}
       set order [Bez_X [Spisok $t]]    
    for {set j 1} {$j <= $t } {incr j} {    
       set order [Bez_X [lappend order $j]]   
        }
      return $order
}


Добавлено (11 апреля 2017, 19:59)
---------------------------------------------
Дополняем и изменяем код:
Код
-relwidth $d   -relheight $d
}
# ------------------------------------------------------
#switch $u { 2 {set X .5;   set Y .5  } 3 {set X .1;   set Y .1  }
#            4 {set X .75;  set Y .75 } 5 {set X .8;   set Y .8  }
#            6 {set X .835; set Y .835} 7 {set X .858; set Y .858}
#            8 {set X .875; set Y .875} 9 {set X .89;  set Y .89 }
#           10 {set X .9;   set Y .9  }   
# --------------------------------------------------------
# Зачем нужен такой switch, если можно применить
# следующую формулу ...
set Q [expr {1.0-1.0/$u}]
set xpos(space) $Q
set ypos(space) $Q

При u = 2 и u = 3 кнопки не двигаются с любым значением Q ...


litl

Сообщение отредактировал colencor - Четверг, 13 Апреля 2017, 01:28
OrdanДата: Среда, 12 Апреля 2017, 03:01 | Сообщение # 4
Главный зомби
Сейчас нет на сайте
А мне вот жалко времени и сил на такого рода эксперименты от которых мало толку. Да и писать игры на тикле извращение.

Цитата недели: Из-за леса, из-за гор, кишки, месиво, хардкор. (Берсерк ТВ-2)

Мои проекты ТЫК
Мои видяхи на ютубэ ТЫК

Если ты споришь с идиотом, вероятно тоже самое делает и он.
colencorДата: Понедельник, 20 Ноября 2017, 00:22 | Сообщение # 5
был не раз
Сейчас нет на сайте
Более компактная и упрощённая реализация команды создания списка:
Код
  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    
}


litl

Сообщение отредактировал colencor - Понедельник, 20 Ноября 2017, 00:25
Форум игроделов » Программирование » Скриптовые языки программирования » Программирование на Tcl'Tk (Проба сил ...)
  • Страница 1 из 1
  • 1
Поиск:

Все права сохранены. GcUp.ru © 2008-2024 Рейтинг