Chinese Xiangqi Chessboard

Chinese Xianqi Chessboard

This page is under development. Comments are welcome, but please load any comments in the comments section at the bottom of the page. Please include your wiki MONIKER and date in your comment with the same courtesy that I will give you. Aside from your courtesy, your wiki MONIKER and date as a signature and minimal good faith of any internet post are the rules of this TCL-WIKI. Its very hard to reply reasonably without some background of the correspondent on his WIKI bio page. Thanks, gold 12Dec2018

Introduction

gold Here is some starter code for Chinese Xiangqi Chessboard. There are several avenues for a Xianqi chessboard. Literature search showed many chess programs relying on a gif of the Chinese chessboard. Primarily looking at RS's checkers.tcl on the wiki to get some primary movable pieces with the board. An version of the code was installed in the Simple Canvas Demo for some pictures. Also, TCLpaint made a lengthy list of 60 line creations in TCLpaint,but the final code should rely on foreach or loop statements for compact code.

The characters are generally stamped red and blue on round wooden pieces, which might be unicode characters in chinese. Given the purpose to display an Xiangqi board, a wish list is dreamed up. Probably need an if switch option for TCL lists of different character sets. Both the oval and the text character are tagged with a random object name like obj_$tiilename. On selection of a chess piece, the code finds the common name tag of the oval and text piece, and moves both at the same time. Probably should add a color outline during selection and movement with the mouse. Also should be able to center or pin the game pieces at the cross points. Probably could use an exit button.

Using the Simple Canvas Demo framework, the code has installed buttons for switching to traditional Chinese pieces, Western pieces, and alphabetic characters. Probably the buttons could select a color scheme. Xiangqi usually uses a gridded board. Western chess uses brown and white squares. Using the random names for the objects to lock ovals and text together. This works, but additional operations on the gamepieces like the moving outline are gumming up. Also the code is outputting the mouse up and down coordinates for the screen.

With the buttons in the little canvas demo, one can call up separate routines to lay out the different boards and install the various options of chesspieces. In a teamwork situation, programming teams could divide up the several tasks with the framework. In many cases, it is advantageous to have or write little demo programs for the separate subroutines. Some of the demo code decks are included below. In the button call up of the canvas demo, separate tasks can laid in successive statements to clear board, set states, layout the board, and populate the chesspieces. Loading four statements in the button might be ClrCanvas .cv; set state3 3;board .cv;populateCanvas .cv 6 6 3; This gets a little lengthy for a button line, so these statements could be stacked in a separate subroutine. With some global statements for any constants and passing the canvas name as $w, the subroutine could be written like

  proc stackedlist {w} {
    global state3
    ClrCanvas $w
    set state3 3
    board $w
    populateCanvas $w 6 6 3
  }

Screenshots Section

figure 1.

figure 2.

figure 3.

figure 4.

Comments Section

Please place any comments here, Thanks.

gold Changes.

AMG: I suggest using a for loop to make [chessboard] more concise.

gold Is there some way to multiply all numbers in a create statement, leaving the alpha characters unchanged? Perl can do this. I tried but kept bombing, and wound up with this code.

 set bee1 [ list .c create poly  -8 10  -8 7  -5 7  -2 -1  -4 -5  -2 -10  2 -10  4 -5  2 -1  5 7  8 7  8 10 ]
      set bee2 [ list    -8 10  -8 7  -5 7  -2 -1  -4 -5  -2 -10  2 -10  4 -5  2 -1  5 7  8 7  8 10 ]
    set check "1"
     foreach factor [list  10 12 14 16 18 20] {
     set cat [list  ]
     foreach item $bee1 {
      if { [catch {expr {1 * $item}}] >> 0} {lappend cat  $item }

      if { [catch {expr {1 * $item}}] == 0 } {lappend cat [ expr 200*$factor*.1 + $item * log($factor)  ]}
       }
     
      eval $cat -outline gray  -fill [lpick $randomcolor ] 
       }

AMG: Yes, but it's very complex. You'd have to use [regexp -indices -all {\d+} $string] to find the start and end indices corresponding to the numbers, then you'd extract each number, multiply it, and replace it back into the string using [string replace]. I don't recommend this approach, especially since it's liable to modify numbers you didn't intend to modify. Also, that regular expression I gave only works for integers; detecting floating point numbers is even harder.

What you need to do is have each creation parameter be a function of your for loop iterators. You say you have a Fortran background; this concept should be familiar to you, except that Fortran says "DO" instead of "for". :^) More seriously, Tcl for loops are weird (in the same way that C for loops are weird). They take four arguments:

Initialization script. This is executed before the loop begins. It's normally used to create the iteration variable.
Termination test. This expression is tested before each iteration, and if it's false, the loop stops.
Advancement script. This is executed after each iteration of the loop. It's normally used to increment the iteration variable.
Iteration body script. This is executed each time the loop iterates, just before the advancement script. Your main code goes here.

Here's code to make a grid similar to the one your program creates. It shows both for and foreach. To be honest, foreach is simpler than for when there are a very small number of iterations. Here, replace the first for with "foreach i {1 2 3 4 5 6 7} {...}" and the second for with "foreach i {0 1 2 3 4 5 6 7 8 9} {...}".

set dx 20    ;# pixels between adjacent vertical grid lines
set dy 20    ;# pixels between adjacent horizontal grid lines
set x0 30    ;# pixels between left of canvas and left of grid
set y0 30    ;# pixels between top of canvas and top of grid
set win .c   ;# name of canvas widget
foreach i {0 8} {
    $win create line [expr {$i * $dx + $x0}] $y0\
                     [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}]
}
for {set i 1} {$i < 8} {incr i} {
    $win create line [expr {$i * $dx + $x0}] $y0\
                     [expr {$i * $dx + $x0}] [expr {4 * $dy + $y0}]
    $win create line [expr {$i * $dx + $x0}] [expr {5 * $dy + $y0}]\
                     [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}]
}
for {set i 0} {$i < 10} {incr i} {
    $win create line $x0 [expr {$i * $dy + $y0}]\
                     [expr {8 * $dx + $x0}] [expr {$i * $dy + $y0}]
}

There's more work to be done, though. Hopefully this will get you started.

References*

appendix TCL programs

FIRST DEMO

        # first demo code from [AMG]
        # pretty print version from autoindent and ased
        # Xiangqi chessboard with little frills.
        # Crosspatch program, dated 3JUL2010.
        #TCL WIKI contribution
        package require Tk
        proc crosspatch {w} {
            set dx 20    ;# pixels between adjacent vertical grid lines
            set dy 20    ;# pixels between adjacent horizontal grid lines
            set x0 30    ;# pixels between left of canvas and left of grid
            set y0 30    ;# pixels between top of canvas and top of grid
            set win $w   ;# name of canvas widget
            foreach i {0 8} {
                $w create line [expr {$i * $dx + $x0}] $y0\
                        [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}]
            }
            for {set i 1} {$i < 8} {incr i} {
                $w create line [expr {$i * $dx + $x0}] $y0\
                        [expr {$i * $dx + $x0}] [expr {4 * $dy + $y0}]
                $w create line [expr {$i * $dx + $x0}] [expr {5 * $dy + $y0}]\
                        [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}]
            }
            for {set i 0} {$i < 10} {incr i} {
                $w create line $x0 [expr {$i * $dy + $y0}]\
                        [expr {8 * $dx + $x0}] [expr {$i * $dy + $y0}]
            }}
        pack [ canvas .cx -width 400 -height 400 ]
        crosspatch .cx

