***FIRST VERSION*** 

      #start of deck
       #start of deck  
     #start of deck
       #start of deck
      #start of deck

        #start of deck  
        #start of deck


 #: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

          }}

     }




    #end of deck
    #end of deck
      #end of deck
      #end of deck      
      #end of deck
    #end of deck


*bonus console program*

     rank of indiv. "throws" over all "throws".
     pi mantissa used here
     proc calculation {  facen }  { 
     # prob. subroutines for mimic sequence of bronze 
     # prob. is throw combos of eg. "7" over all possible throws
     
 set lister [split {14159265358979323846264338327950288419716939937} ""]
 
     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