Крайне непопулярный язык Tcl/Tk

#Rim_Arab.tcl
source [file join [file dirname [info script]] chisla_rim_arab.tcl]
source [file join [file dirname [info script]] chisla_arab_rim.tcl]
source [file join [file dirname [info script]] Valid_Int.tcl]
source [file join [file dirname [info script]] Valid_Rim.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.label           -text " Арабское  число:"
entry  $w.two.entry           -textvar Arab  -fg red   -validate  all  -vcmd {Valid_Int %P}
ttk::button $w.two.button     -text "Вычислить!"  -command {$w.three.entry  insert 0 "[eval {Arab_Rim $Arab}]"}
bind   $w.two.entry     <Return>  {$w.three.entry  insert 0 "[eval {Arab_Rim $Arab}]"}
ttk::button $w.two.button1    -text "Очистить!"   -command {$w.two.entry   delete 0 end}
bind   $w.two.entry     <Delete>  {$w.two.entry  delete  0 end}
 
frame  $w.three
label  $w.three.label         -text " Римское    число:"
entry  $w.three.entry         -textvar Rim   -fg blue  -validate  all  -vcmd {Valid_Rim  %P}         
ttk::button $w.three.button   -text "Вычислить!"  -command {$w.two.entry    insert 0 "[eval {Rim_Arab $Rim }]"}
bind   $w.three.entry   <Return>  {$w.two.entry    insert 0 "[eval {Rim_Arab $Rim }]"}              
ttk::button $w.three.button1  -text "Очистить!"   -command {$w.three.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

#chisla_arab_rim.tcl
proc Arab_Rim {Arab} {
source [file join [file dirname [info script]] data_arab_rim.tcl]
set E 0; set Rim ""
while {0 < $Arab} {
 while {[lindex $arab $E] <= $Arab} {
  append Rim [lindex $rim $E]
  set Arab [expr {$Arab - [lindex $arab $E]}]
      }
      incr E
   }
   return $Rim
}

# data_arab_rim.tcl
set arab {1000 900 500 400 100 90 50 40 10 9 5 4 1}
set rim  {M CM D CD C XC L XL X IX V IV I}

#Valid_Int.tcl
proc Valid_Int {Arab} {return [expr {[string is integer $Arab] && [expr {$Arab < 4000}]}]}

#chisla_rim_arab.tcl
proc Rim_Arab {Rim} {
source [file join [file dirname [info script]] data_rim_arab.tcl]
set RimCM [string map {IV IIII IX VIIII XL XXXX XC LXXXX CD CCCC CM DCCCC} $Rim]
set RimN  [split $RimCM {}]
set Qwer 0; foreach P $RimN {set Qwer [expr {$Qwer + $r_a($P)}]}
set Arab $Qwer 
}

#data_rim_arab.tcl
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

#Valid_Rim.tcl
proc Valid_Rim {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]}

#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}
pack        .label  .entry  .button_1  .button_2    -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})$} $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 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
 
tablica $order

#tablica.tcl
source [file join [file dirname [info script]] pokolenie.tcl]
 
proc tablica {order } {
 global  i u d w t
 for {set i 0} {$i < $t} {incr i} {
 destroy  $w.frame.$i
 set num [lindex  $order $i]
 set xpos($i) [expr {($i%$u)*$d}]
 set ypos($i) [expr {($i/$u)*$d}]
ttk::button  $w.frame.$i   -text  $num        -command   {set order [pokolenie $order]; tablica $order}
place        $w.frame.$i   -relx  $xpos($i)   -rely   $ypos($i)   -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 {set order1 [lappend order1 "" ]}
 set R {set order1 [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 {set order [lappend order "X"]} \
                 else {set order [lappend order ""]}     
   }
   return $order    
}

# start_puzzle_1.tcl
label       .label    -text "Введите размерность пазла:" 
entry       .entry    -textvar a   -validate all   -vcmd {Valid %P}
ttk::button .button1  -text "Вычислить!" -command {source [file join [file dirname [info script]] puzzle_1.tcl]}
bind        .entry <Return>  {source [file join [file dirname [info script]] puzzle_1.tcl]}
ttk::button .button2  -text "Очистить!" -command  {.entry delete 0 end}
bind        .entry <Delete> {.entry delete 0 end}
pack        .label .entry .button1 .button2 -side left
 
proc Valid {a} {
     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})$} $a]
}

#puzzle_1.tcl
source [file join [file dirname [info script]] spisok_1.tcl]
source [file join [file dirname [info script]] puzzleSwitch_1.tcl]
package require Tk
 
if {$a == 1} {tk_messageBox  -title "Предупреждение!"  -message "Неправильное значение > a = 1"}
set u [format "%d" $a]
set d [expr {1.0 / $u}]
set t [expr {round(pow($u, 2)) - 1}]
set Spisok [spisok $t]
 
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 "Игра \"Пазлы\""
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
# ----------------------------------------------------------------------
for {set i 0} {$i < $t} {incr i} {
     set num [lindex  $Spisok $i]
     set xpos($num) [expr {($i%$u)*$d}]
     set ypos($num) [expr {($i/$u)*$d}]
ttk::button $w.frame.$num     -text     $num          -command "puzzleSwitch_1 $w $num"
place       $w.frame.$num     -relx     $xpos($num)   -rely $ypos($num) \
                              -relwidth $d            -relheight $d
}
set Q [expr {1.0 - 1.0/$u}]
set xpos(space) $Q; set ypos(space) $Q

# puzzleSwitch_1.tcl
proc puzzleSwitch_1 {w num} {
    global xpos ypos u
    set E [expr {0.1/$u}]; set R [expr {1.5/$u}]
  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)))} {
    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)
   }
}

#spisok_1.tcl
proc ldelete_val {list val} {
 set ix [lsearch -exact $list $val]
  if {$ix >= 0} {return [lreplace $list $ix $ix]} else {return $list}
}     
proc spisok {t} {
 set Spisok {0}; set q {llength $Spisok}
  while {[eval $q] <= $t} {
   set k 0; set n [expr {round(rand()*$t)}]
    foreach i $Spisok {if {$i != $n} {incr k}}                    
     if {[eval $q] == $k} {lappend Spisok $n}                         
   }
   ldelete_val $Spisok 0
}