SECOND DEMO

minimal example of linked movement on canvas

        # second demo code
        # pretty print from autoindent and ased editor
        # Xiangqi chessboard with little frills.
        # Linked oval and text movement on TCL canvas program, dated 3JUL210.
        #TCL WIKI contribution        
        #***minimal example of linked movement on canvas***
   package require Tk
       proc grab { xx yy } {
            global currentx currenty
            set currentx $xx
            set currenty $yy
        }
        
        proc move {w xx yy } {
            global currentx currenty
            set dx [expr {$xx - $currentx}]
            set dy [expr {$yy - $currenty}]
            $w move movable $dx $dy
            $w raise movable
            set currentx $xx
            set currenty $yy
            
        }
        canvas .cv -width 200 -height 200
        pack .cv
        .cv create oval 10 10 30 30 -fill red -tag movable
        .cv create text 20 20   -text @ -fill blue -tag movable        
        .cv create rect 110 10 130 50 -fill green -tag stationary
        .cv create rect 10 110 50 90 -fill yellow -tag stationary        
        .cv bind movable <Button-1> {grab %x %y }
        .cv bind movable <B1-Motion> {move .cv %x %y }

THIRD DEMO

pegboard DEMO with little frills

    # pretty print from autoindent and ased editor
    # pegboard DEMO with little frills.
    # PEGBOARD program, dated 3JUL210.
    #TCL WIKI contribution
    package require Tk    
    proc pegboard {w} {
        console show
        set  max 400
        set  may 400
        for {set r 50} {$r < $max} {incr r 45} {
            for {set c 50} {$c < $max} {incr c 45} {
                set tilename  [expr {int(rand()*1000000000.)}]
                
                $w create oval $r $c [expr $r+5] [expr $c+5] -outline gray -fill green -width 1 \
                        -tags [concat mv xdat_[expr $r+5]  ydat_[expr $c+5] obj_$tilename]
                puts " xdat_[expr $r+5]  ydat_[expr $c+5] obj_$tilename"
                set texter  "  [expr $r+5] [expr $c+5]  "
                $w create text [expr $r+5] [expr $c+20] \
                        -text $texter -fill green -tags "  [expr $r+5] [expr $c+20]"
                
            }}}
    pack [ canvas .cx -width 400 -height 400 ]
    pegboard .cx

FIRST VERSION

