**Chinese Fortune Casting Example Demo**----
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 in your comment with the same courtesy that I will give you. Its very hard to reply intelligibly without some background of the correspondent. Thanks,[gold]
----
<<This page is under development. OComments 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 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.
----
----
**Comments Section**
Please place any comments here, Thanks.
[gold] Changes.
----
**References**
* [factorial]
* [Slot_Calculator_Demo]
* [Game kingdom of Strategy]
* [Chinese Iching Hexagrams on Chou Bronzes : TCL Example]
* [Iching_Fortunes]
* [Binomial Probability Slot Calculator Example]
* [Chinese Iching Random Weather Predictions]
**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
}
proc about {w} {
set msg "Chinese Fortune Casting.
from TCL WIKI,
written on eTCL
cmds take form
of tcl "
tk_messageBox -title "About" -message $msg
}
#: 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 {
bonereadxx 2;castfortune;}
button .b3 -text "Cast_Bones" -command
{bonereadxx 1 ;castfortune; }
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 }
button .b9 -text "about" -command {about
.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 -side left -padx 2
.f2 configure -bg orange
label .kingx -text "entry language"
label .advisora -text "advisor"
pack .advisora .zzz .t .kingx .xxx -in .f3
-side bottom -padx 2
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
global guabinary guadecimal guatransform
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;
}
proc bonereadxx {coinsread} {
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
$reading "
.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
}}
}
======
----
[gold] This page is copyrighted under the TCL/TK license terms, [http://tcl.tk/software/tcltk/license.html%|%this license].
**Comments Section**
Please place any comments here, Thanks.
<<discussion>>
<<categories>> Numerical Analysis | Toys | Calculator | Mathematics| Example| Toys and Games | Games | Application | GUI
----
<<categories>> Development | Concept| Algorithm