GET-ORDER

ONLY FORTH

VOCABULARY MERGE-SORT
ALSO MERGE-SORT DEFINITIONS

VOCABULARY MERGE-SORT-INTERNALS
ALSO MERGE-SORT-INTERNALS DEFINITIONS

\ In the next few definitions link-xt is a function that takes a node address
\ and returns a pointer to its link field (holding NULL or the address of the
\ next node); compare-xt takes two node addresses and returns a negative, zero,
\ or positive value if the left node is less than, equal to, or greater than
\ the right node, respectively. The term "head" refers to the address of the
\ node at the beginning of a list, or NULL if the list is empty. &link is the
\ address of either a cell holding the head of the list or a node's link field.

\ Put the even items from head into head1 and the odd items into head2
: SPLIT  ( head link-xt -- head1 head2 )
   >R NULL NULL ROT BEGIN ?DUP WHILE
      TUCK R@ EXECUTE XCHG >R SWAP R>
   REPEAT RDROP SWAP ;

\ Merge two sorted lists into a single sorted list
: MERGE  ( head1 head2 link-xt compare-xt -- head )
   2>R NULL >R RSP@ BEGIN
      ( S: head1 head2 &link  R: link-xt compare-xt head )
      \ If either list is empty we're done; append the other to the result and exit
      OVER NULL= IF NIP ! R> 2RDROP EXIT THEN
      2 PICK NULL= IF ! DROP R> 2RDROP EXIT THEN
      \ Otherwise compare the two nodes
      \ If head1 is greater than head2 then move head2 to the output, else head1
      >R 2DUP R> -ROT 1 RPICK EXECUTE 0< IF >R SWAP R> THEN
      >R DUP 3 RPICK EXECUTE @ SWAP R>
      ( S: head1 head2' head2 &link  R: link-xt compare-xt head )
      \ Store NULL in head2's link field; save &link2 under head2 on the stack
      \ Store head2 at &link
      OVER NULL SWAP 2 RPICK EXECUTE DUP >R ! R> -ROT !
      ( S: head1 head2' &link2  R: link-xt compare-xt head )
   AGAIN ;

PREVIOUS DEFINITIONS ALSO MERGE-SORT-INTERNALS

\ Return TRUE if the given list is sorted, or FALSE otherwise
: SORTED?  ( head link-xt compare-xt -- flag )
   \ An empty list is trivially sorted
   2>R ?DUP NULL= IF 2RDROP TRUE EXIT THEN
   BEGIN
      \ Get the next node
      DUP 1 RPICK EXECUTE @
      \ If there is no next node then the list is sorted
      ?DUP NULL= IF DROP 2RDROP TRUE EXIT THEN
      \ If the current node is greater than the next node then the list is not sorted
      TUCK R@ EXECUTE 0> IF DROP 2RDROP FALSE EXIT THEN
      \ Otherwise repeat for the next pair of adjacent nodes
   AGAIN ;

\ Sort the given list using the recursive merge sort algorithm:
\ 1. If the list is already sorted, return it unchanged.
\ 2. Otherwise, split the list into two approximately equal sublists.
\ 3. Sort both sublists recursively.
\ 4. Merge the sorted sublists into a single sorted list.
: MERGE-SORT  ( head1 link-xt compare-xt -- head2 )  RECURSIVE
   2>R DUP 2R@ SORTED? 0= IF
      1 RPICK SPLIT 2R@ MERGE-SORT SWAP 2R@ MERGE-SORT 2R@ MERGE
   THEN 2RDROP ;

\ Sort in descending order by negating the result of compare-xt
: MERGE-SORT>  ( head1 link-xt compare-xt -- head2 )
   [[ ' NEGATE ]] COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ;

SET-ORDER