m

 #start of deck#start of deck
        #start of deck
        #start of deck

 # written on Windowws XP on eTCL 
     # working under TCL version 8.5.6 and eTCL 1.0.1 
     # gold on TCL WIKI , 17Jul2010

 set oscwidth 1000 
 set oschorizontal 500 
 proc loop {from to body} {
    upvar 1 i i ;# make index visible in body
    for {set i $from} {$i<$to} {incr i} {uplevel 1 $body}
 }
 #-- And likewise, a shortcut for addition:
 proc + {a b} {expr {$a+$b}}
 
 pack [canvas .cv -width 400 -height 500 ]

 focus .cv 
 set state2 1
 proc refreshgrid { .cv state2} {
 global oscwidth oschorizontal colorite
 global grid
 set colorite blue 
 for {set x 10} {$x<$oscwidth} {incr x 50} {.cv create line $x 0 $x $oschorizontal  -fill blue -tag grid -

width 4}
 for {set y 20} {$y<$oschorizontal} {incr y 50} {.cv create line 0 $y $oschorizontal $y -fill blue  -tag grid 

-width 4} 
 .cv itemconfigure grid -fill blue 

 if { $state2 == 1 } { .cv raise grid ;} 
 if { $state2 == 2 } { .cv lower grid ;} 
 }

  refreshgrid  .cv $state2 
 # next lines start withn periods, but hard to see
 . configure -borderwidth 0 -highlightthickness 0 -takefocus 0 -background aquamarine4
 . configure -background palegreen -highlightcolor DarkOliveGreen -relief raised -border 30

 . configure -width 1000 -height 2000

 .cv bind all <1> {set p(X) [.cv canvasx %x]; set p(Y) [.cv canvasy %y]}
 .cv bind mv <B1-Motion> {mv .cv %x %y}

  proc mv {w x y} {
    global p
    set x  [$w canvasx $x]
    set y  [$w canvasy $y]
    set id [$w find withtag current]
    set numberx [$w  gettags current]
    regexp {obj_(\d+)} $numberx -> tilex
    
    puts "1"
    puts $numberx
    puts $tilex
    puts " with tag [$w find withtag obj_$tilex ]"
    foreach item [$w find withtag obj_$tilex ] {
    $w move $item [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
    #$w raise $id
    }
    puts " x y $x $y"
    #$w raise $id
    # $w move [$w find withtag "$tilex"] [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
    #set numberx [$w  gettags current]
    #regexp {obj_(\d+)} $numberx -> tilex
    set p(X) $x; set p(Y) $y
 }

     set bluepieces [list K A A E E H H R R C C P P P P P]
     set redpieces  [list K A A E E H H R R C C P P P P P]
     #black western
     set bluepieces {  \u265A \u265B \u265C \u265C \u265D \u265D \u265E \u265E \u265F \u265F \u265F \u265F 

\u265F \u265F \u265F \u265F}  
     #white western
     set redpieces {  \u2654 \u2655 \u2655 \u2656  \u2656 \u2657 \u2657  \u2658 \u2658 \u2659 \u2659 \u2659  

\u2659 \u2659 \u2659 \u2659 \u2659}  
       set bluepieces {\u5C07 \u58EB  \u58EB  \u8C61 \u8C61 \u99AC \u99AC \u8ECA \u8ECA   \u7832   \u7832    

\u5352 \u5352 \u5352   \u5352 \u5352}
 set redpieces  {  0 \u5E25   \u4ED5 \u4ED5   \u76F8   \u76F8 \u99AC \u99AC \u8ECA \u8ECA      \u70AE  \u70AE 

 \u5175  \u5175    \u5175     \u5175   \u5175  }  
     
     set ind 0
     set indx 0
     set baseline {list 1}
      proc K { x y } { set x }

     proc xpop { topper } {
     global liner
     global ind indx
     global bluepieces redpieces
     global baseline
     set topper [ lindex $bluepieces $ind ];
     if { $topper == "" } { 
     set topper [ lindex $redpieces $indx ]
     set indx [ expr { $indx + 1}]
       } 
     set ind [ expr { $ind + 1}]
     lappend $baseline $topper;
     return $topper;
     }
  proc populateCanvas {w cols rows args} {
    global ind indx
    variable ids ;# links text ids with respective rect ids
    variable boxes ;# lists text id and text associated with each rect id
    catch {unset ids boxes}
    set canvas $w
    # parameters for drawing boxes
    set boxwidth 50
    set boxheight 50
    set padx 3
    set pady 3
    set colors { orange yellow green  gray}
    set labels {one two three four}

    # draw the boxes
    for {set row 0} {$row < $rows} {incr row} {
      for {set col 0} {$col < $cols} {incr col} {

        # calculate coordinates
        set x1 [expr {$col * ($boxwidth + $padx) + $padx}]
        set x2 [expr {$x1 + $boxwidth}]
        set x3 [expr {$x1 + ($boxwidth / 2)}]
        set y1 [expr {$row * ($boxheight + $pady) + $pady}]
        set y2 [expr {$y1 + $boxheight}]
        set y3 [expr {$y1 + ($boxheight / 2)}]

        # choose color and text
        set color [lindex $colors [expr {int(rand() * [llength $colors])}]]
        #set text [lindex $labels [expr {int(rand() * [llength $labels])}]]
        # set text [xpop topper]
         set font2 [list Helvetica [expr $boxwidth/2]]

         #set text "0"
         #set text "K"
         set text [xpop 1 ]
         set tilename  [expr {int(rand()*1000000000.)}]
        # create the boxes
        set boxid [$canvas create oval $x1 $y1 $x2 $y2 \
          -fill $color -tags [concat mv rect $args  obj_$tilename]\
          -outline black]
        set colorfo blue
        if { $indx > 1 } {set colorfo red}
        set textid [$canvas create text $x3 $y3 -font $font2 -fill $colorfo \
          -text $text -tags [concat mv  $args  obj_$tilename]  ]

        # remember which text item goes with which box and what the text says
        set boxes($boxid) [list $textid $text]
        set ids($textid) $boxid
        set ids($boxid) $boxid
      }
    }
  }  
     populateCanvas .cv 6 7  
  console show 
 #end of deck
    #end of deck
      #end of deck
      #end of deck      
      #end of deck
      #statements for random names of objects
        #set numberx [.c  gettags current];
        # regexp {obj_(\d+)} $numberx -> tilex
       #.c delete "obj_$tilex+1" ;
      #set tilename  [expr {int(rand()*1000000000.)}]
     #.c delete obj_$tilex ;
      #end of deck
    #end of deck
      #end of deck
      #end of deck      
      #end of deck
    #end of deck
        #end of deck
      #end of deck
      #end of deck      
      #end of deck
    #end of deck

*SECOND VERSION WITH ADDED HACKS

     #start of deck
        #start of deck
        #start of deck #!/bin/sh
 # Restart with tcl: -*- mode: tcl; tab-width: 4; -*- \
 exec wish $0 ${1+"$@"}

 # demo2-canvas.tcl - HaJo Gurt - 2005-12-13 - https://wiki.tcl-lang.org/15073
 #: CanvasDemo: On button-click, draw something on the canvas
 # gold used canvas demo as base for TCL  chess display board.
 
  package require Tk

  proc ClrCanvas {w} {
    $w delete "all"
    $w configure  -bg white
  }

  proc DrawAxis {w} {
    set midX [expr { $::maxX / 2 }]
    set midY [expr { $::maxY / 2 }]
    $w create line 0     $midY  $::maxX   $midY  -tags "axis"
    $w create line $midX 0        $midX $::maxY  -tags "axis"
  }

  proc PaintText {w Txt} {
    global y
    incr y 10
    $w create text 100 $y -text $Txt -tags "text"
  }

  proc DrawBox {w} {
    global x1 y1 x2 y2
    $w create rect  50  50  100  90  -tags "box"
    $w create rect $x1 $y1  $x2 $y2  -tags "box"
    incr x1 15
    incr x2 15
    incr y1 10
    incr y2 10
  }

  proc DrawFn1 {w} {
    $w create line 0 100  50 200  100 50  150 70  200 155  250 50  300 111  350 222\
             -tags "Fn1"  -smooth bezier
  }

  proc DrawFn2 {w} {
    set offY 0    ;# [expr { $::maxY / 2 }]

    for { set x 0 } { $x <= $::maxX } { incr x 5 } {
      set y [expr { rand() * $::maxY + $offY }]

     #puts "$x $y"
      if {$x>0} { $w create line $x0 $y0 $x $y -tags "Fn2" }
      set x0 $x
      set y0 $y
    }
  }

  #: Main :
  frame .f1
  frame .f2
  pack  .f1 .f2

  set maxX 400
  set maxY 400
  set y      0

  set x1 120
  set x2 150
  set y1  50
  set y2  80

  canvas  .cv -width $maxX -height $maxY  -bg tan
  pack    .cv -in .f1
  button  .a0 -text "xiangqi" -command {set state2 1;set state3 1;board .cv;populateCanvas .cv 6 6 1   }
  button  .a1 -text "west*" -command {unset state3;set state3 3;board .cv;populateCanvas .cv 6 6 3   }
  button  .a2 -text "@" -command {unset state3;set state3 3;board .cv;populateCanvas .cv 6 6 2   }
  button  .b0 -text "C" -command { ClrCanvas .cv }
  button  .b1 -text "Text"  -command { PaintText .cv "Chinese Xiangqi Chess" }
  button  .b2 -text "+"  -command { DrawAxis  .cv }
  button  .b3 -text "\[\]"   -command { DrawBox   .cv }
 
  button  .b6 -text "#dn"   -command { refreshgrid .cv 2 }   

  button  .b7 -text "#up"   -command { refreshgrid .cv 1 } 
  button  .b8 -text "#^"   -command {.cv scale all 0 0 1.1 1.1 }
  button  .b9 -text "#<"   -command {.cv scale all 0 0 .9 .9 }  
  button  .b10 -text "x"   -command { exit    }
   set info "000 000"
   label  .info -textvar info -just left
  pack .a0 .a1 .a2 .b0 .b1 .b2 .b3  .b6 .b7 .b8 .b9 .b10 .info -in .f2  -side left -padx 2

 #catch {console show}
set oscwidth 1000 
 set oschorizontal 500 
 proc loop {from to body} {
    upvar 1 i i ;# make index visible in body
    for {set i $from} {$i<$to} {incr i} {uplevel 1 $body}
 }
#-- And likewise, a shortcut for addition:
 proc + {a b} {expr {$a+$b}}
 
 #pack [canvas .cv -width 400 -height 500 ]

# focus .cv 
 set state2 1
 proc refreshgrid { .cv state2} {
 global oscwidth oschorizontal colorite
 global grid
  global ind indx
  set ind 0
  set indx 0
 set colorite blue 
 for {set x 10} {$x<$oscwidth} {incr x 50} {.cv create line $x 0 $x $oschorizontal  -fill blue -tag grid -width 4}
 for {set y 20} {$y<$oschorizontal} {incr y 50} {.cv create line 0 $y $oschorizontal $y -fill blue  -tag grid -width 4} 
 .cv itemconfigure grid -fill blue 

 if { $state2 == 1 } { .cv raise grid ;} 
 if { $state2 == 2 } { .cv lower grid ;} 
 }

  refreshgrid  .cv $state2 
 # next lines start withn periods, but hard to see
 . configure -borderwidth 0 -highlightthickness 0 -takefocus 0 -background aquamarine4
 . configure -background palegreen -highlightcolor DarkOliveGreen -relief raised -border 30

 . configure -background palegreen -highlightcolor DarkOliveGreen -relief raised -border 30
 . configure -width 1000 -height 2000

.cv bind all <1> {set p(X) [.cv canvasx %x]; set p(Y) [.cv canvasy %y];set info " %x %y "}
 .cv bind mv <B1-Motion> {mv .cv %x %y}
 .cv bind mv <ButtonRelease-1> {set info " %x %y "}
 #.cv bind moveable <ButtonPress-1> {item:move %W %x %y 1;set info " %x %y "}
 proc mv {w x y} {
    global p
    set x  [$w canvasx $x]
    set y  [$w canvasy $y]
    set id [$w find withtag current]
    set numberx [$w  gettags current]
    regexp {obj_(\d+)} $numberx -> tilex
    
    puts "1"
    puts $numberx
    puts $tilex
    puts " with tag [$w find withtag obj_$tilex ]"
    foreach item [$w find withtag obj_$tilex ] {
    $w move $item [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
    #$w raise $id
    }
    puts " x y $x $y"
    #$w raise $id
    # $w move [$w find withtag "$tilex"] [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
    #set numberx [$w  gettags current]
    #regexp {obj_(\d+)} $numberx -> tilex
    set p(X) $x; set p(Y) $y
 }
 
    proc board {w} {
    #set state3 1
    set state2 1
    ClrCanvas $w
    . configure -background orange -highlightcolor brown -relief raised -border 30
    $w configure -bg tan
    
    refreshgrid  .cv $state2 ;
    }
    proc gamepieces {state3} {
     global bluepieces redpieces
     if { $state3 == 2 } { 
     set bluepieces [list K A A E E H H R R C C P P P P P]
     set redpieces  [list 0 K A A E E H H R R C C P P P P P]
       } 
     
    if { $state3 == 3 } { 
     #black western
     set bluepieces {  \u265A \u265B \u265C \u265C \u265D \u265D \u265E \u265E \u265F \u265F \u265F \u265F \u265F \u265F \u265F \u265F}  
     #white western
     set redpieces { 0  \u2654 \u2655 \u2655 \u2656  \u2656 \u2657 \u2657  \u2658 \u2658 \u2659 \u2659 \u2659  \u2659 \u2659 \u2659 \u2659 \u2659}  
       }
      if { $state3 == 1 } { 
      set bluepieces {\u5C07 \u58EB  \u58EB  \u8C61 \u8C61 \u99AC \u99AC \u8ECA \u8ECA   \u7832   \u7832    \u5352 \u5352 \u5352   \u5352 \u5352}
 set redpieces  {  0 \u5E25   \u4ED5 \u4ED5   \u76F8   \u76F8 \u99AC \u99AC \u8ECA \u8ECA      \u70AE  \u70AE  \u5175  \u5175    \u5175     \u5175   \u5175  }  
     }
 
     }

     set ind 0
     set indx 0
     set baseline {list 1}
      proc K { x y } { set x }

     proc xpop { topper } {
     global liner 
     global ind indx 
     global bluepieces redpieces
     global baseline
     set topper [ lindex $bluepieces $ind ];
     if { $topper == "" } { 
     set topper [ lindex $redpieces $indx ]
     set indx [ expr { $indx + 1}]
       } 
     set ind [ expr { $ind + 1}]
     lappend $baseline $topper;
     return $topper;
     }
     set state2 1
          proc populateCanvas {w cols rows args} {
    global state2 state3
    gamepieces $args
    #refreshgrid  $w $state2 
    set state3 $args
    global ind indx
    variable ids ;# links text ids with respective rect ids
    variable boxes ;# lists text id and text associated with each rect id
    catch {unset ids boxes}
    set canvas $w
    
    # parameters for drawing boxes
    set boxwidth 50
    set boxheight 50
    set padx 3
    set pady 3
    set colors { orange yellow green  gray}
    set labels {one two three four}

    # draw the boxes
    for {set row 0} {$row < $rows} {incr row} {
      for {set col 0} {$col < $cols} {incr col} {

        # calculate coordinates
        set x1 [expr {$col * ($boxwidth + $padx) + $padx}]
        set x2 [expr {$x1 + $boxwidth}]
        set x3 [expr {$x1 + ($boxwidth / 2)}]
        set y1 [expr {$row * ($boxheight + $pady) + $pady}]
        set y2 [expr {$y1 + $boxheight}]
        set y3 [expr {$y1 + ($boxheight / 2)}]

        # choose color and text
        set color [lindex $colors [expr {int(rand() * [llength $colors])}]]
        #set text [lindex $labels [expr {int(rand() * [llength $labels])}]]
        # set text [xpop topper]
         set font2 [list Helvetica [expr $boxwidth/2]]

         set text "0"
         #set text "K"
         set texter [xpop 1 ]
         set tilename  [expr {int(rand()*1000000000.)}]
        # create the boxes
        set boxid [$w create oval $x1 $y1 $x2 $y2 \
          -fill $color -tags [concat mv rect $args  obj_$tilename]\
          -outline black]
        set colorfo blue
        if { $indx > 1 } {set colorfo red}
        #set textid [$w create text $x3 $y3 -font $font2 -fill $colorfo \
        #  -text $text -tags [concat mv  $args  obj_$tilename]  ]

         set textid [$w create text $x3 $y3 -font $font2 -fill $colorfo \
          -text $texter -tags [concat mv  $args  obj_$tilename ]  ]

        # remember which text item goes with which box and what the text says
        set boxes($boxid) [list $textid $text]
        set ids($textid) $boxid
        set ids($boxid) $boxid
      }
    }
  }  
     populateCanvas .cv 6 6 1 
        #start of deck

    #end of deck
    #end of deck
      #end of deck
      #end of deck      
      #end of deck
    #end of deck

Version with added hacks and pegboard

    #start of deck
        #start of deck
        #start of deck 
   #!/bin/sh

   #!/bin/sh
 # Restart with tcl: -*- mode: tcl; tab-width: 4; -*- \
 exec wish $0 ${1+"$@"}

 # demo2-canvas.tcl - HaJo Gurt - 2005-12-13 - https://wiki.tcl-lang.org/15073
 #: CanvasDemo: On button-click, draw something on the canvas
 # gold used canvas demo as base for TCL  chess display board.
 
 # written on Windowws XP on eTCL 
     # working under TCL version 8.5.6 and eTCL 1.0.1 
     # gold on TCL WIKI , 17Jul2010

        proc scr {w} {
        console show
        set  max 400
        set  may 400 
 for {set r 50} {$r < $max} {incr r 45} {
     for {set c 50} {$c < $max} {incr c 45} {
        set tilename  [expr {int(rand()*1000000000.)}]
  
         $w create oval $r $c [expr $r+5] [expr $c+5] -outline gray -fill green -width 1 \
         -tags [concat mv xdat_[expr $r+5]  ydat_[expr $c+5] obj_$tilename]
           puts " xdat_[expr $r+5]  ydat_[expr $c+5] obj_$tilename"
        set texter  "  [expr $r+5] [expr $c+5]  "
       $w create text [expr $r+5] [expr $c+20] \
          -text $texter -fill green -tags "  [expr $r+5] [expr $c+20]"

 }}}
 
   package require Tk

  proc ClrCanvas {w} {
    $w delete "all"
    $w configure  -bg white
  }

  proc DrawAxis {w} {
    set midX [expr { $::maxX / 2 }]
    set midY [expr { $::maxY / 2 }]
    $w create line 0     $midY  $::maxX   $midY  -tags "axis"
    $w create line $midX 0        $midX $::maxY  -tags "axis"
  }

  proc PaintText {w Txt} {
    global y
    incr y 10
    $w create text 100 $y -text $Txt -tags "text"
  }

  proc DrawBox {w} {
    global x1 y1 x2 y2
    $w create rect  50  50  100  90  -tags "box"
    $w create rect $x1 $y1  $x2 $y2  -tags "box"
    incr x1 15
    incr x2 15
    incr y1 10
    incr y2 10
  }

  proc DrawFn1 {w} {
    $w create line 0 100  50 200  100 50  150 70  200 155  250 50  300 111  350 222\
             -tags "Fn1"  -smooth bezier
  }

  proc DrawFn2 {w} {
    set offY 0    ;# [expr { $::maxY / 2 }]

    for { set x 0 } { $x <= $::maxX } { incr x 5 } {
      set y [expr { rand() * $::maxY + $offY }]

     #puts "$x $y"
      if {$x>0} { $w create line $x0 $y0 $x $y -tags "Fn2" }
      set x0 $x
      set y0 $y
    }
  }

  #: Main :
  frame .f1
  frame .f2
  pack  .f1 .f2

  set maxX 400
  set maxY 450
  set y      0

  set x1 120
  set x2 150
  set y1  50
  set y2  80

  canvas  .cv -width $maxX -height $maxY  -bg tan
  pack    .cv -in .f1
  button  .a0 -text "xiangqi" -command {set state2 1;set state3 1;board .cv;populateCanvas .cv 6 6 1   }
  button  .a1 -text "west*" -command {unset state3;set state3 3;board .cv;populateCanvas .cv 6 6 3   }
  button  .a2 -text "@" -command {unset state3;set state3 3;board .cv;populateCanvas .cv 6 6 2   }
  button  .a3 -text "&" -command {  ClrCanvas .cv;scr .cv   }
  button  .a4 -text "?" -command {  squarenames .cv; refreshgrid .cv 1  }
   button  .b0 -text "C" -command { ClrCanvas .cv }
  button  .b1 -text "Text"  -command { PaintText .cv "Chinese Xiangqi Chess" }
  button  .b2 -text "+"  -command { DrawAxis  .cv }
  button  .b3 -text "\[\]"   -command { DrawBox   .cv }
 
  button  .b6 -text "#dn"   -command { refreshgrid .cv 2 }   

  button  .b7 -text "#up"   -command { refreshgrid .cv 1 } 
  button  .b8 -text "#^"   -command {.cv scale all 0 0 1.1 1.1 }
  button  .b9 -text "#<"   -command {.cv scale all 0 0 .9 .9 }  
  button  .b10 -text "x"   -command { exit    }
   set info "000 000"
   label  .info -textvar info -just left
  pack .a0 .a1 .a2 .a3 .a4 .b0 .b1 .b2 .b3  .b6 .b7 .b8 .b9 .b10 .info -in .f2  -side left -padx 2

   #catch {console show}
   set oscwidth 1000 
 set oschorizontal 500 
 proc loop {from to body} {
    upvar 1 i i ;# make index visible in body
    for {set i $from} {$i<$to} {incr i} {uplevel 1 $body}
 }
   #-- And likewise, a shortcut for addition:
 proc + {a b} {expr {$a+$b}}
 
 #pack [canvas .cv -width 400 -height 500 ]

    # focus .cv 
 set state2 1
 proc refreshgrid { w state2} {
 global oscwidth oschorizontal colorite
 global grid
  global ind indx
  set ind 0
  set indx 0
    set colorite blue 
   



set dx 45    ;# pixels between adjacent vertical grid lines
set dy 45    ;# pixels between adjacent horizontal grid lines
set x0 30    ;# pixels between left of canvas and left of grid
set y0 30    ;# pixels between top of canvas and top of grid
#set win $w   ;# name of canvas widget
foreach i {0 8} {
    $w create line [expr {$i * $dx + $x0}] $y0\
    [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}] -width 2 -fill blue -tag grid
}
for {set i 1} {$i < 8} {incr i} {
    $w create line [expr {$i * $dx + $x0}] $y0\
    [expr {$i * $dx + $x0}] [expr {4 * $dy + $y0}] -width 2 -fill blue -tag grid
    $w create line [expr {$i * $dx + $x0}] [expr {5 * $dy + $y0}]\
    [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}] -width 2 -fill blue -tag grid
}
for {set i 0} {$i < 10} {incr i} {
    $w create line $x0 [expr {$i * $dy + $y0}]\
    [expr {8 * $dx + $x0}] [expr {$i * $dy + $y0}] -width 2 -fill blue -tag grid
}

 .cv itemconfigure grid -fill blue 

 if { $state2 == 1 } { .cv raise grid ;} 
 if { $state2 == 2 } { .cv lower grid ;} 
 }

  refreshgrid  .cv $state2 
 # next lines start withn periods, but hard to see
 . configure -borderwidth 0 -highlightthickness 0 -takefocus 0 -background aquamarine4
 . configure -background palegreen -highlightcolor DarkOliveGreen -relief raised -border 30

 . configure -background palegreen -highlightcolor DarkOliveGreen -relief raised -border 30
 . configure -width 1000 -height 2000

     .cv bind mv <ButtonRelease-1> {set info " %x %y ";
        catch {.cv itemconfigure [lindex $id 0] -outline black -width 1 }
    }

  .cv bind all <1> {set p(X) [.cv canvasx %x]; set p(Y) [.cv canvasy %y];set info " %x %y "}
 set haloo 50
 .cv bind mv <B1-Motion> {mv .cv %x %y}
 #.cv bind mv <ButtonRelease-1> {set info " %x %y ";puts " nearest [.cv find closest  %x %y $haloo ]"}
 #.cv bind moveable <ButtonPress-1> {item:move %W %x %y 1;set info " %x %y "}
      bind .cv <Motion> {wm title . "Xiangqi Chessboard [expr int( [%W canvasx %x])],[expr int ([%W canvasy 

 %y])]"}

     proc mv {w x y} {
    global p id
    set x  [$w canvasx $x]
    set y  [$w canvasy $y]
    set id [$w find withtag current]
    set numberx [$w  gettags current]
    regexp {obj_(\d+)} $numberx -> tilex
    
    puts "1"
    puts $numberx
    puts $tilex
    puts " with tag [$w find withtag obj_$tilex ]"
    foreach item [$w find withtag obj_$tilex ] {
    $w move $item [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
    catch {$w itemconfigure [lindex $id 0] -outline purple -width 5 }
    #$w raise $id
    }
    puts " x y $x $y"
    #$w raise $id
    # $w move [$w find withtag "$tilex"] [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
    #set numberx [$w  gettags current]
    #regexp {obj_(\d+)} $numberx -> tilex
     catch {$w itemconfigure [lindex $id 0] -outline purple -width 5 }
    set p(X) $x; set p(Y) $y
 }

    proc board {w} {
    #set state3 1
    set state2 1
    ClrCanvas $w
    . configure -background orange -highlightcolor brown -relief raised -border 30
    $w configure -bg tan
     
    refreshgrid  .cv $state2 ;
    }
   
     proc squarenames {l} {
    console show
    set result {}
    set i [llength $l]
        set cc 0
        set rr 0
        foreach row {8 7 6 5 4 3 2 1} {
        set rowscreen [expr {$rr*50.}]
        foreach column {A B C D E F G H} {
        set colscreen  [expr {$cc*50.}]   
        lappend result   "$column$row $rowscreen $colscreen"
        incr cc 1
        incr rr 1
         }}
    puts $result
    return $result
    
   }
      
        #foreach row {8 7 6 5 4 3 2 1} {
        #foreach column {A B C D E F G H} {
        #    lappend res [" " "$column$row"]
        #puts "  $column$row "
  
    proc gamepieces {state3} {
     global bluepieces redpieces
     if { $state3 == 2 } { 
     set bluepieces [list K A A E E H H R R C C P P P P P]
     set redpieces  [list 0 K A A E E H H R R C C P P P P P]
       } 
     
    if { $state3 == 3 } { 
     #black western
     set bluepieces {  \u265A \u265B \u265C \u265C \u265D \u265D \u265E \u265E \u265F \u265F \u265F \u265F 

\u265F \u265F \u265F \u265F}  
     #white western
     set redpieces { 0  \u2654 \u2655 \u2655 \u2656  \u2656 \u2657 \u2657  \u2658 \u2658 \u2659 \u2659 

\u2659 

 \u2659 \u2659 \u2659 \u2659 \u2659}  
       }
      if { $state3 == 1 } { 
      set bluepieces {\u5C07 \u58EB  \u58EB  \u8C61 \u8C61 \u99AC \u99AC \u8ECA \u8ECA   \u7832   \u7832    

\u5352 \u5352 \u5352   \u5352 \u5352}
 set redpieces  {  0 \u5E25   \u4ED5 \u4ED5   \u76F8   \u76F8 \u99AC \u99AC \u8ECA \u8ECA      \u70AE  

\u70AE 

 \u5175  \u5175    \u5175     \u5175   \u5175  }  
     }
 
     }
    
     set ind 0
     set indx 0
     set baseline {list 1}
      proc K { x y } { set x }

     proc xpop { topper } {
     global liner 
     global ind indx 
     global bluepieces redpieces
     global baseline
     set topper [ lindex $bluepieces $ind ];
     if { $topper == "" } { 
     set topper [ lindex $redpieces $indx ]
     set indx [ expr { $indx + 1}]
       } 
     set ind [ expr { $ind + 1}]
     lappend $baseline $topper;
     return $topper;
     }
     set state2 1
          proc populateCanvas {w cols rows args} {
    global state2 state3
    gamepieces $args
    #refreshgrid  $w $state2 
    set state3 $args
    global ind indx
    variable ids ;# links text ids with respective rect ids
    variable boxes ;# lists text id and text associated with each rect id
    catch {unset ids boxes}
    set canvas $w
    
    # parameters for drawing boxes
    set boxwidth 50
    set boxheight 50
    set padx 3
    set pady 3
    set colors { orange yellow green  gray}
    set labels {one two three four}

    # draw the boxes
    for {set row 0} {$row < $rows} {incr row} {
      for {set col 0} {$col < $cols} {incr col} {

        # calculate coordinates
        set x1 [expr {$col * ($boxwidth + $padx) + $padx}]
        set x2 [expr {$x1 + $boxwidth}]
        set x3 [expr {$x1 + ($boxwidth / 2)}]
        set y1 [expr {$row * ($boxheight + $pady) + $pady}]
        set y2 [expr {$y1 + $boxheight}]
        set y3 [expr {$y1 + ($boxheight / 2)}]

        # choose color and text
        set color [lindex $colors [expr {int(rand() * [llength $colors])}]]
        #set text [lindex $labels [expr {int(rand() * [llength $labels])}]]
        # set text [xpop topper]
         set font2 [list Helvetica [expr $boxwidth/2]]

         set text "0"
         #set text "K"
         set texter [xpop 1 ]
         set tilename  [expr {int(rand()*1000000000.)}]
        # create the boxes
        set boxid [$w create oval $x1 $y1 $x2 $y2 \
          -fill $color -tags [concat mv rect $args  obj_$tilename]\
          -outline black]
        set colorfo blue
        if { $indx > 1 } {set colorfo red}
        #set textid [$w create text $x3 $y3 -font $font2 -fill $colorfo \
        #  -text $text -tags [concat mv  $args  obj_$tilename]  ]

         set textid [$w create text $x3 $y3 -font $font2 -fill $colorfo \
          -text $texter -tags [concat mv  $args  obj_$tilename ]  ]



        # remember which text item goes with which box and what the text says
        set boxes($boxid) [list $textid $text]
        set ids($textid) $boxid
        set ids($boxid) $boxid
      }
    }
  }  
     populateCanvas .cv 6 6 1 
     squarenames {1 2 3 }
      #end of deck
      #end of deck* 
       #end of deck
      #end of deck
      #end of deck
      #end of deck

    #end of deck
    #end of deck
   #end of deck
   #end of  deck
   #end of deck
   #end of deck
    #end of deck

test on chess and xiangqi fonts

     ***set bluepieces  {將士  士將  象 象 馬 馬 車 車   砲   砲    卒 卒卒   卒卒   ]#trad.    

     ***set redpieces  {  帥   仕  象 象  相   相 馬 馬 車 車 砲 砲   兵炮  炮  兵     兵     兵   兵   ] #trad

     ***set bluepieces  {王 王 王 象 象 马 马 车 车  炮 炮  典 典 典 典 典 典}***#simplified
     ***set redpieces  {王 王 王 象 象 马 马 车 车  炮 炮  典 典 典 典 典 典}***simplified
     set bluepieces {K A A E E H H R R C C P P P P P]#english letters
     set redpieces  {K A A E E H H R R C C P P P P P]#english letters

 babelfish gives炮

国王一般普通话大象马运输车大炮战士典当

 from

king general mandarin elephant horse chariot cannon soldier pawn,

   # probably need an if switch option for TCL lists  

     ***set bluepieces  [list  將士  士將  象 象 馬 馬 車 車   砲,  砲,   卒 卒卒   卒卒   ]#trad.    

     ***set redpieces  [list  帥   仕, 象 象  相   相 馬 馬 車 車 砲 砲   兵炮  炮  兵     兵     兵   兵   ] #trad


   將 King   士 士Adviser 車 車chaRiot   　  馬 馬Horse   炮  炮Cannon　     象象 Elephant卒　卒 卒 卒 卒Pawn

　帥 King 　仕　仕 Adviser 車車 chaRiot 　馬　馬 Horse 炮炮 Cannon　仕　仕 Elephant　兵兵兵兵兵 Pawn

     ***set bluepieces  [list 王 王 王 象 象 马 马 车 车  炮 炮  典 典 典 典 典 典]***#simplified
     ***set redpieces  [list 王 王 王 象 象 马 马 车 车  炮 炮  典 典 典 典 典 典]***simplified
     set bluepieces [list K A A E E H H R R C C P P P P P]#english letters
     set redpieces  [list K A A E E H H R R C C P P P P P]#english letters

♔','♕','♖','♗','♘','♙','♚','♛','♜','♝','♞','♟'

gummy version with purple highlights on moving pieces.

    #start of deck
        #start of deck
        #start of deck 
   #!/bin/sh

   #!/bin/sh
 # Restart with tcl: -*- mode: tcl; tab-width: 4; -*- \
 exec wish $0 ${1+"$@"}

 # demo2-canvas.tcl - HaJo Gurt - 2005-12-13 - https://wiki.tcl-lang.org/15073
 #: CanvasDemo: On button-click, draw something on the canvas
 # gold used canvas demo as base for TCL  chess display board.
 

        proc scr {w} {
        console show
        set  max 400
        set  may 400 
 for {set r 50} {$r < $max} {incr r 45} {
     for {set c 50} {$c < $max} {incr c 45} {
        set tilename  [expr {int(rand()*1000000000.)}]
  
         $w create oval $r $c [expr $r+5] [expr $c+5] -outline gray -fill green -width 1 \
         -tags [concat mv xdat_[expr $r+5]  ydat_[expr $c+5] obj_$tilename]
           puts " xdat_[expr $r+5]  ydat_[expr $c+5] obj_$tilename"
        set texter  "  [expr $r+5] [expr $c+5]  "
       $w create text [expr $r+5] [expr $c+20] \
          -text $texter -fill green -tags "  [expr $r+5] [expr $c+20]"

 }}}
 
   package require Tk

  proc ClrCanvas {w} {
    $w delete "all"
    $w configure  -bg white
  }

  proc DrawAxis {w} {
    set midX [expr { $::maxX / 2 }]
    set midY [expr { $::maxY / 2 }]
    $w create line 0     $midY  $::maxX   $midY  -tags "axis"
    $w create line $midX 0        $midX $::maxY  -tags "axis"
  }

  proc PaintText {w Txt} {
    global y
    incr y 10
    $w create text 100 $y -text $Txt -tags "text"
  }

  proc DrawBox {w} {
    global x1 y1 x2 y2
    $w create rect  50  50  100  90  -tags "box"
    $w create rect $x1 $y1  $x2 $y2  -tags "box"
    incr x1 15
    incr x2 15
    incr y1 10
    incr y2 10
  }

  proc DrawFn1 {w} {
    $w create line 0 100  50 200  100 50  150 70  200 155  250 50  300 111  350 222\
             -tags "Fn1"  -smooth bezier
  }

  proc DrawFn2 {w} {
    set offY 0    ;# [expr { $::maxY / 2 }]

    for { set x 0 } { $x <= $::maxX } { incr x 5 } {
      set y [expr { rand() * $::maxY + $offY }]

     #puts "$x $y"
      if {$x>0} { $w create line $x0 $y0 $x $y -tags "Fn2" }
      set x0 $x
      set y0 $y
    }
  }

  #: Main :
  frame .f1
  frame .f2
  pack  .f1 .f2

  set maxX 400
  set maxY 400
  set y      0

  set x1 120
  set x2 150
  set y1  50
  set y2  80

  canvas  .cv -width $maxX -height $maxY  -bg tan
  pack    .cv -in .f1
  button  .a0 -text "xiangqi" -command {set state2 1;set state3 1;board .cv;populateCanvas .cv 6 6 1   }
  button  .a1 -text "west*" -command {unset state3;set state3 3;board .cv;populateCanvas .cv 6 6 3   }
  button  .a2 -text "@" -command {unset state3;set state3 3;board .cv;populateCanvas .cv 6 6 2   }
  button  .a3 -text "&" -command {  ClrCanvas .cv;scr .cv   }
  button  .b0 -text "C" -command { ClrCanvas .cv }
  button  .b1 -text "Text"  -command { PaintText .cv "Chinese Xiangqi Chess" }
  button  .b2 -text "+"  -command { DrawAxis  .cv }
  button  .b3 -text "\[\]"   -command { DrawBox   .cv }
 
  button  .b6 -text "#dn"   -command { refreshgrid .cv 2 }   

  button  .b7 -text "#up"   -command { refreshgrid .cv 1 } 
  button  .b8 -text "#^"   -command {.cv scale all 0 0 1.1 1.1 }
  button  .b9 -text "#<"   -command {.cv scale all 0 0 .9 .9 }  
  button  .b10 -text "x"   -command { exit    }
   set info "000 000"
   label  .info -textvar info -just left
  pack .a0 .a1 .a2 .a3 .b0 .b1 .b2 .b3  .b6 .b7 .b8 .b9 .b10 .info -in .f2  -side left -padx 2

   #catch {console show}
   set oscwidth 1000 
 set oschorizontal 500 
 proc loop {from to body} {
    upvar 1 i i ;# make index visible in body
    for {set i $from} {$i<$to} {incr i} {uplevel 1 $body}
 }
   #-- And likewise, a shortcut for addition:
 proc + {a b} {expr {$a+$b}}
 
 #pack [canvas .cv -width 400 -height 500 ]

    # focus .cv 
 set state2 1
 proc refreshgrid { .cv state2} {
 global oscwidth oschorizontal colorite
 global grid
  global ind indx
  set ind 0
  set indx 0
    set colorite blue 
    for {set x 10} {$x<$oscwidth} {incr x 50} {.cv create line $x 0 $x $oschorizontal  -fill blue -tag grid -

width 4}
 for {set y 20} {$y<$oschorizontal} {incr y 50} {.cv create line 0 $y $oschorizontal $y -fill blue  -tag grid 

-width 4} 
 .cv itemconfigure grid -fill blue 

 if { $state2 == 1 } { .cv raise grid ;} 
 if { $state2 == 2 } { .cv lower grid ;} 
 }

  refreshgrid  .cv $state2 
 # next lines start withn periods, but hard to see
 . configure -borderwidth 0 -highlightthickness 0 -takefocus 0 -background aquamarine4
 . configure -background palegreen -highlightcolor DarkOliveGreen -relief raised -border 30

 . configure -background palegreen -highlightcolor DarkOliveGreen -relief raised -border 30
 . configure -width 1000 -height 2000

     .cv bind mv <ButtonRelease-1> {set info " %x %y ";
        catch {.cv itemconfigure [lindex $id 0] -outline black -width 1 }
    }

  .cv bind all <1> {set p(X) [.cv canvasx %x]; set p(Y) [.cv canvasy %y];set info " %x %y "}
 set haloo 50
 .cv bind mv <B1-Motion> {mv .cv %x %y}
 #.cv bind mv <ButtonRelease-1> {set info " %x %y ";puts " nearest [.cv find closest  %x %y $haloo ]"}
 #.cv bind moveable <ButtonPress-1> {item:move %W %x %y 1;set info " %x %y "}
      bind .cv <Motion> {wm title . "Xiangqi Chessboard [expr int( [%W canvasx %x])],[expr int ([%W canvasy 

%y])]"}

     proc mv {w x y} {
    global p id
    set x  [$w canvasx $x]
    set y  [$w canvasy $y]
    set id [$w find withtag current]
    set numberx [$w  gettags current]
    regexp {obj_(\d+)} $numberx -> tilex
    
    puts "1"
    puts $numberx
    puts $tilex
    puts " with tag [$w find withtag obj_$tilex ]"
    foreach item [$w find withtag obj_$tilex ] {
    $w move $item [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
    catch {$w itemconfigure [lindex $id 0] -outline purple -width 5 }
    #$w raise $id
    }
    puts " x y $x $y"
    #$w raise $id
    # $w move [$w find withtag "$tilex"] [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
    #set numberx [$w  gettags current]
    #regexp {obj_(\d+)} $numberx -> tilex
     catch {$w itemconfigure [lindex $id 0] -outline purple -width 5 }
    set p(X) $x; set p(Y) $y
 }

    proc board {w} {
    #set state3 1
    set state2 1
    ClrCanvas $w
    . configure -background orange -highlightcolor brown -relief raised -border 30
    $w configure -bg tan
    
    refreshgrid  .cv $state2 ;
    }
    
     proc squarenames {l} {
    console show
    set result {}
    set i [llength $l]
        set cc 0
        set rr 0
        foreach row {8 7 6 5 4 3 2 1} {
        set rowscreen [expr {$rr*50.}]
        foreach column {A B C D E F G H} {
        set colscreen  [expr {$cc*50.}]   
        lappend result   "$column$row $rowscreen $colscreen"
        incr cc 1
        incr rr 1
         }}
    puts $result
    return $result
    
   }
      
        #foreach row {8 7 6 5 4 3 2 1} {
        #foreach column {A B C D E F G H} {
        #    lappend res [" " "$column$row"]
        #puts "  $column$row "
       
    proc gamepieces {state3} {
     global bluepieces redpieces
     if { $state3 == 2 } { 
     set bluepieces [list K A A E E H H R R C C P P P P P]
     set redpieces  [list 0 K A A E E H H R R C C P P P P P]
       } 
     
    if { $state3 == 3 } { 
     #black western
     set bluepieces {  \u265A \u265B \u265C \u265C \u265D \u265D \u265E \u265E \u265F \u265F \u265F \u265F 

\u265F \u265F \u265F \u265F}  
     #white western
     set redpieces { 0  \u2654 \u2655 \u2655 \u2656  \u2656 \u2657 \u2657  \u2658 \u2658 \u2659 \u2659 \u2659 

 \u2659 \u2659 \u2659 \u2659 \u2659}  
       }
      if { $state3 == 1 } { 
      set bluepieces {\u5C07 \u58EB  \u58EB  \u8C61 \u8C61 \u99AC \u99AC \u8ECA \u8ECA   \u7832   \u7832    

\u5352 \u5352 \u5352   \u5352 \u5352}
 set redpieces  {  0 \u5E25   \u4ED5 \u4ED5   \u76F8   \u76F8 \u99AC \u99AC \u8ECA \u8ECA      \u70AE  \u70AE 

 \u5175  \u5175    \u5175     \u5175   \u5175  }  
     }
 
     }
    
     set ind 0
     set indx 0
     set baseline {list 1}
      proc K { x y } { set x }

     proc xpop { topper } {
     global liner 
     global ind indx 
     global bluepieces redpieces
     global baseline
     set topper [ lindex $bluepieces $ind ];
     if { $topper == "" } { 
     set topper [ lindex $redpieces $indx ]
     set indx [ expr { $indx + 1}]
       } 
     set ind [ expr { $ind + 1}]
     lappend $baseline $topper;
     return $topper;
     }
     set state2 1
          proc populateCanvas {w cols rows args} {
    global state2 state3
    gamepieces $args
    #refreshgrid  $w $state2 
    set state3 $args
    global ind indx
    variable ids ;# links text ids with respective rect ids
    variable boxes ;# lists text id and text associated with each rect id
    catch {unset ids boxes}
    set canvas $w
    
    # parameters for drawing boxes
    set boxwidth 50
    set boxheight 50
    set padx 3
    set pady 3
    set colors { orange yellow green  gray}
    set labels {one two three four}

    # draw the boxes
    for {set row 0} {$row < $rows} {incr row} {
      for {set col 0} {$col < $cols} {incr col} {

        # calculate coordinates
        set x1 [expr {$col * ($boxwidth + $padx) + $padx}]
        set x2 [expr {$x1 + $boxwidth}]
        set x3 [expr {$x1 + ($boxwidth / 2)}]
        set y1 [expr {$row * ($boxheight + $pady) + $pady}]
        set y2 [expr {$y1 + $boxheight}]
        set y3 [expr {$y1 + ($boxheight / 2)}]

        # choose color and text
        set color [lindex $colors [expr {int(rand() * [llength $colors])}]]
        #set text [lindex $labels [expr {int(rand() * [llength $labels])}]]
        # set text [xpop topper]
         set font2 [list Helvetica [expr $boxwidth/2]]

         set text "0"
         #set text "K"
         set texter [xpop 1 ]
         set tilename  [expr {int(rand()*1000000000.)}]
        # create the boxes
        set boxid [$w create oval $x1 $y1 $x2 $y2 \
          -fill $color -tags [concat mv rect $args  obj_$tilename]\
          -outline black]
        set colorfo blue
        if { $indx > 1 } {set colorfo red}
        #set textid [$w create text $x3 $y3 -font $font2 -fill $colorfo \
        #  -text $text -tags [concat mv  $args  obj_$tilename]  ]

         set textid [$w create text $x3 $y3 -font $font2 -fill $colorfo \
          -text $texter -tags [concat mv  $args  obj_$tilename ]  ]

        # remember which text item goes with which box and what the text says
        set boxes($boxid) [list $textid $text]
        set ids($textid) $boxid
        set ids($boxid) $boxid
      }
    }
  }  
     populateCanvas .cv 6 6 1 
     squarenames {1 2 3 }

gold This page is copyrighted under the TCL/TK license terms, this license .

Hidden Comments Section

arjen - 2010-06-29 03:31:13

Just a minor comment: the characters are simplified Chinese, I am not sure that is what you would encounter on a real chessboard.

gold# May just use English letters initially and switch for option of simplified or traditional characters.

gold 1jul2010, There are Xiangqi sets with simplified characters made in PRC, but probably not common elsewhere. Really lacking though, are specific unicode fonts for Xiangqi. Meanwhile code will make do with language fonts.

AMG: A note concerning the [list] command: It's not necessary to use [list] if none of the elements are the product of substitution. In other words, if the list will always have the same elements, you don't need the [list] command to construct the list. Instead simply surround the list with {braces}. Its internal representation will become list when it gets used as a list, since Tcl has duck typing. Similar goes for [dict create]. I mean, when you want a number, you just type the number, even though its initial internal representation will be string. It "becomes" a number when context shows that it is a number. You never see code that does this: set var [expr 5]; only this: set var 5.

Please place any comments here, Thanks.

gold 9/27/2021. Switched some comment signs ;# to #. This a big file. Check earlier editions, if not compatible. Maybe obvious, but this page was written on Windows10 Tcl ports including ActiveTCL. I assume that the reader can cut and paste on screen, what the reader needs, and tootle on to his own project and own contribution pages to the TCL Wiki.

Category Numerical Analysis