Updated 2017-03-26 17:12:18 by gold

Sumerian Counting Boards, multiplication operation placement strategy, and eTCL demo example, numerical analysis  edit

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 edit

gold Here is some eTCL starter code for a Sumerian counting board. Transforming some old chess displays into a Sumerian counting board, should have better counting pieces soon.

If a token or coin is dropped on a square, then total of the coins on the square or within certain range of the dropped coin is tallied. The columns were thought to represent powers of 60 and the addition operations were down the columns. There were several types of Sumerian counting boards and not limited to three columns. For three columns, the highest number was expr(59*60+5*10+9). A multiplication feature might have to group coins on square a and multiply times the group on square b. The Sumerian counted in base60, so each token or column should have a base60 value of 3600,60,10,1,plus possible fractions 1/60, 1/3600. In proto-cuneiform math, some tokens represented lamb, goat, or ox. The tokens are kept in a storage box and may be thrown away in a separate trash area. 2 "memory storage areas" have been considered, maybe group and grab to staging areas. Ref DeSegnac paper.

As a debug, a console window is opened and the various token motions and operations are posted to the console (for cut and paste to text editor). Info should have token name, numeric value, random object tag, and screen position. Additional info could include values and tallies of neighboring chips. As understood here, multiplication operations are the side panels operating on the center panel, which may include reciprocals of previous calculations. Using double-click to calculate value of tokens on squares and output same on opened console window. not sure how to initiate operations on screen but automatic operations per square*square on double-click seem possible.

The token symbol and token background are created with canvas text, then the tokens are retagged both with rand number tag and token worth tag to move jointly. With the logic on color (gold color), I trying to drop the worth_token ( value eg, 3600,60,1,1/60) on the background token. I only want to count value tokens, otherwise get twice the value. The logic on the fill color is sticking or evaled as zero.

The earliest counting tokens were about 10000 BP. The heyday of counting tokens was about 5500 years BP. Ref. Schmandt-Besserat

Pseudocode Section edit

       # using pseudocode 
       # possible problem instances,  
      initialize algorithm_result = 1.
      assign value or storage array to various tokens.
      about 150 known tokens from various eras, loaded 5 or 6
      tally worth of picked tokens from storage box area.
      herd number of cows = N cow tokens
      herd number of bulls = N bull tokens     
      assign unique random tag to move items on canvas
      within square, add adjacent tokens from assigned values
      from squares above, add tally.
      from squares above, subtract square_a minus square_b for tally
      store to third square?
      from square a and square b on adjacent sides, multiply contents 
      put in square c in center
      how to reciprocate a stack of positive chips?
      are negative chips possible on counting board?
      # answer, yes on China stick numbers.
      save? tally to memory to one of 2 storage areas
      drag unwanted tokens to waste basket,
      but waste basket sticking and need extra brain power (from wiki ask?).
      check algorithm 
      check_sum = a+b+c+d+e  
      set answers and printout with resulting values 
      pseudocode: need test cases > small,medium, giant 
      pseudocode: need testcases within range of expected operation.
      pseudocode: are there any cases too small or large to be solved?

Testcases Section

In planning any software, it is advisable to gather a number of testcases to check the results of the program.

Testcase 1

table 1printed in tcl wiki format
quantity value comment, if any
worth= 3600. tag = lamb tally_total= 3600.0
worth= 60. tag = jar_oil tally_total= 3660.0
worth= 10. tag = goat tally_total= 3670.0
worth= 1. tag = ingot tally_total= 3671.0
worth= .01666 tag = garment tally_total= 3671.016659
worth= .0002777 tag = cow_bull tally_total= 3671.016937

Testcase 2

table 2printed in tcl wiki format
quantity value comment, if any
worth= .0002777 tag = cow_bull tally_total= 0.0002776
worth= .01666 tag = garment tally_total= 0.0169377
worth= 1. tag = ingot tally_total= 1.016937
worth= 10. tag = goat tally_total= 11.0169377
worth= 60. tag = jar_oil tally_total= 71.0169377
worth= 3600. tag = lamb tally_total= 3671.0169
worth= 3600. tag = lamb tally_total= 7271.0169
worth= 60. tag = jar_oil tally_total= 7331.01693
worth= 10. tag = goat tally_total= 7341.0169
worth= 1. tag = ingot tally_total= 7342.0169377
worth= .01666 tag = garment tally_total= 7342.03359
worth= .0002777 tag = cow_bull tally_total= 7342.0338

Testcase 3

table 3printed in tcl wiki format
quantity value comment, if any
worth= .01666 tag = garment tally_total= 0.01666
worth= 1. tag = ingot tally_total= 1.016659
worth= 1. tag = ingot tally_total= 2.016659
worth= 10. tag = goat tally_total= 12.01666
worth= 60. tag = jar_oil tally_total= 72.01666
worth= 10. tag = goat tally_total= 82.01666
worth= 60. tag = jar_oil tally_total= 142.01666

Testcase 4

