\ heap sort by Lcc Wizard for win32forth v4.2 0671


/*
void siftDown(int numbers[], int root, int len)
{
  int done, maxChild, temp;

  done = 0;
  while ((root*2 < len) && (!done))
    maxChild = root * 2;
    if (maxChild 1+ < len)
      if (numbers[maxChild] > numbers[maxChild + 1])
      maxChild++;

    if (numbers[root] < numbers[maxChild])
    {
      temp = numbers[root];
      numbers[root] = numbers[maxChild];
      numbers[maxChild] = temp;
      root = maxChild;
    }
    else  done = 1;
  }
}

void heapSort(int numbers[], int array_size)
{
  int i, temp;

  for (i = (array_size / 2); i >= 0; i--)
    siftDown(numbers, i, array_size);

  for (i = array_size-1; i >= 1; i--)
  {
    temp = numbers[0];
    numbers[0] = numbers[i];
    numbers[i] = temp;
    siftDown(numbers, 0, i);
  }
}
*/

0 value heapsort-compare-cnt
0 value heapsort-swap-cnt

: buf-swap-mem      { adr1 adr2 size buf -- }
                adr1 buf size cmove
                adr2 adr1 size cmove
                buf  adr2 size cmove

                1 +to heapsort-swap-cnt
               \ pad pad 1+ 512 cmove
                ;

\ : ?negate if negate then ;
code ?negate    ( n f -- n )
                mov     eax, ebx
                pop     ebx
                or eax, eax
                je short @@1
                neg ebx
        @@1:
                next end-code

: hsort-siftDown { root len h-array left b/h-array sort-compare descend? buf \ maxchild -- }
                begin
                        root 2* dup to maxchild
                        len <
                while
                        maxchild 1+ len < if
                                1 +to heapsort-compare-cnt

                                maxchild left +
                                dup 1+
                                h-array sort-compare execute
                                descend? if negate then
                                -1 = \ <
                                if
                                        1 +to maxchild
                                then
                        then

                        1 +to heapsort-compare-cnt

                        root left +   maxchild left +  h-array
                        sort-compare execute
                        descend? if negate then
                        -1 = \ <
                        if

                                h-array root left +  b/h-array * +
                                h-array maxchild left +  b/h-array * +
                                b/h-array buf buf-swap-mem
                                maxchild to root
                        else
                                exit
                        then
                repeat ; 

\ : sort-compare-func ( #index #index array -- f )
: heapsort      { left right h-array b/h-array descend? sort-compare \ len buf -- }
                left right >= ?exit

                b/h-array malloc to buf

                0 to heapsort-compare-cnt
                0 to heapsort-swap-cnt

                right left - 1+ to len

                ." sort entries= " len . cr

                len 2/
                begin
                        dup 0 >=
                while
                        dup len
                        h-array left b/h-array sort-compare descend? buf hsort-siftDown

                        1-
                repeat
                drop


                len 1-
                begin
                        dup 0>
                while
                        h-array over left +  b/h-array * +
                       \ h-array 0    left +  b/h-array * +
                        h-array      left    b/h-array * +
                        b/h-array buf buf-swap-mem

                        0 over
                        h-array left b/h-array sort-compare descend? buf hsort-siftDown

                        1-
                repeat
                drop

                buf free drop

                ." compare-cnt= " heapsort-compare-cnt . cr
                ." swap-cnt   = " heapsort-swap-cnt . cr
                ;


\ ==============

create testarray 5 , 3 , 20 , 1 , 9 , 13 , 19 , 88 , 10 , 57 ,
                 99 , 1000 , 843 , 232 , 329 , 232 , 88 , 45 , 5 , 99 ,
                 -1 ,


: int-compare   ( n n -- f )
                2dup < if 2drop -1 exit then
                > if 1 exit then 0 ;
/*
code int-compare ( n n -- f )
                pop eax
                mov ecx, ebx
                xor ebx, ebx
                cmp eax, ecx
                je      short @@2
                ja      short @@1
                dec     ebx                     \ if len1 < len2, default is -1
                next
@@1:
                inc     ebx                     \ if len1 > len2, default is 1
@@2:
                next end-code
*/

: int-sort-compare ( #index #index array -- f )
             \   ." compare " over .

                dup>r
                   +cells @ swap
                r> +cells @
                swap
                int-compare

              \  pad 255 pad 255 compare drop \ for delay only!
                ;

in-system

: t             ( -- )
                { \ ii tt kk -- }
                cls
                ." Heap Sort: " cr

           21 1 do
                i 0 ?do 100 random testarray i cells+ ! loop

                0 i 1- testarray cell false
                ['] int-sort-compare
                heapsort
                ." sorted= " i 0 do testarray i cells+ @ . loop cr cr

                i 1- 0max 0 ?do
                        testarray i cells+ @
                        testarray i 1+ cells+ @ > if
                                ." Error!" cr
                                s" error" errorbox leave
                        then
                loop
           loop
                21 0 do testarray i cells+ @ . loop cr


                100000 to ii
                ii cells malloc to tt
                ii 0 ?do
                        ii 10 * random
                        i cells tt + !
                loop

                time-reset
                0 ii 1-  tt cell false
                ['] int-sort-compare
                heapsort
                .elapsed cr
                10 0 do tt i cells+ @ . loop cr

                ii 1- 0 ?do
                        tt i cells+ @
                        tt i 1+ cells+ @ > if
                                s" error" errorbox leave
                        then
                loop
                ii free drop



                ;

in-application