Chinese Fortune Casting Example Demo

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



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.



Comments Section

Please place any comments here, Thanks.

gold Changes.


References

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 "   [email protected] [? $a].
        [? $b].
        [email protected] [? $c].
        [email protected] [? $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, this license .

Comments Section

Please place any comments here, Thanks.