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 mainly 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
}
puts [mergeSort 3 1 5 4 2]
#---------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
}
puts [strandSort 3 1 5 4 2]glennj another merge sort
package require Tcl 8.5
proc mergesort m {
set len [llength $m]
if {$len <= 1} {
return $m
}
set middle [expr {$len / 2}]
set left [lrange $m 0 [expr {$middle - 1}]]
set right [lrange $m $middle end]
return [merge [mergesort $left] [mergesort $right]]
}
proc merge {left right} {
set result [list]
while { [set lleft [llength $left]] > 0 &&
[set lright [llength $right]] > 0
} {
if {[lindex $left 0] <= [lindex $right 0]} {
set left [lassign $left value]
lappend result $value
} else {
set right [lassign $right value]
lappend result $value
}
}
if {$lleft > 0} {
lappend result {*}$left
}
if {$lright > 0} {
set result [concat $result $right] ;# another way append elements
}
return $result
}
puts [mergesort {8 6 4 2 1 3 5 7 9}] ;# => 1 2 3 4 5 6 7 8 9