add a generic MERGE-SORT function for linked lists

startup.4th

@@ -2081,6 +2081,69 @@ HIDE UNTHREAD
 : WORDS ( -- )
    GET-ORDER ?DUP IF 1- SWAP >R NDROP R> SHOW-WORDLIST THEN ;
 
+\ In the next few definitions link-xt is a function that takes a node address
+\ and returns a pointer to its link field (holding 0 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 0 if the list is empty. &link is the address
+\ of 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 0 0 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 0 >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 0= IF NIP ! R> 2RDROP EXIT THEN
+      2 PICK 0= 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 0 in head2's link field; save &link2 under head2 on the stack
+      \ Store head2 at &link
+      OVER 0 SWAP 2 RPICK EXECUTE DUP >R ! R> -ROT !
+      ( S: head1 head2' &link2  R: link-xt compare-xt head )
+   AGAIN ;
+
+\ 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 0= 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 0= 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 ;
+
+: NEGATED ( xt1 -- xt2 )
+   { EXECUTE NEGATE } 1 CLOSURE ;
+
+: MERGE-SORT-DESCENDING ( head1 link-xt compare-xt -- head2 )
+   NEGATED DUP >R MERGE-SORT R> FREE ;
+
+HIDE SPLIT
+HIDE MERGE
+
 : BANNER "JumpForth version " TYPE VERSION . ", by Jesse McDonald\n" TYPE ;
 
 INTERACTIVE? [IF] BANNER [THEN]

test/merge-sort.4th

@@ -0,0 +1,22 @@
+STRUCT
+CELL% FIELD NODE>LINK
+CELL% FIELD NODE>DATA
+ENDSTRUCT NODE%
+
+: COMPARE-NODES ( node1 node2 -- -1 | 0 | 1 )
+   >R NODE>DATA @ R> NODE>DATA @ - SIGNUM ;
+
+: MAKE-LIST ( xu ... x1 u -- head )
+   0 >R RSP@ SWAP BEGIN ?DUP WHILE
+      1- -ROT NODE% %ALLOCATE DUP ROT ! DUP NODE>LINK -ROT NODE>DATA ! SWAP
+   REPEAT DROP R> ;
+
+: SHOW-LIST ( head -- )
+   BEGIN ?DUP WHILE
+      DUP NODE>LINK @ SWAP NODE>DATA @ . SPACE
+   REPEAT EOL ;
+
+7 5 3 6 8 9 4 2 4 9 MAKE-LIST
+"Before: " TYPE DUP SHOW-LIST
+' NODE>LINK ' COMPARE-NODES MERGE-SORT-DESCENDING
+"After:  " TYPE SHOW-LIST

test/merge-sort.exp

@@ -0,0 +1,3 @@
+Before: 4 2 4 9 8 6 3 5 7 
+After:  9 8 7 6 5 4 4 3 2 
+exit-code: 0