74 lines
3.0 KiB
Forth
74 lines
3.0 KiB
Forth
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
|