Product of selected doubleclick point and nearest point should be associative. Here p1*p2 = 12960000 and p2*p1 = 12960000, recorded in output from console window. Terms in canvas tags for value_ regular expressions seem to be working.
&|worth= |3600. | tag = lamb | tally_total= |3600.0|&
&|worth= |3600. | tag = lamb | tally_total= |7200.0|&
selected double click point mv xdat_81 ydat_205 obj_98569283 # value_3600. current 
nearest entity 33 mv xdat_81 ydat_205 obj_98569283 # value_3600. current
product of adjacent tokens 3600 X 3600 12960000 
1
mv xdat_169 ydat_199 obj_674367737 # value_3600. current
674367737
 with tag 30 31
 x y 176.0 204.0
selected double click point mv xdat_169 ydat_199 obj_674367737 # value_3600. current 
nearest entity 31 mv xdat_169 ydat_199 obj_674367737 # value_3600. current
product of adjacent tokens 3600 X 3600 12960000 

Screenshots Section

figure 1. trial counting board

figure 2.trial counting board 2

figure 3.trial counting board (2*2=4)


References:

  • Possible old Babylonian computing paths some minor observations
  • D. A. R. DeSegnac, 10Mar2017, shows possible counting boards
  • Oneliner's Pie in the Sky
  • One Liners
  • Canvas item selection by mouse click [brusch] used here,
  • Category Algorithm
  • Simple Canvas Demo by HJG used here
  • canvas -highlightcolor Used here. Robert Heller
  • provided sample of how to use the canvas's -highlightcolor option
  • slightly corrected by Jeff Hobbs
  • Canvas lasso selection by RLE, under consideration
  • see similar 1/(1/nth) terms method used in
  • Babylonian Combined Market Rates and eTCL demo example calculator, numerical analysis
  • Proust, Christine "Du calcul flottant en Mésopotamie",
  • La Gazette des Mathématiciens2015-0910,” English version available, 2013
  • Halloran, John Alan “Early Numeration – Tally Sticks,
  • Counting Boards, and Sumerian ProtoWriting,” August 10, 2009,
  • Nissen et al.: Archaic Bookkeeping : Early Writing and
  • Techniques of Economic Administration in the Ancient Near East, Chicago and London, 1993
  • Hoyrup, Jens: A Note on Old Babylonian Computational Techniques,
  • Historia Mathematica 29 (2002), 193–198
  • Mathematical Treasure: Mesopotamian Accounting Tokens, Frank J. Swetz , Pennsylvania State University
  • Reckoning Before Writing by Denise Schmandt-Besserat
  • (Archaeology. May/June 1979, Vol. 32, No. 3, p. 22-31).
  • Numbers and Measures in the Earliest Written Records, Jöran Friberg.
  • Scientific American. February 1984. Volume 250. Number 2. Pages 110-118
  • Schmandt-Besserat, Denise. The Earliest Precursor of Writing ,
  • in Scientific American, June 1977, Vol. 238, No. 6, p. 50-58.
  • Schmandt-Besserat, Denise. Reckoning Before Writing,
  • in Archaeology. May/June 1979, Vol. 32, No. 3, p. 22-31.
  • Schmandt-Besserat, Denise. Two Precursors of Writing:
  • Plain and Complex Tokens», in The Origins of Writing
  • edited by Wayne M. Senner. 1991: 27-41.
  • Ancient Computers Part I - Rediscovery, Stephen Kent Stephenson

Appendix Code edit

appendix TCL programs and scripts

