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


<<categories>> Algorithm