\ Hoare's and Wil Baden's Quicksort

7 CELLS CONSTANT THRESHOLD
CELL NEGATE CONSTANT -CELL

: Precedes ( n1 n2 -- f )   U< ;

: Exchange ( a1 a2 -- )   2DUP  @ SWAP @ ROT !  SWAP ! ;

: Both-Ends ( f l pivot -- f l )
    >R  BEGIN
       OVER @ R@ Precedes WHILE
          CELL 0 D+
    REPEAT  BEGIN
       R@ OVER @ Precedes WHILE
          CELL -
    REPEAT  R> DROP ;

: Order3 ( f l -- f l pivot )
   2DUP OVER - 2/ -CELL AND + >R
   DUP @ R@ @ Precedes IF
      DUP R@ Exchange
   THEN  OVER @ R@ @ SWAP Precedes IF
      OVER R@ Exchange  DUP @ R@ @ Precedes IF
         DUP R@ Exchange
   THEN  THEN  R> ;

: Partition ( f l -- f l' f' l )
   Order3 @ >R  2DUP  CELL -CELL D+  BEGIN
      R@ Both-Ends 2DUP 1+ U< IF
         2DUP Exchange CELL -CELL D+
      THEN  2DUP SWAP U<
   UNTIL  R> DROP SWAP ROT ;

: Sink ( f key where -- f )
   ROT >R  BEGIN
      CELL - 2DUP @ Precedes WHILE
         DUP @ OVER CELL + !  DUP R@ = IF
            ! R>  EXIT
         THEN  ( key where -- )
   REPEAT  CELL + ! R> ;

: Insertion ( f l -- )
   2DUP U< IF
      CELL + OVER CELL + DO
         I @ I Sink
      CELL +LOOP  DROP
   ELSE  ( f l -- ) 2DROP
   THEN ;

: Hoarify ( f l -- ... )
   BEGIN
      2DUP THRESHOLD 0 D+ U< WHILE
         Partition  2DUP - >R  2OVER - R> > IF
            2SWAP
   THEN  REPEAT  Insertion ;

: QUICK ( f l -- )
   DEPTH >R  BEGIN
      Hoarify DEPTH R@ <
   UNTIL  R> DROP ;

: SORT ( a n -- ) \ zero n not allowed
   1- CELLS  OVER +  QUICK ;

: SORTTEST ( -- )
    FLAGS 1 1000 DO I OVER ! CELL+  -1 +LOOP DROP
    FLAGS 1000 SORT ;


