## Introduction

Here is some starter code for Chinese Fortune Casting Example Demo. The impetus for this calculator was checking some probabilities on the Chinese bronzes example. Its easy enough to plug in formulas/subroutines into the display formats on Game kingdom of Strategy and Chinese Iching Hexagrams on Chou Bronzes : TCL Example. Most of the checked testcases involve flipping two sided objects like coins or popsicle sticks or four sided rectangular dice, see pix below. This page is more an investigation into the mindset of the Chinese sages, using TCL visual and random subroutines.

In planning any software, it is advisable to gather a number of testcases to check the results of the program.

gold Changes.

## appendix TCL programs

```    ***FIRST VERSION***
#autoindent test from ased editor.
#:by gold,  Chinese Fortune Casting
# written on Windows XP on eTCL
# working under TCL version 8.5.6 and eTCL
# 1.0.1
# gold on TCL WIKI , 1apr2011
package require Tk
global bookvalue bookvalue2
set colorground bisque
set wow "bone number"
proc K { x y } { set x }
proc shuffle5 { list } {
set n 1
set slist {}
foreach item \$list {
set index [expr {int(rand()*\$n)}]
set slist [linsert \$slist \$index \$item]
incr n
}
return \$slist
}
proc lremove {_list el} {
upvar 1 \$_list list
set pos [lsearch -exact \$list \$el]
set list [lreplace \$list \$pos \$pos]
}
proc pi {args} [subst -novariable {
expr [expr {atan2(0,-1)}] \$args
}]
#wdb,usage [pi] [pi /4]
proc piesq {args} { set pie [pi] ; return [
expr sqrt(\$pie) ]}
proc geoseries1 {aa bb cc} { if {\$bb <= -1||\$bb >=
1} { return 0} ;return [ expr \$aa / ( 1 - \$bb ) ]};
proc box1 {aa bb } { set pie [pi]  ;return [ expr
sqrt((\$aa *  \$bb*4 )/ (\$pie))]}
proc stuffit {} {
set nums {1 2 3 4 1 2 3 4 }
set numnum  [lindex \$nums [expr {int(rand() *
[llength \$nums])}]]
lremove nums \$numnum
append  details "  "
append  details \$numnum
append  details "  "
return \$details
}
proc ? L {lindex \$L [expr {int(rand()*[llength
\$L])}]}
proc recipe {} {
set a {
{1} {2} {3}
{4} {5}
}
set b {
{1} {2}
{3}
{4} {5}
}
set c {1 2 3 4 5 6}
set d {
1 {2} 3v{4} 5 {6}
}
return "   1@ [? \$a].
[? \$b].
2@ [? \$c].
3@ [? \$d]."
}
proc ? L {
lindex \$L [expr {int(rand()*[llength \$L])}]
}
if 0 {This is used several times in:}
proc lpick L {lindex \$L [expr int(rand()*
[llength \$L])];}
#proc poly args {eval .cv create polygon \$args}
set lister { 5 5 6 6 6 6 6 6 7 7 7 7 8 8 1 1 1 1
1 1 1 1 1 }
proc clrcanvas {w} {
global counter winner5
\$w delete  "all"
.zzz delete  0 end
.xxx delete  0 end
.t delete 1.0 end
set counter 0
set winner5 0
set loser5 0
}
proc run {w} {
global side1 side2 results
.t delete 1.0 end
.t insert 1.0 "run test5"
}
proc consol {w} {
console show
puts "Chinese Fortune Casting "
}
proc leave {w} {
exit
}
proc board {w} {
#set state3 1
set state2 1
clrcanvas \$w
. configure -background orange -highlightcolor
brown -relief raised -border 30
\$w configure -bg tan
}
set msg "Chinese Fortune Casting.
from TCL WIKI,
written on eTCL
cmds take form
of  tcl "
}
#: Main :
frame .f1
frame .f2
frame .f3
pack  .f1 .f2 .f3
set maxX 400
set maxY 300
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
#set side2 2
button  .b0 -text "Coin_Toss" -command {
button  .b3 -text "Cast_Bones"   -command
button  .b5 -text "clear"   -command {clrcanvas
.cv;  }
button  .b6 -text "run script"   -command {
run .cv}
button  .b7 -text "clear"   -command {
clrcanvas .cv; }
button .b4 -text "console"   -command { consol
.cv; }
button  .b8 -text "exit"   -command {leave
.cv }
.cv }
text .t -width 40 -height 5 -bg bisque
entry .xxx -width 50  -bg bisque -textvariable
side1
entry .zzz -width 50 -textvariable side2 -bg
bisque
pack .b0 .b3 .b5  .b6 .b7 .b7 .b4 .b9 .b8  -in
.f2 configure  -bg orange
label .kingx  -text "entry language"
pack  .advisora .zzz .t   .kingx  .xxx -in .f3
focus .xxx
focus .zzz
board   .cv
wm title . "Chinese Fortune Casting "}
if {[file tail [info script]]==[file tail \$argv0]} {
package require Tk
#pack [text .t5 -width 40 -height 5]
bind .t  <1> {showRecipe %W; break}
proc showRecipe w {
\$w delete 1.0 end
\$w insert end [recipe]
}
showRecipe .t
}
set width 50
set height 50
set w ".can"
set x 100
set y 100
set dx 50
set dy 30
set colors {white black }
set color 0
proc lpick L {lindex \$L [expr {int(rand()*[llength
\$L])} ];}
# utilities
proc plainsub {text item replacewith} {
set text [string map [list \$item \$replacewith]
\$text]
}
proc %+ {a  } {return [string toupper \$a]; #%+
tree >TREE }
proc %- {a  } {return [string tolower \$a]; #%+
Tree >tree  }
proc %++ {a b} {return \$a\$b;#%+* tree root
>treeroot }
proc %-- {a b} {regsub \$b \$a "" a; return
\$a;#%-- 5 7>5 }
proc %% {a b} {regsub -all \$b \$a "";#%% tree
root  >tree }
proc %1 {a b} {regsub \$b \$a "" a; return \$a;#%1
tree root>tree }
proc %2 {a b} {regsub \$b \$a "" a;regsub \$b \$a ""
a; return \$a;#%2 tree root>tree }
proc %3 {a b} {regsub \$b \$a "" a;regsub \$b \$a
"" a;regsub \$b \$a "" a; return \$a;#%3 tree
root>tree}
proc %2x  {a} {return \$a\$a;#%2x tree>treetree}
proc %3x  {a} {return \$a\$a\$a;#%3x
tree>treetreetree}
proc %4x  {a} {return "\$a,\$a,\$a";#%5x
tree>tree,tree,tree }
proc %5x  {a} {return "\$a \$a \$a";#%5x
tree>tree tree tree }
proc repeat {n body} {while {\$n} {incr n -1;
uplevel \$body}}
proc random n {expr {round(\$n*rand())}}
proc whitelist {a} {return [lreplace \$a 0 -
1];#take string,return list without blanks}
set k [split {abcdefghijklmnopqrstuvwxyz} {}]
proc average L {expr ([join \$L +])/[llength
\$L].}
proc srevert s {
set l [string length \$s]
set res ""
while {\$l} {append res [string index \$s [incr l
-1]]}
set res
};# RS,
proc lreverse L {
set res {}
set i [llength \$L]
#while {[incr i -1]>=0} {lappend res [lindex \$L
\$i]}
while {\$i} {lappend res [lindex \$L [incr i -1]]}
;# rmax
set res
} ;# RS, tuned 10% faster by [rmax]
proc sumoflist  L {expr [join [split \$L ""] +]
+0} ;# RS
proc convertbase2to10 {jip} {
set l [split \$jip ""]
set t 0; set e 0;
foreach n \$l {
set exp [ expr int(pow(2,\$e))];
incr t [ expr \$n * \$exp  ] ;
incr e;
}
return \$t}
proc kvsearch {kvlist item} {
set pos [lsearch \$kvlist \$item]
if {\$pos != -1} {
lindex \$kvlist [expr {\$pos+1-2*(\$pos%2)}]
}
} ;# RS
# end utilities
#start iching data
set bookvalue  [ list  1  63  43  62  14  61  34
60  9  59  5 58 26  57  11  56  10  55  58  54  38
53  54  52  61  51 60  50 41  49  19  48 13  47  49
46  30  45  55  44  37  43  63  42  22  41  36  40
25  39  17  38  21  37  51  36  42  35  3  34  27
33  24  32  44  31  28  30  50  29  32  28  57  27
48  26  18  25  46  24  6  23  47  22  64  21  40
20  59  19  29  18 4 17  7  16  33  15  31  14  56
13  62  12  53  11  39 10  52  9  15  31  14  56  13
62  12  53  11  39  10 52  9  15 8 12   7  45  6
35  5  16  4  20  3   23  1  2  0 8 2 ]
set bookvalue2  [ list 9999 1  63  43  62  14  61
34  60  9  59  5 58 26  57  11  56  10  55  58  54
38  53  54  52  61  51 60  50 41  49  19 48  13  47
49  46  30  45  55  44  37  43  63  42  22  41  36
40  25  39  17  38  21  37  51  36  42  35  3  34
27  33  24  32  44  31  28  30  50  29  32  28  57
27  48  26  18  25  46  24  6  23  47  22  64  21
40  20  59  19  29  18 4 17  7  16  33  15  31  14
56  13  62  12  53  11  39 10  52  9  15  31  14  56
13  62  12  53  11  39  10 52  9  15 8 12   7  45
6  35  5  16  4  20  3   23  1  2  0 8 2 ]
if 0 { iching hexagrams and trigrams }
if 0 { Little API style database }
set  chartbamboo { " list
"  }
proc plainsub {text item replacewith} {
set text [string map [list \$item \$replacewith]
\$text] }
foreach piece { + : { } }  {
set  chartbamboo [ plainsub \$chartbamboo \$piece
"*" ]
}
set reading [ list [ split \$chartbamboo " " ]]
#end iching data
proc binaryexchange {gualisting} {
# converts gualisting as a list
# to binary & decimal numbers.
global dx dy colors color
set guabinary [ whitelist \$gualisting ];
set guabinary [ join [ split \$guabinary "
"]];
set guabinary [ plainsub \$guabinary 6 0 ];
set guabinary [ plainsub \$guabinary 7 1 ];
set guabinary [ plainsub \$guabinary 8 0 ];
set guabinary [ plainsub \$guabinary 9 1 ];
set guabinary [ plainsub \$guabinary " " "" ];
return \$guabinary;
}
proc second_hexagram_compute {gualisting } {
# subroutine under test
global bookvalue second_hexagram
#set gualisting [ lreverse \$gualisting];
set second_hexagram [ list ];
set second_hexagram  [ join \$gualisting ] ;
set second_hexagram [ plainsub
\$second_hexagram 6 7 ];
set second_hexagram  [ plainsub
\$second_hexagram 9 6 ];
set guabinary [ binaryexchange
\$second_hexagram ];
set decimalout [ convertbase2to10 \$guabinary
];
set bookgua [ kvsearch \$bookvalue \$decimalout
];
return \$bookgua;
}
global dx dy colors color gualisting reading
global bookvalue bookvalue2 second_hexagram
set dj 1;
set gualisting [list ];
if { \$coinsread == 1 } {
for {set j 0} {\$j<6} {incr j \$dj} {
set bone1 [lpick {3 3 3 2}]
set bone2 [lpick {3 3 2 2}]
set bone3 [lpick {3 3 2 2}]
set bonereading [expr \$bone1 + \$bone2 + \$bone3
]
set wow [expr \$bone1 + \$bone2 + \$bone3 ]
lappend gualisting \$wow;
}
}
if { \$coinsread == 2 } {
for {set j 0} {\$j<6} {incr j \$dj} {
set bone1 [lpick {3 3 2 2}]
set bone2 [lpick {3 3 2 2}]
set bone3 [lpick {3 3 2 2}]
set bonereading [expr \$bone1 + \$bone2 + \$bone3
]
set wow [expr \$bone1 + \$bone2 + \$bone3 ]
lappend gualisting \$wow;
}
}
#set guabinary [ list 1 0 1 1 1 si tiene
problema ]
set gualisting [ lreverse \$gualisting];
# reading hexagram lines top down,
# opposed to reverse(down top)
# give different binary values
#
set guabinary [ binaryexchange \$gualisting ];
set decimalout [ convertbase2to10 \$guabinary
];
set bookgua [ kvsearch \$bookvalue2
\$decimalout ];
set second_hexa [ second_hexagram_compute
\$gualisting ];
.t delete 1.0 end;
set outoutfoulspirit " last bone is \$wow .gua
listing is   \$gualisting && binary \$guabinary &&
decimal \$decimalout &&Iching_gua_# \$bookgua &&  test
2nd hex. \$second_hexagram && 2nd h. test
\$second_hexa && \$second_hexagram
.t insert end \$outoutfoulspirit
.t insert end [ stuffit ]
}
proc castfortune {} {
global dx dy colors color gualisting
second_hexagram
set colorx black;
for {set i 0; set y 0} {\$i<6} {incr i; incr y
\$dy} {
set colorx brown;
for {set j 0; set x 0} {\$j<3} {incr j; incr x
\$dx} {
set colorx brown;
if { \$j == 1} {
if { [lindex \$gualisting \$i ] == 6} {set
colorx tan}
if { [lindex \$gualisting \$i ] == 7} {set
colorx brown}
if { [lindex \$gualisting \$i ] == 8} {set
colorx tan}
if { [lindex \$gualisting \$i ] == 9} {set
colorx brown}
}
.cv create rectangle [expr {\$x + 40}]
[expr {\$y+50} ] [expr {\$x+\$dx+40}] [expr
{\$y+\$dy+50}]
-fill \$colorx
}}
set dx 50
set dy 30
set colorx blue;
for {set i 0; set y 0} {\$i<6} {incr i; incr y
\$dy} {
set colorx blue;
for {set j 0; set x 0} {\$j<3} {incr j; incr x
\$dx} {
set colorx blue;
if { \$j == 1} {
if { [lindex \$second_hexagram \$i ] == 6}
{set colorx tan}
if { [lindex \$second_hexagram \$i ] == 7}
{set colorx blue}
if { [lindex \$second_hexagram \$i ] == 8}
{set colorx tan}
if { [lindex \$second_hexagram \$i ] == 9}
{set colorx blue}
}
.cv create rectangle [expr {\$x + 220}]
[expr {\$y+50}] [expr {[expr {\$x +220} ]+\$dx}] [expr
{\$y+\$dy+50}]
-fill \$colorx
}}
}

```