**An Experiment**

This code is rather long. It draws several sprites (configurable by modifying NUMBER_OF_SPRITES) and animate them. Currently on my 1.5GHz PC the canvas can comfortably handle up to 50 sprites at once. This does roughly 12 frames per second on my PC.

This is really a proof of concept rather than anything useful. This is roughly a straightforward translation of one of my javascript projects (which explains why I'm using [dicthash] and why the code looks weird).

======
#! /usr/bin/env wish

set NUMBER_OF_SPRITES 50

package require math::constants

proc dicthash {cmd args} {
  set path [split [string range $cmd 1 end] .]
  set varname [lindex $path 0]
  set path [lrange $path 1 end]

  #figure out if we need to re-base our "this"
  set hashindex -1
  for {set i 0} {$i<[llength $path]} {incr i} {
    set  key [lindex $path $i]
    if {[string match %* $key]} {
      set hashindex $i
      lset path $i [string trimleft $key %]
    }
  }

  if {$hashindex == -1} {
    upvar 2 $varname var
  } else {
    # We need to re-base "this". This is done by repointing $path and $var
    # So we need to save the path that leads to this nested dict: $prepath
    set prepath [lrange $path 0 $hashindex]
    set path [lrange $path [expr {$hashindex+1}] end]
    
    # Also need to save the base dict somewhere: $basedict
    upvar 2 $varname basedict
    set var [dict get $basedict {*}$prepath]
  }

  if {[llength $args] == 0} {
    return [dict get $var {*}$path]
  } else {
    set subcommand [lindex $args 0]
    set args [lrange $args 1 end]
    
    # check to see if $subcommand is a method:
    if {[catch {dict get $var {*}$path $subcommand} script] == 0} {
    
      # "this" magic:
      set body [lindex $script 1]
      if {![string match {upvar 1 var this;*} $body]} {
        set body "upvar 1 var this;$body"
        lset script 1 $body
        dict set var {*}$path $subcommand $script
      }
      set ret [apply $script {*}$args]
      
      # If we are rebased we need to merge $var back 
      # into the base dict since tcl has value semantics:
      if {$hashindex != -1} {
        dict set basedict {*}$prepath $var
      }
      return $ret
    } else {
      # built in operators:
      switch -- $subcommand {
        "=" {
          if {[llength $path]} {
            if {[llength $args]} {
              set ret [dict set var {*}$path {*}$args]
              
              # If we are rebased we need to merge $var back 
              # into the base dict since tcl has value semantics:
              if {$hashindex != -1} {
                dict set basedict {*}$prepath $var
              }
              return $ret
            } else {
              error "value not specified"
            }
          } else {
            error "key not specified"
          }
        }
        "+" {
          if {[llength $path] == 0} {
            return [dict merge $var {*}$args]
          } else {
            error "invalid dict merge"
          }
        }
        "+=" {
          if {[llength $path] == 0} {
            return [set var [dict merge $var {*}$args]]
          } else {
            error "invalid dict merge"
          }
        }
      }
    }
  }
  error "unsupported operation on $cmd"
}

if {[info proc dicthash.unknown] == ""} {
  rename unknown dicthash.unknown
  proc unknown {cmd args} {
    if {[string index $cmd 0] == "%"} {
      return [dicthash $cmd {*}$args]
    } else {
      dicthash.unknown $cmd {*}$args
    }
  }
}

math::constants::constants pi

proc angleFromDelta {dx dy} {
  set hyp [distanceFromDelta $dx $dy]
  set theta [expr {asin($dy/$hyp)}]
  if {$dx<0} {
    set theta [expr {$::pi-$theta}]
  } elseif {$dy<0} {
    set theta [expr {$::pi*2+$theta}]
  }
  return $theta
}

proc angleDiff {theta gamma} {
  expr {acos(cos($theta-$gamma))}
}

proc sectorFromAngle {angle numberOfSectors} {
  set sec [expr {round(($angle/(2*$::pi))*$numberOfSectors)}]
  if {$sec == $numberOfSectors} {
    set sec 0
  }
  return $sec
}

proc distanceFromDelta {dx dy} {
    expr {sqrt($dx*$dx + $dy*$dy)}
}

proc distance {xy1 xy2} {
    distanceFromDelta \
    [expr {[lindex $xy1 0]-[lindex $xy2 0]}] \
    [expr {[lindex $xy1 1]-[lindex $xy2 1]}]
}

set SPRITE_SECTORS 8

pack [canvas .c -bg white -width 600 -height 400] -fill both -expand 1

proc copySprite {src dst width height x y {composite set}} {
  set w [expr {$width-1}]
  set h [expr {$height-1}]
  set startx [expr {$x*$width}]
  set starty [expr {$y*$height}]
  set endx [expr {$startx+$width}]
  set endy [expr {$starty+$height}]
  $dst copy $src \
    -from $startx $starty $endx $endy \
    -to 0 0 $width $height \
    -compositingrule $composite
}

set IMAGE_COL 3
set IMAGE_ROW 8
set IMAGE_WIDTH 12
set IMAGE_HEIGHT 24
image create photo boy -data {
R0lGODlhJADAAMIEAAAHA8iicunUw/7//P///////////////yH5BAEKAAQALAAAAAAkAMAAAAP+
SKrQ+zBKCYIF1E3ScKzWBYGB94XmAgpsSopjCKvWAAiuxeJnsKccH45HC9iID9ARWNkhg60nQ3hj
OktJYevkBEKltx12dGVqvU0pbUtmjdfs2O/jFrw5Yi9+3g673BpZQ2p+cQ1lZCUtZopEFVU+d01p
gQwNVFM3JZV4jYSIll0faYRnbXZoOnFJfFOAd0FpsHuoDHkoRSWYMbhBFyQmwL0jHUkaxcYYyBvM
zc7P0BvL0dDAE9PEei+z1j3cMrDbjMNQWpLg4zNQNktr5sGReXBVSE3sVWv3T2GtX/TwUfDBWUWL
ID+CX8JpAbPQDCg43wAJcrKP4r6GrCjCONj+j1S9eD8c2blSj1KwKD+wFAoJj1KRg8cudHkDoqYx
jCo8VmqyyYqojP2+1AK6imdHIbtU1KmIIympMJJaqAPGBxjPHD1HXZqBzKaxZ9iIURvLLCzZa+SS
SeM0RUYqdbnephXHi5wmMRfd1p0qYMmAeiPrnDT3cYimk34BJ/7z0xU9mj4e55BHFAzFVEMnZnYl
UXPEWeUcPhSqkLItiwAfeszM0ZBGwAsdgRypUhWqWpPMqUQ5SJknqL55P/LFz+shqZB/ByO1CWjz
m0GhGhwt1HLvNklPZ9/jpw/cmgYvfP+lbSsaZeXB6jnLvj0HtjnXv1/fra62tL7moturUG/+Fv+5
TEUYZHgRWAdNOLDDWoIA/IVggw0uSI+EgzxYIWPRXXbKdKad1plSHSaE2WaclRbiQVFpCOJoKGL4
0woqhoLKYCR5MOGBJ6FiYUg8PNKFIeJBBtNGQ9J0yWbHAeLic5yRyJFPGQaWIm0uXsQbgrcxld1V
3RRnl0x52RiIVWx18J1886nn3prumWUJmmbV9x9o+aXTH350rfidGNzw+UeDewLap6B/fmgLcHQg
uqKT1BV0TmNNlgLpHqApSgeJtPRpqJ6ifRJUk5Ntxx2mRzLVnTFSMdRFjqfmBAiSkUBiI3JopATG
kcNRGhY/TC46Jk7ORcShk0h5lUmxQEH+qUsvwlRlypy+bYRClwDGZ+2103SAJpvcdtuem2leA1+d
FOBHLn92povuunMKCE5y+7UVbyfzalKvHfdGMsxdAPJrlxt74hsOwAML7NNcBIsmrKbEsojahlOa
1pqVH8L4YmCCQYfDSSjiNghKLTnlyXU+ppScse/NNEaSMwqSFVG9PnlKwFFS6aqUVR586lMSL4Uh
tbHWB15ePWElJhPmZbNWNdt6q5XT0IorX5zzxlUuXPmNV23WUYFDtNb/ej2YDLCRPXYIZaN9tg5/
qM2K2ErBPdDAbr/NNhcMDxteiKGV2zCL78hh6MSpSRwbljFyFFncKhqFoy954BaZbsrDCLdFyRf6
k1K0Xq7cOTzK5fQOhr2+9yyI27UoOIetasdh6iB711/rxGkdZ9JiwTeuWFAz3TR7cqol9dV4mhs8
1+q2e867WOlX7TaLy9vvu/DGA7rZAd6dS1FkR5/1SM2Hp8o4CMlCPkPjr/63pLA+PJB1jbXGVeCL
OouxYTfHfP/iK0mVoy6s+hHnVvUfYw3Nf5YA1ptipbFFVIYRNdMbxagAkNO5rjBXmlVTWDe/X+jL
Rig4ysuwNRUznYlpa/kdtxIAADs=
}

# Split image tile into individual sprites:
array set sprites {}
for {set x 0} {$x < $IMAGE_COL} {incr x} {
  for {set y 0} {$y < $IMAGE_ROW} {incr y} {
    set sprites(boy.$x.$y) [image create photo \
      -width $IMAGE_WIDTH -height $IMAGE_HEIGHT
    ]
    copySprite boy $sprites(boy.$x.$y) $IMAGE_WIDTH $IMAGE_HEIGHT $x $y
  }
}  

proc count {stepcount} {
  expr {($stepcount+1)%120}
}

# Character object:
set character {
  size 50
    x 100
    y 100
    vector {x 0 y 1}
    speed 3
    dest {x {} y {}}
    sprite {
    img boy
    tag ""
        x 0
        y 2
  }
    stepcount 0
    
    step {{} {
    if {[%this.dest.x] == {} || [%this.dest.y] == {}} {
      return 0
    }
    
    set x [%this.x]
    set y [%this.y]
    
    set dx [expr {[%this.dest.x]-$x}]
    set dy [expr {[%this.dest.y]-$y}]
    
    set distance [distanceFromDelta $dx $dy]
    
    if {$distance < [%this.speed]} {
      # Arrived at destination, stop moving.
      %this.dest.x = {}
      %this.dest.y = {}
      return 0
    }
    
    if {([%this.stepcount] % 5) == 0} {
      %this setVector $dx $dy
    }
    
    set xx [%this.vector.x]
    set yy [%this.vector.y]
    
    set xx [expr {$xx*[%this.speed]}]
    set yy [expr {$yy*[%this.speed]}]
        
    %this.x = [expr {$x+$xx}]
    %this.y = [expr {$y+$yy}]
    
    .c moveto [%this.sprite.tag] [%this.x] [%this.y]
    
    %this.stepcount = [count [%this.stepcount]]
        
    set walkstate [expr {[%this.stepcount] % 4}]
    switch -- $walkstate {
      0 {%this.sprite.x = 0}
      1 {%this.sprite.x = 1}
      2 {%this.sprite.x = 0}
      3 {%this.sprite.x = 2}
    }
    %this renderImg
        
    return 1
  }}
      
    setVector {{dx dy} {
    math::constants::constants pi
    
    set theta [angleFromDelta $dx $dy]
    
    %this.sprite.y = [sectorFromAngle $theta $::SPRITE_SECTORS]
    %this renderImg
    
    set gamma [expr {(double([%this.sprite.y])/$::SPRITE_SECTORS)*2*$::pi}]
    
    %this.vector.x = [expr {cos($gamma)}]
    %this.vector.y = [expr {sin($gamma)}]
  }}
    
    renderImg {{} {
    global sprites
    set s [%this.sprite]
    
    .c itemconfigure [%s.tag] -image $sprites([%s.img].[%s.x].[%s.y])
  }}
}

proc makeUnit {proto spec} {
  set unit [dict merge $proto $spec]
  
  set tag [.c create image [%unit.x] [%unit.y]]
  %unit.sprite.tag = $tag
  
  %unit renderImg
  
  return $unit
}

proc sortCanvas {} {
  # raise/lower units based on y-coordinates
  global units
  set ylist {}
  foreach x [array names units] {
    lappend ylist [list [%units($x).sprite.tag] [%units($x).y]]
  }
  set ylist [lsort -decreasing -real -index 1 $ylist]
  foreach x $ylist {
    set item [lindex $x 0]
    .c lower $item topitems
    .c addtag topitems withtag $item
  }
  .c dtag topitems
}

array set units {}
for {set x 0} {$x < $NUMBER_OF_SPRITES} {incr x} {
  set units($x) [makeUnit $character [list \
    x [expr {rand()*600}] \
    y [expr {rand()*400}]
  ]]
}

proc anim {} {
  global units
  foreach x [array names units] {
    %units($x) step
  }
  sortCanvas
  after 80 anim
}
anim

# periodically give people random destinations
proc motivate {} {
  global units
  foreach x [array names units] {
    if {rand() > 0.8} {
      %units($x).dest.x = [expr {rand()*600}]
      %units($x).dest.y = [expr {rand()*400}]
    }
  }
  after 1000 motivate
}
motivate

bind . <Key-c> {
  catch {console show}
}
======

----
!!!!!!
%| enter categories here |%
!!!!!!