2009-03-18 [kruzalex] I decided to put some code in conjuncion with merge sorts playing little bit with PHP array functionality, cause I didnt see any on wiki pages in this relation. Below rewrited sorting procs are sourced from existing php codes...

#---------Merge sort

  rename array Array

  namespace eval array {
  variable info [list]
  }

  proc array {args} {
  set res [info level 0]
  set array_name [lindex [info level 0] 2]
  if {[lindex $args 0] == "exists"} {
  return [uplevel 1 [list Array exists $array_name]]   
  } elseif {[lindex $args 0] == "set"} {
  if {[regexp {[[:digit:][:alpha:]][(][0-9]+[)]} [lindex $args 1]] != 1} {
  set ::array::temp [list]
  for {set x 0} {$x<[llength  [lindex $res 3]]} {incr x} {
  lappend ::array::temp $x [lindex [lindex $res 3] $x]
  } 
  uplevel 1 [list Array unset $array_name]
  uplevel 1 [list Array set $array_name $::array::temp]           
  } elseif {[regexp {[[:digit:][:alpha:]][(][0-9]+[)]} [lindex $args 1]] == 1} {
  regexp {[[:digit:][:alpha:]]+} [lindex $args 1] array_name
  regexp {[(](.*?)[)]} [lindex $args 1] -> array_key        
  uplevel 1 [list set ${array_name}($array_key) [lindex $args 2]]
  }    
  } elseif {[lindex $args 0] == "get"} {
  return [uplevel 1 [list Array get $array_name]]
  } elseif {[lindex $args 0] == "size"} {
  return [uplevel 1 [list Array size $array_name]]
  } elseif {[lindex $args 0] == "unset"} {
  if {[regexp {[[:digit:][:alpha:]][(][0-9]+[)]} [lindex $args 1]] == 1} {
  regexp {[[:digit:][:alpha:]]+} [lindex $args 1] array_name
  regexp {[(](.*?)[)]} [lindex $args 1] -> array_key
  uplevel 1 [list unset ${array_name}($array_key)]
  } elseif {[regexp {[[:digit:][:alpha:]]} [lindex $args 1]] == 1} {
  uplevel 1 [list Array unset $array_name]
  }
  }
  }

  proc array_shift { arry args } {
  upvar $arry a
  set array_old [list]
  set array_new [list]
  foreach {key value} [Array get a] {
  lappend array_old [list $key $value]  
  }    
  set first_key [lindex [lsort -index 0 $array_old] 0 0]
  set shifted $a($first_key)
  set n 0
  foreach {key value} [eval concat [lsort -index 0 $array_old]] {
  if {$key!=$first_key} {
  lappend array_new $value          
  }    
  }
  uplevel 1 [list array set $arry $array_new]
  return $shifted
  }

  proc array_pop { arry args } {
  upvar $arry a
  set array_new [list]
  foreach {key value} [Array get a] {
  lappend array_new [list $key $value]  
  }    
  set last_key [lindex [lsort -index 0 $array_new] end 0]
  set shifted $a($last_key)
  uplevel 1 [list array unset ${arry}($last_key)]]
  return $shifted
  }
 
  proc array_unshift { arry args } {
  upvar $arry a
  set array_old [list]
  set array_new $args
  foreach {key value} [Array get a] {
  lappend array_old [list $key $value]  
  }    
  foreach {key value} [eval concat [lsort -index 0 $array_old]] {
  lappend array_new $value         
  }
  uplevel 1 [list array set $arry $array_new]
  return [uplevel 1 [list array size $arry]]
  }

  proc array_push { arry args } {
  upvar $arry a
  set array_old [list]
  foreach {key value} [Array get a] {
  lappend array_old $value
  }
  set array_new [eval concat [lappend array_old $args]]
  uplevel 1 [list array set $arry $array_new]
  return [uplevel 1 [list array size $arry]]
  }
 
  proc array_first_value {arry} {
  upvar $arry a
  set first_value $a([uplevel 1 [list array_first_key $arry]])
  return $first_value
  }
     
  proc array_last_value {arry} {
  upvar $arry a
  set last_value $a([uplevel 1 [list array_last_key $arry]])
  return $last_value
  }
     
  proc array_first_key {arry} {
  upvar $arry a
  set array_new [list]
  foreach {key value} [Array get a] {
  lappend array_new [list $key $value]  
  }    
  set first_key [lindex [lsort -index 0 $array_new] 0 0]
  return $first_key
  }
     
  proc array_last_key {arry} {
  upvar $arry a
  set array_new [list]
  foreach {key value} [Array get a] {
  lappend array_new [list $key $value]  
  }    
  set last_key [lindex [lsort -index 0 $array_new] end 0]
  return $last_key
  }
     
  proc array_splice {arry offset args} {
  upvar $arry a    
  set array_old [list]
  set array_new [list]
  set replacement [lrange $args 1 end]
  foreach {key value} [Array get a] {
  lappend array_old [list $key $value]
  }
  foreach {key value} [eval concat [lsort -index 0 $array_old]] {
  lappend array_new $value    
  } 
  if {[llength $args]>0} {
  set length [lindex $args 0]
  if {$length<0} {
  if {$offset<0} {
  return $array_new
  } else {
  puts [lindex $replacement 0]
  puts [lindex [lindex $replacement 0] 0]
  puts [lindex [lindex [lindex $replacement 0] 0] 0]
  set array_left [lrange $array_new 0 [expr $offset-1]]
  set array_middle [lrange $array_new end-[expr ($length*-1)-1] end-[expr ($length*-1)-1]]
  set array_right [lrange $array_new end-[expr ($length*-1)-2] end]
  if {[llength $replacement]>0} {
  set array_new [concat $array_left $replacement $array_right]
  } else {
  set array_new [concat $array_left $array_middle $array_right]            
  }
  }
  } else {
  if {$offset<0} {
  set array_left [lrange $array_new 0 end-[expr ($offset*-1)]]
  set array_right [lrange $array_new end-[expr ($offset*-1)-1-$length] end]
  set array_new [concat $array_left $replacement $array_right]    
  } else {    
  set array_left [lrange $array_new 0 [expr $offset-1]]
  set array_right [lrange $array_new [expr $offset+$length] end]
  set array_new [concat $array_left $replacement $array_right]
  } 
  }
  } else {
  if {$offset<0} {
  set array_new [lrange $array_new 0 end-[expr ($offset*-1)]]
  } else {  
  set array_new [lrange $array_new 0 [expr $offset-1]]
  }
  }
  uplevel 1 [list array set $arry $array_new]    
  }

  proc array_slice {arry offset args} {
  upvar $arry a    
  set array_old [list]
  set array_new [list]
  foreach {key value} [Array get a] {
  lappend array_old [list $key $value]
  }
  foreach {key value} [eval concat [lsort -index 0 $array_old]] {
  lappend array_new $value    
  } 
  if {[llength $args]>0} {
  set length [lindex $args 0]
  if {$offset<0} {
  set array_new [lrange $array_new [expr [llength $array_new]-[expr ($offset*-1)]] [expr [llength    $array_new]-[expr ($offset*-1)+1]+$length]]
  } else {    
  set array_new [lrange $array_new $offset [expr $offset+$length-1]]    
  }
  } else {
  set array_new [lrange $array_new $offset end]
  }
  return $array_new
  }
 
  proc mergeSort {args} {
  array set external [list]
  array set inputArray $args
  while {[array size inputArray]>0} {
  array set array1 [array_splice external 0]
  array set array2 [array_shift inputArray]
  array set output [list]
  while {[array size array1]>0 && [array size array2]>0} {
  if {$array1(0) < $array2(0)} {
  array_push output [array_shift array1]
  } else {
  array_push output [array_shift array2] 
  }        
  }
  while {[array size array1]>0} {
  array_push output [array_shift array1]
  }
  while {[array size array2]>0} {
  array_push output [array_shift array2]
  }
  foreach {key value} [array get output] {
  lappend temp $value          
  }
  array set external $temp
  }
  foreach {key value} [lsort -index 0 [array get external]] {
  lappend result $value
  }
  return $result
  }

#---------Strand sort

  proc strandSort {args} {
  array set results [list]
  array set arr $args
  while {[array size arr]>0} {
  array set sublist [array_shift arr]
  set last [array_last_key sublist]
  foreach {i val} [array get arr] {
  if {$val > $sublist($last)} {  
  array_push sublist $val
  array unset arr($i)
  incr last
  }           
  }
  if {[array size result]>0} {
  foreach {key val} [array get sublist] {
  set spliced false
  foreach {i rval} [array get result] {
  if {$val < $rval} {
  array_splice result $i 0 $val
  set spliced true
  break                          
  }         
  }
  if {!$spliced} {
  array_push result $val
  }
  }
  } else {
  foreach {key value} [array get sublist] {
  lappend temp $value          
  }
  array set result $temp
  unset temp
  }
  }
  foreach {key value} [lsort -index 0 [array get result]] {
  lappend res $value
  }
  return $res
  }


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