**Chinese Fortune Casting Example Demo**

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 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. 
    

----  

**Screenshots Section**
[http://farm5.static.flickr.com/4122/4866853039_0a6798b1f8.jpg]
[http://farm5.static.flickr.com/4133/4837907275_4863aa5764.jpg]
[http://farm5.static.flickr.com/4136/4812522943_33727ff8ec.jpg]
[http://farm5.static.flickr.com/4114/4812413403_e697523a46.jpg]
[http://farm5.static.flickr.com/4098/4818003683_be9dddea77.jpg]
[http://farm5.static.flickr.com/4123/4821292691_35da154995.jpg] 

  
----
**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 Windowws XP on eTCL
    # working under TCL version 8.5.6 and eTCL
    1.0.1
    # gold on TCL WIKI , 1Aug2011
    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
    bind . <Motion> {wm title . "Chinese Fortune
        Casting "}
    #end of deck
    #end of deck
    #end of deck
    #end of deck
    #end of deck
    #end of deck
    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
        }}
}


  ***FIRST VERSION***         
        #autoindent test from ased editor.

        #:by gold,  Chinese Fortune Casting
        
        # written on Windowws XP on eTCL
        # working under TCL version 8.5.6 and eTCL
        
        1.0.1
        # gold on TCL WIKI , 1Aug2011
        
        
        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
        
        bind . <Motion> {wm title . "Chinese Fortune
            
            Casting "}
        
        #end of deck
        #end of deck
        #end of deck
        #end of deck
        #end of deck
        #end of deck
        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
                
            }}
        
    }
    
 *bonus console program*

               #rank of indiv. "throws" over all "throws".
               #pi mantissa used here
               #autoindent test from ased editor.
   console show
            proc calculation {  facen }  {
                # prob. subroutines for mimic sequence of bronze
                # prob. is throw combos of eg. "7" over all possible throws
                
                set lister [split {14159265358979323846} ""]
                
                set ee [llength  $lister ]
                set kk [ llength [ lsearch -all $lister $facen ] ]
                set prob [ expr { ($kk*1.) / $ee  } ]
                return $prob
            }
            set limit 12
            for { set i 1 } { $i <= $limit }  { incr i } {
                lappend listxxx $i
                lappend listxxx [ calculation  $i ]
                puts " $i [ calculation  $i ] "
            }
            #end
            

results for first 20 numbers of pi mantissa
 1 0.1 
 2 0.1 
 3 0.15 
 4 0.1 
 5 0.15 
 6 0.1 
 7 0.05 
 8 0.1 
 9 0.15 
results for small numbers of pi mantissa
 1 0.0851063829787234 
 2 0.10638297872340426 
 3 0.1702127659574468 
 4 0.0851063829787234 
 5 0.0851063829787234 
 6 0.0851063829787234 
 7 0.0851063829787234 
 8 0.10638297872340426 
 9 0.1702127659574468 
results for 100k numbers of pi mantissa
 1 0.1000947923455181 
 2 0.09782372573414697 
 3 0.0989790074451488 
 4 0.09843592629895136 
 5 0.09899875585046508 
 6 0.09899875585046508 
 7 0.09898888164780693 
 8 0.09852479412287458 
 9 0.09777435472085629 




======
 
<<categories>> Toys | Example | Calculator | Mathematics