***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
        }}
}