0358 0BF4     THRESHOLD   SP=SP-1
0359 00060007             S0=#7
035B 0409                 Return
035C 0BF4     -CELL       SP=SP-1
035D 0103                 S0=-1
035E 0409                 Return
035F FFFF                 
0360 4110     Precedes    W=S1+(-S0), latch CF
0361 0513                 S1=-1 when C=0 (u<) else 0
0362 0814                 SP=SP+1
0363 0409                 Return
0364 0BE4     Exchange    SP=SP-2
0365 6612                 x=Data(S2)
0366 6412                 S1=x, x=Data(S2)
0367 5003                 S0=W=S3
0368 66F0                 x=Data(S0)
0369 64F0                 G7=x, x=Data(S0)
036A 6EF2                 Data(S2)=G7
036B 5021                 S2=W=S1
036C 0824                 SP=SP+2
036D 6E01                 Data(S1)=S0
036E 0824                 SP=SP+2
036F 0409                 Return
0370 3800     Both-Ends   Push S0 to return stack
0371 0814                 SP=SP+1
0372 0BE4                 SP=SP-2
0373 6613                 x=Data(S3)
0374 6413                 S1=x, x=Data(S3)
0375 3400                 S0=R0
0376 81B0                 Call 0360:Precedes
0377 4400                 W=S0
0378 0720                 Skip when W<>0, DROP
0379 1006                 Branch: P=0380
037A 0BE4                 SP=SP-2
037B 00160001             S1=#1
037D 0003                 S0=0
037E 8066                 Call 00CC:D+
037F 1FF2                 Branch: P=0372
0380 0BF4                 SP=SP-1
0381 3400                 S0=R0
0382 0BF4                 SP=SP-1
0383 6602                 x=Data(S2)
0384 6402                 S0=x, x=Data(S2)
0385 81B0                 Call 0360:Precedes
0386 4400                 W=S0
0387 0720                 Skip when W<>0, DROP
0388 1002                 Branch: P=038B
0389 5300                 S0=W=S0-1
038A 1FF5                 Branch: P=0380
038B 0BF4                 SP=SP-1
038C 3C00                 Pop S0 from return stack
038D 0814                 SP=SP+1
038E 0409                 Return
038F FFFF                 
0390 4101     Order3      W=S0+(-S1), latch CF
0391 00F5                 G7=W
0392 5FEF                 G6=W=G7/2, latch CF
0393 0183                 G0=-1
0394 4DE8                 G6=W=G6 AND G0
0395 0BF4                 SP=SP-1
0396 422E                 W=S2+G6, latch CF
0397 0005                 S0=W
0398 0BF4                 SP=SP-1
0399 3801                 Push S1 to return stack
039A 5001                 S0=W=S1
039B 6612                 x=Data(S2)
039C 6412                 S1=x, x=Data(S2)
039D 6600                 x=Data(S0)
039E 6400                 S0=x, x=Data(S0)
039F 81B0                 Call 0360:Precedes
03A0 4400                 W=S0
03A1 0720                 Skip when W<>0, DROP
03A2 1004                 Branch: P=03A7
03A3 0BE4                 SP=SP-2
03A4 5012                 S1=W=S2
03A5 3400                 S0=R0
03A6 81B2                 Call 0364:Exchange
03A7 0BE4                 SP=SP-2
03A8 6613                 x=Data(S3)
03A9 6413                 S1=x, x=Data(S3)
03AA 3400                 S0=R0
03AB 50F1                 G7=W=S1
03AC 6610                 x=Data(S0)
03AD 6410                 S1=x, x=Data(S0)
03AE 500F                 S0=W=G7
03AF 81B0                 Call 0360:Precedes
03B0 4400                 W=S0
03B1 0720                 Skip when W<>0, DROP
03B2 1012                 Branch: P=03C5
03B3 0BE4                 SP=SP-2
03B4 5013                 S1=W=S3
03B5 3400                 S0=R0
03B6 81B2                 Call 0364:Exchange
03B7 0BE4                 SP=SP-2
03B8 6612                 x=Data(S2)
03B9 6412                 S1=x, x=Data(S2)
03BA 3400                 S0=R0
03BB 6600                 x=Data(S0)
03BC 6400                 S0=x, x=Data(S0)
03BD 81B0                 Call 0360:Precedes
03BE 4400                 W=S0
03BF 0720                 Skip when W<>0, DROP
03C0 1004                 Branch: P=03C5
03C1 0BE4                 SP=SP-2
03C2 5012                 S1=W=S2
03C3 3400                 S0=R0
03C4 81B2                 Call 0364:Exchange
03C5 0BF4                 SP=SP-1
03C6 3C00                 Pop S0 from return stack
03C7 0409                 Return
03C8 81C8     Partition   Call 0390:Order3
03C9 0BD4                 SP=SP-3
03CA 66F3                 x=Data(S3)
03CB 64F3                 G7=x, x=Data(S3)
03CC 380F                 Push G7 to return stack
03CD 5005                 S0=W=S5
03CE 5024                 S2=W=S4
03CF 00160001             S1=#1
03D1 0103                 S0=-1
03D2 8066                 Call 00CC:D+
03D3 0BF4                 SP=SP-1
03D4 3400                 S0=R0
03D5 81B8                 Call 0370:Both-Ends
03D6 51F0                 G7=W=S0+1
03D7 41F1                 W=G7+(-S1), latch CF
03D8 0300                 Skip when W<>0 and C=0 (u>)
03D9 1009                 Branch: P=03E3
03DA 0BE4                 SP=SP-2
03DB 5013                 S1=W=S3
03DC 5002                 S0=W=S2
03DD 81B2                 Call 0364:Exchange
03DE 0BE4                 SP=SP-2
03DF 00160001             S1=#1
03E1 0103                 S0=-1
03E2 8066                 Call 00CC:D+
03E3 4110                 W=S1+(-S0), latch CF
03E4 0300                 Skip when W<>0 and C=0 (u>)
03E5 1FED                 Branch: P=03D3
03E6 0BF4                 SP=SP-1
03E7 3C00                 Pop S0 from return stack
03E8 50F3                 G7=W=S3
03E9 5031                 S3=W=S1
03EA 501F                 S1=W=G7
03EB 0814                 SP=SP+1
03EC 0409                 Return
03ED FFFF                 
03EE 3802     Sink        Push S2 to return stack
03EF 5021                 S2=W=S1
03F0 5010                 S1=W=S0
03F1 0814                 SP=SP+1
03F2 53F0                 G7=W=S0-1
03F3 0BE4                 SP=SP-2
03F4 5322                 S2=W=S2-1
03F5 5013                 S1=W=S3
03F6 660F                 x=Data(G7)
03F7 640F                 S0=x, x=Data(G7)
03F8 81B0                 Call 0360:Precedes
03F9 4400                 W=S0
03FA 0720                 Skip when W<>0, DROP
03FB 1012                 Branch: P=040E
03FC 51F0                 G7=W=S0+1
03FD 66E0                 x=Data(S0)
03FE 64E0                 G6=x, x=Data(S0)
03FF 6EEF                 Data(G7)=G6
0400 0BE4                 SP=SP-2
0401 5012                 S1=W=S2
0402 3400                 S0=R0
0403 4110                 W=S1+(-S0), latch CF
0404 06F3                 G7=-1 when W=0 else 0
0405 0824                 SP=SP+2
0406 440F                 W=G7
0407 0700                 Skip when W<>0
0408 1004                 Branch: P=040D
0409 6E10                 Data(S0)=S1
040A 3C01                 Pop S1 from return stack
040B 0814                 SP=SP+1
040C 0409                 Return
040D 1FE4                 Branch: P=03F2
040E 51F0                 G7=W=S0+1
040F 6E1F                 Data(G7)=S1
0410 3C01                 Pop S1 from return stack
0411 0814                 SP=SP+1
0412 0409                 Return
0413 FFFF                 
0414 4101     Insertion   W=S0+(-S1), latch CF
0415 0300                 Skip when W<>0 and C=0 (u>)
0416 1016                 Branch: P=042D
0417 0BF4                 SP=SP-1
0418 5111                 S1=W=S1+1
0419 5102                 S0=W=S2+1
041A 3801                 Push S1 to return stack
041B 3800                 Push S0 to return stack
041C 0824                 SP=SP+2
041D 340F                 G7=R0
041E 0BE4                 SP=SP-2
041F 661F                 x=Data(G7)
0420 641F                 S1=x, x=Data(G7)
0421 3400                 S0=R0
0422 81F7                 Call 03EE:Sink
0423 0BF4                 SP=SP-1
0424 00060001             S0=#1
0426 8076                 Call 00EC:(%+loop)
0427 440A                 W=G2
0428 0600                 Skip when W=0
0429 1FF3                 Branch: P=041D
042A 082C                 RP=RP+2
042B 0814                 SP=SP+1
042C 1001                 Branch: P=042E
042D 0824                 SP=SP+2
042E 0409                 Return
042F FFFF                 
0430 0BC4     Hoarify     SP=SP-4
0431 5035                 S3=W=S5
0432 5024                 S2=W=S4
0433 00160007             S1=#7
0435 0003                 S0=0
0436 8066                 Call 00CC:D+
0437 4110                 W=S1+(-S0), latch CF
0438 05F3                 G7=-1 when C=0 (u<) else 0
0439 0824                 SP=SP+2
043A 440F                 W=G7
043B 0700                 Skip when W<>0
043C 100F                 Branch: P=044C
043D 81E4                 Call 03C8:Partition
043E 4110                 W=S1+(-S0), latch CF
043F 00F5                 G7=W
0440 4132                 W=S3+(-S2), latch CF
0441 00E5                 G6=W
0442 41FE                 W=G7+(-G6), latch CF
0443 0C00                 Skip when W<0 xor V=1 (<)
0444 1006                 Branch: P=044B
0445 50F3                 G7=W=S3
0446 5031                 S3=W=S1
0447 501F                 S1=W=G7
0448 50F2                 G7=W=S2
0449 5020                 S2=W=S0
044A 500F                 S0=W=G7
044B 1FE4                 Branch: P=0430:Hoarify
044C 820A                 Call 0414:Insertion
044D 0409                 Return
044E 80DA     QUICK       Call 01B4:DEPTH
044F 3800                 Push S0 to return stack
0450 0814                 SP=SP+1
0451 8218                 Call 0430:Hoarify
0452 80DA                 Call 01B4:DEPTH
0453 0BF4                 SP=SP-1
0454 3400                 S0=R0
0455 4110                 W=S1+(-S0), latch CF
0456 0CF3                 G7=-1 when W<0 xor V=1 (<) else 0
0457 0824                 SP=SP+2
0458 440F                 W=G7
0459 0700                 Skip when W<>0
045A 1FF6                 Branch: P=0451
045B 0BF4                 SP=SP-1
045C 3C00                 Pop S0 from return stack
045D 0814                 SP=SP+1
045E 0409                 Return
045F FFFF                 
0460 53F0     SORT        G7=W=S0-1
0461 42F1                 W=G7+S1, latch CF
0462 0005                 S0=W
0463 8227                 Call 044E:QUICK
0464 0409                 Return
0465 FFFF                 
0466 0BD4     SORTTEST    SP=SP-3
0467 0026080B             S2=#2059
0469 00160001             S1=#1
046B 000603E8             S0=#1000
046D 3801                 Push S1 to return stack
046E 3800                 Push S0 to return stack
046F 0824                 SP=SP+2
0470 340F                 G7=R0
0471 6EF0                 Data(S0)=G7
0472 0BF4                 SP=SP-1
0473 5111                 S1=W=S1+1
0474 0103                 S0=-1
0475 8076                 Call 00EC:(%+loop)
0476 440A                 W=G2
0477 0600                 Skip when W=0
0478 1FF7                 Branch: P=0470
0479 082C                 RP=RP+2
047A 0BF4                 SP=SP-1
047B 0016080B             S1=#2059
047D 000603E8             S0=#1000
047F 8230                 Call 0460:SORT
0480 0409                 Return
