Version 79 of 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 middle of the page. Thanks,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.  I installed
 a version of the code in the Simple Canvas Demo for some pictures.
  Also I made a lengthy list of 60 line creations in TCLpaint,but
  we better 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
  taqgged 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 outputing
 the mouse up and down coordinates for the screen.

Screenshots Section

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*

  http://rishida.net/tools/conversion/, outstanding unicode conversion online!!!

http://mayoneez.1g.fi/hiddenlynx/index.html http://www.chessvariants.org/graphics.dir/big5/index.html

http://geert.vanderkelen.org/2009/12/chessboard-in-mysql.html

  http://pinyin.info/tools/converter/chars2uninumbers.html

http://en.wikipedia.org/wiki/Miscellaneous_Symbols_Unicode_block

 http://wiki.tcl.tk/884
   http://wiki.tcl.tk/15073

http://wiki.tcl.tk/884 http://wiki.tcl.tk/9493 http://wiki.tcl.tk/14255 http://99.237.250.152/xq/book/xiangqi_printset.pdfunicode

http://www.yutopian.com/chinesechess/chrules.pdf

appendix TCL programs

FIRST VERSION

 #start of deck#start of deck
        #start of deck
        #start of deck
        
 
 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 - http://wiki.tcl.tk/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****
 #!/bin/sh
 # Restart with tcl: -*- mode: tcl; tab-width: 4; -*- \
 exec wish $0 ${1+"$@"}

 # demo2-canvas.tcl - HaJo Gurt - 2005-12-13 - http://wiki.tcl.tk/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 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 "}
 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 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
***minimal example of linked movement on canvas***
  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 second
  .cv create rect 10 110 50 90 -fill yellow -tag second

   .cv bind movable <Button-1> {grab %x %y }
  .cv bind movable <B1-Motion> {move .cv %x %y }
   #end of deck
    #end of deck
   #end of deck
   #end of  deck
   #end of deck
   #end of deck
    #end of deck

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.

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 highlights on moving pieces.

 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 mv <ButtonRelease-1> {
        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}

 .cv bind mv <B1-Motion> {mv .cv %x %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)}]
    #$w raise $id
    catch {$w itemconfigure [lindex $id 0] -outline purple -width 5 }
    }
    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
    catch {$w itemconfigure [lindex $id 0] -outline purple -width 5 }
 }






     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 -width 1 ]
        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