Initial code edit

                # pretty print from autoindent and ased editor
                # Sumerian counting board Strategy
                # working under TCL version 8.5.6 and eTCL 1.0.1
                # program written on Windows XP on eTCL
                # gold on TCL WIKI, 10Mar2017
                package require Tk
                package require math::numtheory
                namespace path {::tcl::mathop ::tcl::mathfunc math::numtheory }
                set tcl_precision 17
                #! /bin/env tclsh
                console show
                global  xx1 yy2 xxx1 tally_picks
                set tally_picks 0 
                set grab 0
                set filex  ""
                set colorit blue
                set coloritx gold
                set xx 50
                set yy 50
                set xxx1 50
                set yyy1 50
                array set worth {lamb 3600. jar_oil 60. goat 10. ingot 1. garment .01666 cow_bull .0002777}
                set font9 { Helvetica 20}
                set font10 { Helvetica 40}
                proc wastebasket {w} {
                    set font9 { Helvetica 50}
                    $w  create rectangle 350 550 500 600 -fill beige -tag grid
                    $w  lower grid                    
                }                
                proc tokenize_lamb {tag} {
                    global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .c create text [+ $xxx1 355 ] [+ $yyy1 35 ] -text "\u26AB" -font $font10  -fill $coloritx -tags $tag
                .c create text [+ $xxx1 355 ] [+ $yyy1 35 ] -text "\u2638" -font $font9  -fill $colorit -tags $tag
                }                
                proc tokenize_jar_oil {tag} {
                         global font9 font10 colorit coloritx xx yy xxx1 yyy1
 .c create text [+ $xxx1 355] [+ $yyy1 78 ] -text "\u26AB" -font $font10 -fill $coloritx -tags $tag
 .c create text [+ $xxx1 355] [+ $yyy1 78 ] -text "\u2617" -font $font9  -fill $colorit -tags $tag
                }                
                proc tokenize_goat {tag} {
                    global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .c create text [+ $xxx1 355] [+ $yyy1 127] -text "\u26AB" -font $font10 -fill $coloritx -tags $tag
                .c create text [+ $xxx1 355] [+ $yyy1 127] -text "\u2744" -font $font9 -fill $colorit -tags $tag
                }                
                proc tokenize_ingot {tag} {
                                  global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .c create text [+ $xxx1 355] [+ $yyy1 182] -text "\u26AB" -font $font10  -fill $coloritx  -tags $tag
                .c create text [+ $xxx1 355] [+ $yyy1 182] -text "\u26AB" -font $font9  -fill $colorit  -tags $tag
                }                
                proc tokenize_garment {tag} {
                          global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .c create text [+ $xxx1 355] [+ $yyy1 243] -text "\u26AB" -font $font10  -fill $coloritx -tags $tag
                .c create text [+ $xxx1 355] [+ $yyy1 243] -text "\u2616" -font $font9  -fill $colorit -tags $tag
                }                
                proc tokenize_cow_bull {tag} {
                     global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .c create text [+ $xxx1 355]  [+ $yyy1 303] -text "\u26AB" -font $font10  -fill $coloritx -tags $tag
                .c create text [+ $xxx1 355]  [+ $yyy1 303] -text "\u2735" -font $font9  -fill $colorit -tags $tag
                }                                
                set state2 1
                proc refreshgrid { w state2} {
                    global oscwidth oschorizontal colorite
                    global grid
                    global ind indx
                    set ind 0
                    set indx 0
                    set colorite blue
                    . configure -background orange -highlightcolor brown -relief raised -border 30
                    $w configure -bg tan
                    set dx 100    ;# pixels between adjacent vertical grid lines
                    set dy 100    ;# pixels between adjacent horizontal grid lines
                    set x0 50    ;# pixels between left of canvas and left of grid
                    set y0 50   ;# pixels between top of canvas and top of grid
                    #set win $w   ;# name of canvas widget
                    $w  create rectangle 350 50 500 500 -fill beige -tag grid
                    $w  lower grid
                    foreach i {0 3} {
                        $w create line [expr {$i * $dx + $x0}] $y0\
                                [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}] -width 2 -fill green -tag grid
                    }
                    for {set i 1} {$i < 4} {incr i} {
                        $w create line [expr {$i * $dx + $x0}] $y0\
                        [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}] -width 2 -fill blue -tag grid
                        }
                    for {set i 0} {$i < 10} {incr i} {
                        $w create line $x0 [expr {$i * $dy + $y0}]\
                        [expr {3 * $dx + $x0}] [expr {$i * $dy + $y0}] -width 2 -fill purple -tag grid
                        }
                        }                
                proc take_token {tag x y} {
                    global tokenx tokeny
                    set tokenx $x
                    set tokeny $y
                    tokenize_$tag token
                    .c raise token
                    .c bind $tag <B1-Motion> {drag_token %x %y}
                    .c bind $tag <ButtonRelease-1> "drop_token $tag %x %y"
                    }                
                proc drag_token {x y} {
                    global tokenx tokeny
                    .c move token [expr {$x - $tokenx}] [expr {$y - $tokeny}]
                    set tokenx $x
                    set tokeny $y
                    }                
                proc drop_token {tag x y} {
                    global grab worth numis xx1 yy2 xxx1 tally_picks
                    #.c delete token
                    set tally_picks [+ $tally_picks $worth($tag)]  
                    puts " &|worth= |$worth($tag) | tag = $tag | tally_total= |$tally_picks|&"
                    set tilename  [expr {int(rand()*1000000000.)}]
                    .c itemconfigure token  -tag [concat mv xdat_$x  ydat_$y obj_$tilename # value_$worth($tag) ]
                    }  
                   proc onDblClick {x y} {
                   set x [.c canvasx $x] ; set y [.c canvasy $y]
                   set i [.c find closest $x $y]
                   set t [.c gettags $i]
                   set u [.c gettags current]
                   puts "selected double click point $u "  
                   puts "nearest entity $i $t"
                   set number1 1.
                   set number2 1.
                   set numberx $t
                   regexp {value_(\d+)} $u -> number1
                   regexp {value_(\d+)} $numberx -> number2
                   puts "product of adjacent tokens $number1 X $number2 [* $number1 $number2 ] "
                   set cumulative_product 1.
                   set cumulative_sum 0.
                   set numero 1.
                   puts "selected double click point $u "  
                   puts "nearest entity $i $t"
                   puts " rectangular enclosure  [ .c find enclosed $x $y [+ $x 100 ] [+ $y 100 ] ]  "
                   puts " rectangular enclosure split [split [ .c find enclosed $x $y [+ $x 100 ] [+ $y 100 ] ] ] "
                   foreach item [split [ .c find enclosed $x $y [+ $x 100 ] [+ $y 100 ] ] ]   {
                   puts " .c gettags $item [.c gettags $item ]"
                   set tx ""
                   set tx $item
                   regexp {value_(\d+)} [.c gettags $item ] -> numero
                   puts " numero $numero "
                   set cumulative_product [* $cumulative_product $numero]
                   set cumulative_sum [+ $cumulative_sum $numero]
                   puts "cumulative_sum $cumulative_sum"
                   puts "cumulative_product $cumulative_product" 
                    }
                   set number1 1.
                   set number2 1.
                   set numberx $t
                   regexp {value_(\d+)} $u -> number1
                   regexp {value_(\d+)} $numberx -> number2
                   puts " number1 number1 $number1 $number2" 
                   puts "product of adjacent tokens $number1 X $number2 [* $number1 $number2 ] "
                   }             
                wm withdraw .
                wm geometry . 600x800
                wm resizable . 0 0                
                pack [canvas .c -width 600 -height 800 -bg orange ]                
                tokenize_lamb lamb
                .c bind lamb <ButtonPress-1> {take_token lamb %x %y}
                tokenize_jar_oil jar_oil
                .c bind jar_oil <ButtonPress-1> {take_token jar_oil %x %y}
                tokenize_goat goat
                .c bind goat <ButtonPress-1> {take_token goat %x %y}
                tokenize_ingot ingot
                .c bind ingot  <ButtonPress-1> {take_token  ingot %x %y}
                tokenize_garment garment
                .c bind garment  <ButtonPress-1> {take_token  garment %x %y}                
                tokenize_cow_bull cow_bull
                .c bind cow_bull  <ButtonPress-1> {take_token  cow_bull %x %y}                
                .c bind all <1> {set p(X) [.c canvasx %x]; set p(Y) [.c canvasy %y];set info " %x %y "}
                set haloo 50
                .c bind mv <B1-Motion> {mv .c %x %y}
                bind .c <Double-1> { onDblClick %x %y }
                .c bind mv <ButtonRelease-1> { crasher .c }
                proc crasher {w} {
                    foreach  item [$w  find overlapping  400 500 450 600 ] {
                        if {[$w type $item]=="oval"} {$w delete $item}
                        if {[$w type $item]=="text"} {$w delete $item}
                    }
                    }                
                proc mv {w x y} {
                    global p id
                    set x  [$w canvasx $x]
                    set y  [$w canvasy $y]
                    set id [$w find withtag current]
                    set numberx [$w  gettags current]
                    regexp {obj_(\d+)} $numberx -> tilex                    
                    puts "1"
                    puts $numberx
                    puts $tilex
                    puts " with tag [$w find withtag obj_$tilex ]"
                    foreach item [$w find withtag obj_$tilex ] {
                        $w move $item [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
                        
                    }
                    puts " x y $x $y"
                    if { $y >= 20 && $y <= 70 } {
                        if { $x >= 20 && $x <= 70 } {$w delete obj_$tilex }
                    }                    
                    foreach  item [$w  find overlapping  400 500 550 600 ] {                        
                        if {[$w type $item]=="oval"} {$w delete $item}
                        if {[$w type $item]=="text"} {$w delete $item}
                    }                    
                    set p(X) $x; set p(Y) $y
                }
                wastebasket .c
                refreshgrid .c state2
                wm title . " Sumerian Counting Board Strategy "                
                after idle wm deiconify .
                .c configure -background orange -highlightcolor brown -relief raised -border 30
                .c configure -bg tan
               #end of file

Under test, many additions

                # pretty print from autoindent and ased editor
                # Sumerian counting board Strategy
                # working under TCL version 8.5.6 and eTCL 1.0.1
                # program written on Windows XP on eTCL
                # gold on TCL WIKI, 10Mar2017
                package require Tk
                package require math::numtheory
                namespace path {::tcl::mathop ::tcl::mathfunc math::numtheory }
                set tcl_precision 17
                # demo2-canvas.tcl - HaJo Gurt - 2005-12-13 - http://wiki.tcl.tk/15073
                #: CanvasDemo: On button-click, draw something on the canvas
                package require Tk
                set halo 2
                global  xx1 yy2 xxx1 tally_picks infox
                set tally_picks 0 
                set tallysum 0.
                set grab 0
                set filex  ""
                set colorit blue
                set coloritx gold
                set xx 50
                set yy 50
                set xxx1 50
                set yyy1 50
                array set worth {lamb 3600. jar_oil 60. goat 10. ingot 1. garment .01666 cow_bull .0002777}
                set font9 { Helvetica 20}
                set font10 { Helvetica 40}
                set font12 { Helvetica 10 bold}       
                proc item:upd {w} {
                    $w itemconfigure object -outline {}
                    $w itemconfigure hover -outline red -width 5
                    $w itemconfigure moveit -outline purple -width 5
                }
                proc item:move {w x y {init 0}} {
                    global oldx oldy
                    if $init {
                        set oldx $x; set oldy $y
                        $w addtag moveit closest $x $y $::halo
                        $w dtag !moveable moveit
                        $w raise moveit
                    } else {
                        $w move moveit [expr $x-$oldx] [expr $y-$oldy]
                        set oldx $x; set oldy $y
                    }
                    item:upd $w
                }
                proc item:endmove {w x y} {
                    $w dtag moveit
                    item:upd $w
                }
                proc item:hover {w x y st} {
                    if $st {
                        $w addtag hover closest $x $y $::halo
                        $w dtag !moveable hover
                    } else {
                        $w dtag hover
                    }
                    item:upd $w
                }
                proc item:toggletag {w x y tag} {
                    set ttt tagtotoggle
                    $w addtag $ttt closest $x $y $::halo $tag
                    if {[lsearch [$w gettags $ttt] $tag] >= 0} {
                        $w dtag ($ttt&&$tag) $tag
                        item:hover $w $x $y 0
                    } else {
                        $w addtag $tag withtag ($ttt&&!$tag)
                        item:hover $w $x $y 1
                    }
                    $w dtag $ttt
                }
                proc ClrCanvas {w} {
                    $w delete "all"
                }
                proc DrawAxis {w} {
                    #set midX [expr { $::maxX / 2 }]
                    #set midY [expr { $::maxY / 2 }]
                    set midX [expr { $::maxX / 2 }]
                    set midY [expr { $::maxY / 2 }]                    
                    $w create line 0     $midY  [expr $::maxX+80]   $midY  -tags "axis" -width 2
                    $w create line $midX 0        $midX $::maxY  -tags "axis" -width 2
                }
                proc PaintText {w Txt} {
                    global y
                    incr y 30
                    $w create text 40 $y -text $Txt -tags "text"
                    $w create text 384 426 -text "trash" -tags "green wastebasket"
                    $w create text 384 41 -text "token storage" 
                    $w create text 111 41 -text "3600" -tags "column label 3600"
                    $w create text 216 41 -text "60" -tags "column label 60"
                    $w create text 313 41 -text "1" -tags "column label 1"
                    #$w create text 384 450 -text "memory storage area 1 " 
                    #$w create text 384 480 -text "memory storage area 2 " 
                }
                proc mint {w } {
                    catch {console show}
                    $w create oval 150  110 170   130 -width 2 -fill red -outline gray -tags {object moveable};
                    puts "test"
                }
                proc DrawBox {w} {
                    global x1 y1 x2 y2
                    $w create rect  50  200  100  80  -tags "box"
                    $w create rect $x1 $y1  $x2 $y2  -tags "box"
                    incr x1 15
                    incr x2 15
                    incr y1 10
                    incr y2 10
                }
                    proc gamegrid {w} {
                        global x1 y1 x2 y2
                        global randomcolor board
                        populateCanvas $w 8 8
                        #$w create rect  50  200  100  80  -tags "box"
                        #$w create rect $x1 $y1  $x2 $y2  -tags "box"
                        incr x1 15
                        incr x2 15
                        incr y1 10
                        incr y2 10
                        $w create line  50  50 350  50 -width 2 
                        $w create line 100 100 300 100 -width 2 
                        $w create line 150 150 250 150 -width 2
                        $w create line  50 200 150 200 -width 2
                        $w create line 250 200 350 200 -width 2
                        $w create line 150 250 250 250 -width 2
                        $w create line 100 300 300 300 -width 2
                        $w create line  50 350 350 350 -width 2
                        $w create line  50  50  50 350 -width 2
                        $w create line 100 100 100 300 -width 2
                        $w create line 150 150 150 250 -width 2
                        $w create line 200  50 200 150 -width 2
                        $w create line 200 250 200 350 -width 2
                        $w create line 250 150 250 250 -width 2
                        $w create line 300 100 300 300 -width 2
                        $w create line 350  50 350 350 -width 2
                        set bee [ list $w create poly  -8 10  -8 7  -5 7  -2 -1  -4 -5  -2 -10  2 -10  4 -5  2 -1  5 7  8 7  8 10 ]
                        set bee [ list    -8 10  -8 7  -5 7  -2 -1  -4 -5  -2 -10  2 -10  4 -5  2 -1  5 7  8 7  8 10 ]
                        set check "1"
                        foreach factor [list  10 12 14 16 18 20] {
                            set cat [list  ]
                            foreach item $bee {
                                #if {[string is alpha $item] == "1"} {lappend cat  $item }
                                if { 1 == "1" || 1 == "1" || 1 == "1" ||  1 == "1" } {lappend cat [ expr 200*$factor*.1 + $item * log($factor)                                     ]}
                            }
                            puts " $w create poly  $cat -outline gray -fill [lpick $randomcolor ] -tags {object moveable}"
                            $w create poly  $cat -outline gray -fill [lpick $randomcolor ] -tags {object moveable}
                        }
                    }
                proc wastebasket {w} {
                    set font9 { Helvetica 50}
                    $w  create rectangle 350 400 500 450 -fill green -tag wastebasket
                    $w  raise wastebasket                   
                }                
                proc tokenize_lamb {tag} {
                    global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .cv create text [+ $xxx1 355 ] [+ $yyy1 35 ] -text "\u26AB" -font $font10  -fill $coloritx -tags $tag
                .cv create text [+ $xxx1 355 ] [+ $yyy1 35 ] -text "\u2638" -font $font9  -fill $colorit -tags $tag
                }                
                proc tokenize_jar_oil {tag} {
                         global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .cv create text [+ $xxx1 355] [+ $yyy1 78 ] -text "\u26AB" -font $font10 -fill $coloritx -tags $tag
                .cv create text [+ $xxx1 355] [+ $yyy1 78 ] -text "\u2617" -font $font9  -fill $colorit -tags $tag
                }                
                proc tokenize_goat {tag} {
                    global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .cv create text [+ $xxx1 355] [+ $yyy1 127] -text "\u26AB" -font $font10 -fill $coloritx -tags $tag
                .cv create text [+ $xxx1 355] [+ $yyy1 127] -text "\u2744" -font $font9 -fill $colorit -tags $tag
                }                
                proc tokenize_ingot {tag} {
                                  global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .cv create text [+ $xxx1 355] [+ $yyy1 170] -text "\u26AB" -font $font10  -fill $coloritx -tags "$tag xxx"
                .cv create text [+ $xxx1 355] [+ $yyy1 170] -text "\u2745" -font $font9  -fill $colorit  -tags $tag
                }                
                proc tokenize_garment {tag} {
                          global font9 font10 colorit coloritx xx yy xxx1 yyy1
                .cv create text [+ $xxx1 355] [+ $yyy1 223] -text "\u26AB" -font $font10  -fill $coloritx -tags $tag
                .cv create text [+ $xxx1 355] [+ $yyy1 223] -text "\u2618" -font $font9  -fill $colorit -tags $tag
                }                
                proc tokenize_cow_bull {tag} {
                     global font9 font10 colorit coloritx xx yy xxx1 yyy1 worth
                .cv create text [+ $xxx1 355]  [+ $yyy1 270] -text "\u26AB" -font $font10  -fill $coloritx -tags $tag
        .cv create text [+ $xxx1 355]  [+ $yyy1 270] -text "\u2735" -font $font9  -fill $colorit -tags "$tag "
                }                                
                set state2 1
                proc take_token {tag x y} {
                    global tokenx tokeny
                    set tokenx $x
                    set tokeny $y                    
                    tokenize_$tag token
                    .cv raise token
                    .cv bind $tag <B1-Motion> {drag_token %x %y}
                    .cv bind $tag <ButtonRelease-1> "drop_token $tag %x %y"
                }                
                proc drag_token {x y} {
                    global tokenx tokeny
                    .cv move token [expr {$x - $tokenx}] [expr {$y - $tokeny}]
                    set tokenx $x
                    set tokeny $y
                }                
                proc drop_token {tag x y} {
                    global grab worth numis xx1 yy2 xxx1 tally_picks
                    #.c delete token 
                    set tallyit {}
                    set valuex 0.
                    set tallysum 0.
                    foreach  item [.cv  find overlapping  $x $y [+ 25 $x] [+ 25 $y ]] {
                     set numberx [.cv  gettags $item ]
                    regexp {value_(\d+)} $numberx -> valuex  
                       lappend tallyit $valuex
                       set tallysum [+ $tallysum $valuex ]
                    }
                    puts   [.cv  gettags [.cv  find overlapping  $x $y [+ 25 $x] [+ 25 $y ] ]]
                    puts "tallyit= $tallyit  tallysum= $tallysum "
                    set tally_picks [+ $tally_picks $worth($tag)]  
                    puts " &|worth= |$worth($tag) | tag = $tag | tally_total= |$tally_picks|&"
                    set tilename  [expr {int(rand()*1000000000.)}]
   .cv itemconfigure token  -tag [concat mv xdat_$x  ydat_$y obj_$tilename # $worth($tag) value_$worth($tag) ]
                                        
                }     
                proc refreshgridx { w } {
                    global oscwidth oschorizontal colorite
                    global grid cxmax cymax dx dy x0 y0
                    global ind indx
                    set cxmax 500
                    set cymax 400
                    set ind 0
                    set indx 0
                    set colorite blue
                    . configure -background orange -highlightcolor brown -relief raised -border 30
                    $w configure -bg tan
                    set dx 100    ;# pixels between adjacent vertical grid lines
                    set dy 100    ;# pixels between adjacent horizontal grid lines
                    set x0 50    ;# pixels between left of canvas and left of grid
                    set y0 50   ;# pixels between top of canvas and top of grid
                    #set win $w   ;# name of canvas widget
                    $w  create rectangle 350 50 500 350 -fill beige -tag grider
                    $w  lower grid
                    foreach i {0 3} {
                        $w create line [expr {$i * $dx + $x0}] $y0\
                                [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}] -width 2 -fill green -tag grid
                    }
                    for {set i 1} {$i < 4} {incr i} {
                        $w create line [expr {$i * $dx + $x0}] $y0\
                                [expr {$i * $dx + $x0}] [expr {9 * $dy + $y0}] -width 2 -fill blue -tag grid
                        
                    }
                    for {set i 0} {$i < 10} {incr i} {
                        $w create line $x0 [expr {$i * $dy + $y0}]\
                                [expr {3 * $dx + $x0}] [expr {$i * $dy + $y0}] -width 2 -fill purple -tag grid
                    }
                     wastebasket .cv
                } 
                    proc DrawFn1 {w} {
                        $w create line 0 100  50 200  100 50  150 70  200 155  250 50  300 111  350 222\
                                -tags "Fn1"  -smooth bezier -width 4
                    }
                    proc DrawFn2 {w} {
                        set offY 0    ;# [expr { $::maxY / 2 }]
                        for { set x 0 } { $x <= $::maxX } { incr x 5 } {
                            set y [expr { rand() * $::maxY + $offY }]
                            #puts "$x $y"
                            if {$x>0} { $w create line $x0 $y0 $x $y -tags "Fn2"  }
                            set x0 $x
                            set y0 $y
                        }
                    }
                   proc onDblClick {x y} {
                   set x [.cv canvasx $x] ; set y [.cv canvasy $y]
                   set i [.cv find closest $x $y]
                   set t [.cv gettags $i]
                   set u [.cv gettags current]
                   puts "selected double click point $u "  
                   puts "nearest entity $i $t"
                   set number1 1.
                   set number2 1.
                   set numberx $t
                   regexp {value_(\d+)} $u -> number1
                   regexp {value_(\d+)} $numberx -> number2
                   puts "product of adjacent tokens $number1 X $number2 [* $number1 $number2 ] "
                   set cumulative_product 1.
                   set cumulative_sum 0.
                   set numero 1.
                   puts "selected double click point $u "  
                   puts "nearest entity $i $t"
                   puts " rectangular enclosure  [ .cv find enclosed $x $y [+ $x 100 ] [+ $y 100 ] ]  "
                   puts " rectangular enclosure split [split [ .cv find enclosed $x $y [+ $x 100 ] [+ $y 100 ] ] ] "
                   foreach item [split [ .cv find enclosed $x $y [+ $x 100 ] [+ $y 100 ] ] ]   {
                   puts " .cv gettags $item [.cv gettags $item ]"
                   set tx ""
                   set tx $item
                   regexp {value_(\d+)} [.cv gettags $item ] -> numero
                   puts " numero $numero "
                   set cumulative_product [* $cumulative_product $numero]
                   set cumulative_sum [+ $cumulative_sum $numero]
                   puts "cumulative_sum $cumulative_sum"
                   puts "cumulative_product $cumulative_product" 
                   estimate_squares $x $y
                    }
                   set number1 1.
                   set number2 1.
                   set numberx $t
                   regexp {value_(\d+)} $u -> number1
                   regexp {value_(\d+)} $numberx -> number2
                   puts " number1 number1 $number1 $number2" 
                   puts "product of adjacent tokens $number1 X $number2 [* $number1 $number2 ] "
                   }    
                   proc estimate_squares { x y } {
                   global .cv dx dy
                   global grid cxmax cymax dx dy x0 y0
                   puts " rectangular enclosure  [ .cv find enclosed $x $y [+ $x 100 ] [+ $y 100 ] ]  "
                   foreach item  {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15}  { 
                   foreach item2  {1 2 3 4 5 6 7 8 9 10  }  {
                   set cx0 [expr { $dx*$item2/4. + $dx/4.}]
                   set cy0 [expr { $dy*$item/4.  + $dy/4.}]
                   set cx1 [expr { $dx*$item2/4. + $dx + 5  }]
                   set cy1 [expr { $dy*$item/4. +  $dy + 5  }]
                   puts " enclosed squares $cx0 $cy0 $cx1 $cy1 [ .cv find enclosed $cx0 $cy0 $cx1 $cy1 ] "
                   } }      
                   }         
                    #: Main :
                    frame .f1
                    frame .f2
                    frame .f3
                    pack  .f1 .f2 .f3
                    set maxX 320
                    set maxY 240
                    set y      0
                    set state2 1
                    set x1 120
                    set x2 150
                    set y1  50
                    set y2  80
                    set colorite seashell3
                    #canvas  .cv -width $maxX -height $maxY  -bg white
                    set state2 1
                    #canvas .cv -width $maxX -height $maxY -bg white
                    set oscwidth 1000
                    set oschorizontal 500
                    canvas .cv -width 400 -height 500 -scrollregion "0 0 $oscwidth $oschorizontal" \
                            -xscrollcommand ".corpsx set" -yscrollcommand ".corpsy set" \
                            -background palegreen -highlightcolor DarkOliveGreen \
                            -relief raised -border 10
                    scrollbar .corpsx -command " .cv xview" -orient horizontal
                    scrollbar .corpsy -command " .cv yview" -orient vertical
                    focus .cv
                    proc refreshgrid { .cv state2} {
                        global oscwidth oschorizontal colorite
                        global grid
                        set colorite blue
                        for {set x 10} {$x<$oscwidth} {incr x 50} {.cv create line $x 0 $x $oschorizontal  -fill blue -tag gridx -width 4}
                        for {set y 20} {$y<$oschorizontal} {incr y 50} {.cv create line 0 $y $oschorizontal $y -fill blue  -tag gridx -width 4}
                        .cv itemconfigure gridx -fill blue
                        if { $state2 == 1 } { .cv raise gridx ;}
                        if { $state2 == 2 } { .cv lower grider ;.cv lower grid; .cv delete gridx }
                    }
                    pack    .cv -in .f1
                    button  .b0 -text "Clear" -command { ClrCanvas .cv }
                    button  .b1 -text "Text"  -command { PaintText .cv "Canvas" }
                    button  .b2 -text "Axis"  -command { DrawAxis  .cv }
                    button  .b3 -text "Box"   -command { DrawBox   .cv }
                    button  .b4 -text "Fn1"   -command { DrawFn1   .cv }
                    button  .b5 -text "Fn2"   -command { DrawFn2   .cv }
                    #pack .b0 .b1 .b2 .b3 .b4 .b5  .b6 .b7 -in .f2  -side left -padx 2
                    #catch {console show}
                    #if { $state2 == 1 } { .cv raise grid ;} if { $state2 == 2 } { .cv lower grid ;} }
                    button  .b6 -text "gridlower"   -command { refreshgrid .cv 2 } -background   $colorite
                    button  .b7 -text "gridover"   -command { refreshgrid .cv 1 } -background   $colorite
                    button  .b8 -text "S.board"   -command { refreshgridx .cv  }
                    button  .b9 -text "S.pieces"   -command { pieces .cv }
                    button  .b10 -text "scale^"   -command {.cv scale all 0 0 1.1 1.1 }
                    button  .b11 -text "unscale<"   -command {.cv scale all 0 0 .9 .9 }
                    button  .b12 -text "meas_ball"   -command { .cv create oval 150  110 170   130 -width 2 -fill red -outline gray                         -tags {object moveable}; }
                    button  .b13 -text "console"   -command { mint .cv; }
                    button  .b14 -text "exit"   -command { exit }
                    set info "0"
                    label  .info -textvar info -just left
                    pack .b0 .b1 .b2 .b3 .b4 .b5  .b6 .b7  -in .f2  -side left -padx 2
                    pack .b8 .b9 .b10 .b11 .b12 .b13 .b14 .info -in .f3  -side left -padx 2
                    .cv bind moveable <ButtonPress-1> {item:move %W %x %y 1;set info " %x %y ";puts "%x %y"}
                    .cv bind moveable <ButtonRelease-1> {item:endmove %W %x %y;puts "%x %y"}
                    .cv bind moveable <Enter> {item:hover %W %x %y 1;set info " %x %y "}
                    .cv bind moveable <Leave> {item:hover %W %x %y 0;set info " %x %y "}
                    .cv bind moveit <B1-Motion> {item:move %W %x %y;set info " %x %y "}
                    .cv bind all <ButtonRelease-2> {item:toggletag %W %x %y moveable}
                proc pieces { .cv } {
                tokenize_lamb lamb
                .cv bind lamb <ButtonPress-1> {take_token lamb %x %y}
                tokenize_jar_oil jar_oil
                .cv bind jar_oil <ButtonPress-1> {take_token jar_oil %x %y}
                tokenize_goat goat
                .cv bind goat <ButtonPress-1> {take_token goat %x %y}
                tokenize_ingot ingot
                .cv bind ingot  <ButtonPress-1> {take_token  ingot %x %y}
                tokenize_garment garment
                .cv bind garment  <ButtonPress-1> {take_token  garment %x %y}         
                tokenize_cow_bull cow_bull
                .cv bind cow_bull  <ButtonPress-1> {take_token  cow_bull %x %y}            
                .cv bind all <1> {set p(X) [.cv canvasx %x]; set p(Y) [.cv canvasy %y];set info " %x %y "}
                set haloo 50
                .cv bind mv <B1-Motion> {mv .cv %x %y}
                .cv bind mv <ButtonRelease-1> { crasher .cv }
                bind .cv <Double-1> { onDblClick %x %y }
                }
                proc crasher {w} {
                    foreach  item [$w  find overlapping  350 400 500 450 ] {
                        if {[$w type $item]=="oval"} {$w delete $item}
                        if {[$w type $item]=="text"} {$w delete $item}
                    }
                } 
                proc mv {w x y} {
                    global p id
                    set x  [$w canvasx $x]
                    set y  [$w canvasy $y]
                    set id [$w find withtag current]
                    set numberx [$w  gettags current]
                    regexp {obj_(\d+)} $numberx -> tilex                    
                    puts "1"
                    puts $numberx
                    puts $tilex
                    puts " with tag [$w find withtag obj_$tilex ]"
                    foreach item [$w find withtag obj_$tilex ] {
                        $w move $item [expr {$x-$p(X)}] [expr {$y-$p(Y)}]
                        
                    }
                    puts " x y $x $y"
                    if { $y >= 20 && $y <= 70 } {
                        if { $x >= 20 && $x <= 70 } {$w delete obj_$tilex }
                    }                    
                    foreach  item [$w  find overlapping  350 400 500 450 ] {                        
                        if {[$w type $item]=="oval"} {$w delete $item}
                        if {[$w type $item]=="text"} {$w delete $item}
                    }                    
                    set p(X) $x; set p(Y) $y
                }               
                    #wastebasket .cv
                    #set info [format "x=%.2f y=%.2f" $x $y]
                    wm title . " Sumerian Counting Board Strategy "     
                    # update item styles
                    item:upd .cv

gold This page is copyrighted under the TCL/TK license terms, this license.

Comments Section edit

Please place any comments here, Thanks.