Category : Science and Education
Archive   : SORT-OUT.ZIP
Filename : SORT-OUT.SCR

\ Sorting Algorithms Henning Hansen 22:25 14.06.89 \ For Laboratory Microsystems PC/FORTH and PC/FORTH+ systems \ \ \ \ \ Made by Henning Hansen \ Technical University of Denmark \ building #116 \ 2800 Lyngby, Denmark \ \ \ \ \ \ \ Load 12:35 16.06.89 2 ?SCREENS THRU MAIN CR .( Make turnkey SORT-OUT ? ) ?Y/N NOT ?\ CR \\ : SORT-OUT MAIN RETURN ; TURNKEY SORT-OUT SORT-OUT \\ Remember to install resident graphics driver before use \ Tools 13:18 16.06.89 : bye BYE ; : FH ( blk-rel -- blk-abs ) BLK @ + ; VARIABLE SOUND SOUND ON : SOUND-ON/OFF SOUND @ NOT SOUND ! ; : BIP SOUND @ IF 1024 10 BEEP THEN ; : BELL SOUND @ IF 660 20 BEEP THEN ; : HONK SOUND @ IF 220 100 BEEP THEN ; : KEY-BELL ?TERMINAL NOT IF BELL THEN ; \ Request user for Yes (Y or y) or No (anything else) : ?Y/N ( --- f ) ." (Y/N) " KEY-BELL KEY DUP ASCII Y = SWAP ASCII y = OR DUP IF ." Yes " ELSE ." No " THEN ; : ?\ NOT IF [COMPILE] \ THEN ; \ skip rest of line if false : 32> WSIZE 4 = ?\ ; IMMEDIATE : 16> WSIZE 2 = ?\ ; IMMEDIATE \ PC/FORTH+ address utillities 12:27 16.06.89 \ handy words to access compiled and return addresses, 32> CR .( 32bit LMI PC/FORTH+ ) CR 32> : ', ( addr --- ) SHR4 W, ; 32> : '! ( addr1 addr2 --- ) SWAP SHR4 SWAP W! ; 32> : '@ ( addr1 -- addr2 ) W@ SHL4 ; 32> : W+! ( n addr --- ) DUP W@ ROT + SWAP W! ; 32> : (') ( --- addr ) \ "tick" macro definition - very useful 32> COMPILE R> COMPILE DUP COMPILE 2+ COMPILE >R 32> COMPILE S&O>ADDR COMPILE '@ ; IMMEDIATE \ PC/FORTH address words 12:27 16.06.89 16> CR .( 16bit LMI PC/FORTH ) CR 16> : ', , ; 16> : '! ! ; 16> : '@ @ ; 16> : W+! +! ; 16> : (') ( --- addr ) \ "tick" macro definition 16> COMPILE R> COMPILE DUP COMPILE 2+ COMPILE >R 16> COMPILE @ ; IMMEDIATE \ PC/FORTH extensions 15:35 14.06.89 ( for compatibility with PC/FORTH+ code ) 16> : S&O>ADDR ; 16> : ADDR>S&O ; 16> : W, , ; 16> : W@ @ ; 16> : W! ! ; 16> : 4+ 2+ 2+ ; 16> : 4* 2* 2* ; 16> : 4/ 2/ 2/ ; \ PC/FORTH extensions cont. 22:14 14.06.89 ( for compatibility with PC/FORTH+ code ) \ integer square-root: n --- square-root ) 16> : SQRT DUP 0< ABORT" SQRT negative argument" 16> DUP 1 > IF 16> DUP 2/ 16> BEGIN 2DUP / 16> 2DUP - ABS 1 > WHILE 16> + 2/ REPEAT 16> MIN SWAP DROP 16> THEN ; \ the SQRT provided in FORTH.SCR fails for argument = 1 \ Tools 23:08 14.06.89 \ test for odd or even : ?ODD ( n -- f ) 1 AND 0<> ; : ?EVEN ( n -- f ) 1 AND 0= ; \ integer squared ** : ** ( n -- n*n ) DUP * ; \ find median without overflowing like + 2/ may do : +2/ ( n1 n2 -- n3 ) OVER - 2/ + ; \ Shuffled Random Numbers 22:22 14.06.89 ( Based on Leonard Zettel, Forth Dimensions 4:3 ) VARIABLE SEED VARIABLE RAND-ARRAY 33 2* ALLOT : (RAND) ( --- n ) \ unshuffled random number in 16 bit range SEED @ 259 * 3 + 32767 AND DUP SEED ! ; : (SHRAND) ( --- n ) \ shuffled random number in 16 bit range RAND-ARRAY DUP 32 2* + W@ 31 AND 2* + DUP W@ (RAND) ROT W! DUP RAND-ARRAY 32 2* + W! ; : RANDOM ( n1 -- n2 ) \ scaled unshuffled random number (RAND) 32767 */ ; : SHRANDOM ( n1 -- n2 ) \ scaled shuffled random number (SHRAND) 32767 */ ; : RAND-INIT 12345 SEED ! \ to repeat random seequence 33 0 DO (RAND) RAND-ARRAY I 2* + W! LOOP ; RAND-INIT \ Timer Words 22:26 14.06.89 : @SEC/100 @TIME 256 /MOD ROT 256 /MOD 60 * + 60 * + 100 * + ; : TIME ( t1 -- t2 ) @SEC/100 - ; \ start time : TIME-OUT ( t1 -- t2 ) @SEC/100 + ; \ stop time : LAP-TIME ( t1 -- t1 t2 ) DUP TIME-OUT ; \ lap time : WAIT ( t -- ) \ wait t /100 seconds NEGATE TIME BEGIN LAP-TIME 0< NOT UNTIL DROP ; \\ example of use: : LOOP-TIME-DEMO ( n -- ) 0 TIME OVER 0 DO CR I . ." loops in " LAP-TIME . ." /100 seconds" 10 WAIT LOOP SWAP CR . ." loops in " TIME-OUT . ." /100 seconds" CR ; \ Graphics modes 12:34 16.06.89 CR .( Yes for VGA graphics ) ?Y/N DUP ?\ CR .( VGA graphics modes selected. ) DUP ?\ : GMODE ( -- ) 640X480 VMODE CLS ; \ VGA graphics DUP ?\ : AMODE ( -- ) 80X25 16COLOR VMODE CLS ; \ text CR ?\ \\ CR .( Yes for EGA graphics ) ?Y/N DUP ?\ CR .( EGA graphics modes selected. ) DUP ?\ : GMODE ( -- ) 640X350 VMODE CLS ; \ EGA graphics DUP ?\ : AMODE ( -- ) 80X25 16COLOR VMODE CLS ; \ text CR ?\ \\ CR .( Yes for CGA graphics ) ?Y/N DUP ?\ CR .( CGA graphics modes selected. ) DUP ?\ : GMODE ( -- ) 160X100 VMODE CLS ; \ CGA graphics DUP ?\ : AMODE ( -- ) 80X25 16COLOR VMODE CLS ; \ text CR NOT ?\ .( No graphics mode selected) CR HONK \ Deferred Definition with (') 22:31 14.06.89 \\ No, I don't use DEFER in this file ... : CRASH ( -- ) -1 ABORT" Undefined execution vector" ; : DEFER ( -- ) \ Allow backward reference: DEFER CREATE ['] CRASH ', DOES> '@ EXECUTE ; : (IS) (') >BODY '! ; : IS ( addr -- ) \ used: ' IS STATE @ IF COMPILE (IS) ELSE ' >BODY '! THEN ; IMMEDIATE : (REFER) (') (') >BODY '! ; : REFER ( -- ) \ used: REFER STATE @ IF COMPILE (REFER) \ alternetive to ' and IS ELSE ' ' >BODY '! THEN ; IMMEDIATE \ Local Variables, macro definition 22:31 14.06.89 \\ Just in case you might need it in another sorting algorithm : RESTORE R> R> ! ; \ restore variable address and value : LOCAL ( adr -- ) \ local-value variable COMPILE >R COMPILE R@ COMPILE @ COMPILE >R ['] RESTORE >BODY ADDR>S&O [COMPILE] LITERAL COMPILE >R ; IMMEDIATE \\ : LOCAL>> \ local-value quantity ' >BODY [COMPILE] LITERAL [COMPILE] LOCAL ; IMMEDIATE \ CASE: and MENU: 22:33 14.06.89 : (CASE:) CREATE W, ] ; : CASE: ( n -- ) (CASE:) DOES> DUP 2+ -ROT W@ MOD 2* + '@ EXECUTE ; : (MENU:) CREATE W, ] ; : MENU: ( n -- adr ) (MENU:) DOES> DUP 2+ -ROT W@ MOD 0 ?DO 2+ COUNT + ALIGN LOOP 2+ ; \\ MENU: example of use 3 MENU: ABC " MENU A" " MENU B" " MENU C" ; CR 0 ABC COUNT TYPE CR 1 ABC COUNT TYPE CR 2 ABC COUNT TYPE CR \ Screen window management 13:22 16.02.89 \\ WINDOW Create a screen window with BIOS windows support for scrolling, clear and relative text addressing. W Return address of current window. W-OUT Vectored screen output to current window (virtual screen). STD-OUT Default output vectors. Vectored VINIT executes STD-OUT. \ Screen window management 09:20 27.02.89 \\ WBORDER Draw current window border. WHEADER Draw border with text header. WCLEAR Clear window and border. STD-TYPE-ON TRUNC-TYPE-ON SPACE-TYPE-ON WRAP-TYPE-ON Set different types of TYPE. \ Window support 22:35 14.06.89 ( based on Laboratory Microsystems, Inc. FORTH.SCR ) HEX ( create wpb compilation: Xul Yul Xlr Ylr --- ) ( execution: --- wpb-addr ) : WINDOW CREATE 100 * + , 100 * + , 000 , 000 , ; ( fetch parameters for VIDEO-IO call: wpb --- dx cx bx ) : WPAR@ DUP @ SWAP WSIZE + DUP @ SWAP WSIZE + @ ; ( change initializing attribute: attrib wpb --- ) : W-ATTRIB SWAP 100 * SWAP WSIZE 2* + ! ; ( execute window function: dx cx bx ax --- ) : W-EXEC regAX ! regBX ! regCX ! regDX ! 10 INT86 ; DECIMAL \ Window support, continued 22:36 14.06.89 ( based on Laboratory Microsystems, Inc. FORTH.SCR ) HEX ( initialize window: wpb --- ) : W-CLEAR WPAR@ 0600 W-EXEC ; ( scroll window up: wpb --- ) : W-UP WPAR@ 0601 W-EXEC ; ( scroll window down: wpb --- ) : W-DOWN WPAR@ 0701 W-EXEC ; ( cursor addressing within window: x y wpb --- ) : W-GOTOXY WSIZE + @ DUP 0FF AND SWAP 100 / D+ GOTOXY ; DECIMAL \ Window support, continued 22:36 14.06.89 ( based on Laboratory Microsystems, Inc. FORTH.SCR ) HEX ( draw border around window: wpb --- ) : W-BORDER DUP >R WSIZE + @ SPLIT R> @ SPLIT OVER 1+ 4 PICK DO I 3 PICK 1- GOTOXY 0C4 EMIT I OVER 1+ GOTOXY 0C4 EMIT LOOP DUP 1+ 3 PICK DO OVER 1+ I GOTOXY 0B3 EMIT 3 PICK 1- I GOTOXY 0B3 EMIT LOOP OVER 1+ 3 PICK 1- GOTOXY 0BF EMIT ( urc ) 3 PICK 1- OVER 1+ GOTOXY 0C0 EMIT ( llc ) 1+ SWAP 1+ SWAP GOTOXY 0D9 EMIT ( lrc ) 1- SWAP 1- SWAP GOTOXY 0DA EMIT ; ( ulc ) DECIMAL \ Window support extensions 22:36 14.06.89 HEX ( change window coordinates: Xul Yul Xlr Ylr wpb --- ) : W-RESIZE >R 100 * + R@ ! 100 * + R> WSIZE + ! ; ( coordinates to parameters: Xul Yul Xlr Ylr --- dx cx bx ) : ULLR>WPAR 100 * + -ROT 100 * + 000 ; ( clear part of screen: Xul Yul Xlr Ylr --- ) : CLEAR-AREA ULLR>WPAR 0600 W-EXEC ; ( store window position : X Y wpb --- ) : W-XY! >R 100 * + R> WSIZE 3 * + ! ; ( fetch window position : wpb --- X Y ) : W-XY@ WSIZE 3 * + @ DUP 0FF AND SWAP 100 / ; DECIMAL \ Window support extensions 22:36 14.06.89 HEX ( upper left corner : wp --- Xul Yul ) : W-UL WSIZE + @ DUP 0FF AND SWAP 100 / ; ( lower left corner: wp --- Xll Yll ) : W-LL DUP WSIZE + @ 0FF AND SWAP @ 100 / ; ( lower right corner : wp --- Xlr Ylr ) : W-LR @ DUP 0FF AND SWAP 100 / ; DECIMAL \ Window support extensions 09:05 14.02.89 ( from screen to window coordinates: X Y wp --- wX wY ) : XY>WXY W-UL ROT SWAP - ROT ROT - SWAP ; ( from window to screen coordinates: wX wY wp --- X Y ) : WXY>XY W-UL D+ ; ( min of pairs of integers : x0 y0 x1 y1 -- xmin ymin ) : 2MIN >R SWAP >R MIN R> R> MIN ; ( max of pairs of integers : x0 y0 x1 y1 -- xmax ymax ) : 2MAX >R SWAP >R MAX R> R> MAX ; \ Current text window definition 22:37 14.06.89 VARIABLE ?W ?W OFF \ text window active ? VARIABLE (W) \ current text window : W (W) @ ; : SET-W ( wpb --- ) \ activate window (W) ! ; \\ 0 0 ?XMAX ?YMAX WINDOW SCREEN \ full screen window SCREEN SET-W \ don't try to draw border around SCREEN window ! \ Output vector vectors 14:43 14.02.89 32 ORIGIN+ CONSTANT VEMIT \ vector for EMIT 35 ORIGIN+ CONSTANT VTYPE \ vector for TYPE 36 ORIGIN+ CONSTANT VGOTOXY \ vector for GOTOXY 37 ORIGIN+ CONSTANT VCLS \ vector for GOTOXY 38 ORIGIN+ CONSTANT VCLREOS \ vector for GOTOXY 39 ORIGIN+ CONSTANT VCLREOL \ vector for GOTOXY 50 ORIGIN+ CONSTANT VVINIT \ vector for GOTOXY 51 ORIGIN+ CONSTANT V?XY \ vector for ?XY 56 ORIGIN+ CONSTANT Vemit \ vector for default CONSOLE EMIT 57 ORIGIN+ CONSTANT Vtype \ vector for default CONSOLE TYPE : CLREOS VCLREOS PERFORM ; \ Text output default variables 14:43 14.02.89 VARIABLE VEMIT @ ! VARIABLE VTYPE @ ! VARIABLE VGOTOXY @ ! VARIABLE VCLS @ ! VARIABLE VCLREOS @ ! VARIABLE VCLREOL @ ! VARIABLE VVINIT @ ! VARIABLE V?XY @ ! VARIABLE Vemit @ ! VARIABLE Vtype @ ! \ Window output operators 15:45 14.02.89 ( current position relative to textwindow : --- Xrel Yrel ) : W?XY PERFORM W XY>WXY ; ( go to position relative to textwindow : Xrel Yrel --- ) : WGOTOXY 0 0 2MAX SWAP W W-LR DROP W W-LL DROP - 1+ /MOD ROT + \ wrap around W WXY>XY W W-LL 2 PICK OVER > IF W W-UP 2SWAP THEN 2DROP \ scroll and goto W-LL PERFORM ; ( goto window upper left : --- ) : WHOME 0 0 WGOTOXY ; ( goto lower left corner : --- ) : WGOTOLL W W-LL W XY>WXY WGOTOXY ; \ Window output operators 09:10 27.02.89 ( emit character and goto position inside textwindow : c --- ) : WEMIT 1 OUT +! PERFORM W?XY WGOTOXY ; F: WTYPE ( type string inside window : adr count --- ) : STD-TYPE 2DUP W W-LR W XY>WXY DROP W?XY DROP 1- - \ spaces to eol DUP >R /STRING 2SWAP R> MIN \ partition string DUP 0> IF PERFORM ELSE 2DROP THEN W?XY WGOTOXY DUP 0> IF RECURSE ELSE 2DROP THEN ; \ Window output operators 09:27 27.02.89 ( type with string truncation : adr count --- ) : TRUNC-TYPE W W-LR W XY>WXY DROP W?XY DROP 1- - \ spaces to eol MIN STD-TYPE ; \ truncate to eol ( trunc-type and spaces to eol : adr count --- ) : SPACE-TYPE W W-LR W XY>WXY DROP W?XY DROP 1- - \ spaces to eol 2DUP - NEGATE >R MIN STD-TYPE R> DUP 0> IF SPACES ELSE DROP THEN ; \ Window output operators 09:28 27.02.89 ( type with string wrapping : adr count --- ) : WRAP-TYPE W W-LR W XY>WXY DROP W?XY DROP 1- - \ spaces to eol OVER < IF CR THEN STD-TYPE ; \ CR if word too long ( type string with word wrapping : adr count --- ) : WORDWRAP-TYPE BL SKIP 2DUP BL SCAN 2SWAP 2 PICK - WRAP-TYPE W?XY DROP 0> IF SPACE THEN DUP 0> IF RECURSE ELSE 2DROP THEN ; \ Type definition 09:18 27.02.89 VARIABLE ?TYPE 0 ?TYPE ! 4 CASE: XTYPE STD-TYPE TRUNC-TYPE SPACE-TYPE WORDWRAP-TYPE ; R: WTYPE ?TYPE @ XTYPE ; : STD-TYPE-ON 0 ?TYPE ! ; : TRUNC-TYPE-ON 1 ?TYPE ! ; : SPACE-TYPE-ON 2 ?TYPE ! ; : WRAP-TYPE-ON 3 ?TYPE ! ; \ Window output operators 13:05 14.02.89 ( clear and home cursor : --- ) : WCLS W W-CLEAR WHOME ; ( clear to end-of-line : --- ) : WCLREOL W?XY W WXY>XY W W-LR DROP OVER CLEAR-AREA ; ( clear to end-of-window : --- ) : WCLREOS WCLREOL W?XY W WXY>XY 1+ SWAP W W-UL DROP MIN SWAP W W-LR 2 PICK OVER > IF 2DROP 2DROP ELSE CLEAR-AREA THEN ; \ Vectored output operators 13:59 27.02.89 F: WVINIT ( set text window and vectors : wpb --- ) : W-OUT W?XY W W-XY! ['] WEMIT Vemit ! ['] WTYPE Vtype ! ['] WEMIT VEMIT ! ['] WTYPE VTYPE ! ['] WGOTOXY VGOTOXY ! ['] WCLS VCLS ! ['] WCLREOS VCLREOS ! ['] WCLREOL VCLREOL ! ['] WVINIT VVINIT ! ['] W?XY V?XY ! (W) ! ?W ON W W-XY@ WGOTOXY B/W ; \ Standard output 21:31 25.02.89 ( set standard text vectors : --- ) : STD-OUT W?XY W W-XY! @ Vemit ! @ Vtype ! @ VEMIT ! @ VTYPE ! @ VGOTOXY ! @ VCLS ! @ VCLREOS ! @ VCLREOL ! @ VVINIT ! @ V?XY ! ?W OFF 0 0 GOTOXY ; R: WVINIT STD-OUT VINIT ; : CLRSCREEN W STD-OUT CLS W-OUT ; \ Window borders 13:07 17.02.89 ( draw window border : --- ) : WBORDER ?XY >R >R ?W @ IF STD-OUT W W-BORDER W W-OUT ELSE W W-BORDER THEN R> R> GOTOXY ; ( type header of window : adr wpb --- ) : W-HEAD >R COUNT R@ W-LR DROP R@ W-UL DROP - DUP >R MIN R> OVER - 1+ 2/ R> W-UL >R + R> 1- GOTOXY TYPE ; ( draw border with text heading : adr --- ) : WHEADER ?XY >R >R ?W @ IF STD-OUT W W-BORDER W W-HEAD W W-OUT ELSE W W-BORDER W W-HEAD THEN R> R> GOTOXY ; ( erase window border : --- ) : -WBORDER 0 FOREGROUND WBORDER B/W ; ( clear textwindow and border : --- ) : WCLEAR -WBORDER W W-CLEAR ; \ Menu windows 22:40 14.06.89 \\ Use MENU: to define an array of menu texts to be selected from menu window, and CASE: to define actions to be executed. MENU ( n0 -- n ) Execute menu selection. Brings up a menu from texts texts defined with MENU: , manage selection by the user with , , , and arrow-keys. Other keys will jump to menu beginning with pressed character. Sets up menu with n0 as default menu number, and returns the number of the selected menu-text. MENU uses the current window, set with SET-W. \ Menu windows 22:41 14.06.89 VARIABLE MTEXTS \ strings of menu-texts, MENU: definition VARIABLE WLINES \ number of window lines VARIABLE MLINES \ number of menu lines VARIABLE MUPPER \ upper menu-line in window VARIABLE MPOINT \ selected menu line : MENU-TEXT ( n --- adr ) MTEXTS @ EXECUTE ; : MENU-TYPE STD-TYPE-ON W W-LR W XY>WXY DROP W?XY DROP - \ spaces to eol-1 2DUP - NEGATE >R MIN STD-TYPE R> DUP 0> IF SPACES ELSE DROP THEN ; \ Menu windows 22:41 14.06.89 ( goto start of menu-line : n --- ) : GOTOML 1 SWAP WGOTOXY ; ( type menu line : n --- ) : TYPEML DUP MUPPER @ - GOTOML MENU-TEXT COUNT MENU-TYPE ; : RTYPEML REVERSE TYPEML REVERSE ; : M?MORE WHOME MUPPER @ 0> IF ASCII * ELSE BL THEN EMIT WGOTOLL MLINES @ MUPPER @ - WLINES @ - 0> IF ASCII * ELSE BL THEN EMIT WHOME ; \ Menu windows 10:47 04.04.89 ( show menu in window : --- ) : SHOW-MENU M?MORE WLINES @ MLINES @ MIN 0 DO I MUPPER @ + DUP MPOINT @ = IF RTYPEML ELSE TYPEML THEN LOOP ; ( scroll menu if neccessary to show line : n --- f ) : ?MSCROLL MUPPER @ SWAP DUP MUPPER @ MIN MUPPER ! WLINES @ 1- - MUPPER @ MAX MUPPER ! MUPPER @ <> ; : MSHOW ( n --- ) ?TERMINAL NOT IF ?MSCROLL SHOW-MENU THEN DROP ; \ Menu windows 22:42 14.06.89 ( remember: select menu window with SET-W ) ( initialize menu: n0 --- ) : INIT-MENU W W-OUT W W-LL SWAP DROP W W-UL SWAP DROP - 1+ WLINES ! 0 MUPPER ! MTEXTS @ >BODY W@ MLINES ! DUP MPOINT ! WCLS MSHOW ; \ Key Constants 15:11 17.04.89 \ Ctrl-key codes, returns 0 and code. 82 CONSTANT 83 CONSTANT 71 CONSTANT 79 CONSTANT 73 CONSTANT 81 CONSTANT 72 CONSTANT 75 CONSTANT 77 CONSTANT 80 CONSTANT \ Key codes for non-Ctrl keys. 13 CONSTANT 27 CONSTANT \ Pointing out in menu 12:36 16.06.89 VARIABLE ?MENU VARIABLE ?ESC VARIABLE ?MP : MPOINT-TO ( n --- ) MLINES @ MOD MPOINT ! ?MP ON ; : POINT-MENU ( --- key ) \ until non-Ctrl key BEGIN KEY DUP 0= WHILE ?MP OFF DROP KEY DUP = IF 0 MPOINT-TO THEN DUP = IF MLINES @ 1- MPOINT-TO THEN DUP = IF MUPPER @ DUP MPOINT @ = IF WLINES @ 1- - THEN 0 MAX MPOINT-TO THEN DUP = IF MUPPER @ WLINES @ 1- + DUP MPOINT @ = IF WLINES @ 1- + THEN MLINES @ 1- MIN MPOINT-TO THEN DUP = IF MPOINT @ 1- MPOINT-TO THEN DUP = IF MPOINT @ 1+ MPOINT-TO THEN DROP ?MP @ NOT IF BIP THEN MPOINT @ MSHOW REPEAT ; \ Menu windows 12:36 16.06.89 : CHAR-POINT ( key -- key ) MPOINT @ BEGIN 1+ MLINES @ MOD DUP MPOINT @ = >R 2DUP MENU-TEXT COUNT DROP C@ = DUP IF OVER MPOINT-TO THEN R> OR UNTIL MSHOW ; : SELECT-MENU ?MENU ON ?ESC OFF BEGIN POINT-MENU ?MP OFF CHAR-POINT DUP = IF ?MENU OFF ?MP ON ?ESC ON THEN DUP = IF ?MENU OFF ?MP ON THEN DROP ?MP @ NOT IF BIP THEN ?MENU @ NOT UNTIL ?ESC @ IF -1 MPOINT ! THEN MPOINT @ ; ( execute menu and select menu number : n0 --- n ) : MENU (') MTEXTS ! ( W >R ) INIT-MENU SELECT-MENU ( R> W-OUT ) ; \ Sorting algorithms visualization program 23:04 14.06.89 \\ The previous screens contain some general purpose tools, the menu-system being a major one. From this screen on, the subject is sorting algorithms and visualisation. Focus is not on fast implementation of sorting routines, but on theoretical properties of the algorithms. However, if you need a sorting routine, you may select one from this collection and optimize it for your own needs. They have been tested extensively. Compile the file and try out the possibilities. They make characteristic patterns when illustrated with color graphics. \ Variables 14:36 13.06.89 VARIABLE #SORT \ sorting algorithm number VARIABLE #SUBSORT \ subsort for Partitionsort VARIABLE #SHELLSEQ \ increment sequence for Shellsort VARIABLE #DEMO \ demo number VARIABLE #PAL \ palette number 0 #SORT ! 0 #SUBSORT ! 5 #SHELLSEQ ! 0 #DEMO ! 0 #PAL ! \ Forward references for sorting interface 17:03 18.06.89 F: COMPARE F: EXCHANGE F: MOVE F: TRACE : DUMMY ; \ no-operation definition \\ SORT ( n2 n1 --- ) \ sort elements numbered n1 to n2 COMPARE ( n2 n1 -- f ) \ compare 2 elements, n2 ; \ Interchange OBJECT(1) and OBJECT(2) : EXCHANGE ( n1 n2 --- ) 2DUP @ SWAP @ ROT ! SWAP ! ; \ Move operation in terms of exchange : MOVE-LEFT ( n2 n1 --- ) \ n2>n1 SWAP 1- DO I DUP 1+ EXCHANGE -1 +LOOP ; : MOVE-RIGHT ( n1 n2 --- ) \ n1 IF COMPARE ELSE 2DROP FALSE THEN ; : ?EXCHANGE 2DUP <> IF EXCHANGE ELSE 2DROP THEN ; : NO-NAME ." None " ; : NO-SORT ( h l -- ) TRACE 2DROP ; \ 2SORT 3SORT 10:34 12.06.89 : 2SORT ( b a -- ) \ sort a and b 2DUP COMPARE IF EXCHANGE ELSE 2DROP THEN ; ( A IF ODD-X ELSE EVEN-X THEN TRACE LOOP 2DROP ; \ Bubble Sort 17:03 18.06.89 : BUBBLE-NAME ." Bubblesort " ; : BUBBLE ( n i -- n ) \ bobble down to depth i OVER 1- DO I 1+ I 2DUP COMPARE IF EXCHANGE ELSE 2DROP THEN -1 +LOOP ; : BUBBLE-SORT ( h l -- ) TRACE \ sort by bubbling n-1 times OVER SWAP ?DO I BUBBLE TRACE LOOP DROP ; \ Shakersort, straight 17:03 18.06.89 : SHAKER-NAME ." Simple Shakersort " ; : >SHAKE ( h l -- h-1 l ) 2DUP DO I 1+ I 2DUP COMPARE IF EXCHANGE ELSE 2DROP THEN LOOP SWAP 1- SWAP ; : WHILE ?ODD IF >SHAKE ELSE IF SHAKE ELSE 2DROP THEN ; \ Shakersort with flag 17:03 18.06.89 : SHAKERF-NAME ." Shakersort with flag " ; VARIABLE FIN? : >SHAKEF ( h l -- h-1 l ) 2DUP DO I 1+ I 2DUP COMPARE IF EXCHANGE FIN? OFF ELSE 2DROP THEN LOOP SWAP 1- SWAP ; : FIN? @ NOT AND WHILE FIN? ON ?ODD IF >SHAKEF ELSE IF SHAKEF ELSE 2DROP THEN ; \ Shaker Sort with interval reduction 17:03 18.06.89 : SHAKERI-NAME ." Shakersort with interval reduction " ; VARIABLE EXCHLAST VARIABLE SHAKER : >SHAKEI ( h l -- h-1 l ) DUP EXCHLAST ! 2DUP DO I 1+ I 2DUP COMPARE IF 2DUP MIN EXCHLAST ! EXCHANGE ELSE 2DROP THEN LOOP SWAP DROP EXCHLAST @ SWAP ; : WHILE SHAKER @ DUP NEGATE SHAKER ! 0> IF >SHAKEI ELSE IF SHAKEI ELSE 2DROP THEN ; \ Shuttle Sort 17:03 18.06.89 : SHUTTLE-NAME ." Shuttlesort / Sifting " ; : SHUTTLE ( z i -- z ) \ insert i'th object BEGIN 2DUP > IF FALSE ELSE DUP 1+ OVER COMPARE THEN WHILE DUP 1+ OVER EXCHANGE 1- REPEAT DROP ; : SHUTTLE-SORT ( h l --- ) TRACE \ sort by inserting n-1 times SWAP OVER ?DO I SHUTTLE TRACE LOOP DROP ; \ Lin. Insertion Sort 17:03 18.06.89 : LINSERT-NAME ." Straight Insertionsort " ; : POINT-LIN ( z i -- i x ) \ find place to insert linear search DUP BEGIN 2 PICK OVER = IF TRUE ELSE 2DUP 1- COMPARE IF 1- FALSE ELSE TRUE THEN THEN UNTIL ROT DROP ; : LINSERT ( z i -- z ) \ insert i'th object by shift-operation 1+ OVER SWAP POINT-LIN 2DUP > IF MOVE ELSE 2DROP THEN ; : LINSERT-SORT ( h l --- ) TRACE \ sort by inserting n-1 times SWAP OVER ?DO I LINSERT TRACE LOOP DROP ; \ Ass. Insertion Sort 17:03 18.06.89 : AINSERT-NAME ." Binary Insertionsort, assymmetric " ; : POINT-AIN ( i i z -- i x ) \ find place to insert 1 BEGIN DUP 0> DUP IF >R 3 PICK 3 PICK 2 PICK - COMPARE R> AND THEN WHILE ROT OVER - -ROT 2* 2 PICK 2 PICK - MIN REPEAT SWAP DROP OVER SWAP - BEGIN 2DUP 1+ > WHILE 2DUP +2/ 3 PICK OVER COMPARE IF ROT DROP SWAP ELSE SWAP DROP THEN REPEAT DROP ; : AINSERT ( z i -- z ) \ insert i'th object with shift 1+ 2DUP SWAP POINT-AIN 2DUP > IF MOVE ELSE 2DROP THEN ; : AINSERT-SORT ( h l --- ) TRACE \ sort by inserting n-1 times SWAP OVER ?DO I AINSERT TRACE LOOP DROP ; \ Bin. Insertion Sort 17:03 18.06.89 : BINSERT-NAME ." Binary Insertionsort, symmetric " ; : POINT-BIN ( i i z -- i x ) \ find place to insert 2DUP COMPARE NOT IF \ use binary search BEGIN 2DUP 1+ > WHILE 2DUP +2/ 3 PICK OVER COMPARE 0< IF ROT DROP SWAP ELSE SWAP DROP THEN REPEAT ELSE SWAP THEN DROP ; : BINSERT ( z i -- z ) \ insert i'th object with shift 1+ 2DUP SWAP POINT-BIN 2DUP > IF MOVE ELSE 2DROP THEN ; : BINSERT-SORT ( h l --- ) TRACE \ sort by inserting n-1 times SWAP OVER ?DO I BINSERT TRACE LOOP DROP ; \ Selection Sort 17:03 18.06.89 : SELECTION-NAME ." Selectionsort " ; : POINT-OUT ( n i -- x ) \ find object to select DUP ROT 1- DO I 1+ OVER COMPARE IF DROP I 1+ THEN -1 +LOOP ; : SELECT ( n i -- n ) \ select i'th object 2DUP POINT-OUT ?EXCHANGE ; : SELECTION-SORT ( h l -- ) TRACE \ sort by selecting n-1 times OVER SWAP ?DO I SELECT TRACE LOOP DROP ; \\ use more COMPAREs for equal keys : POINT-OUT ( n i -- x ) DUP -ROT DO I 1+ OVER COMPARE IF DROP I 1+ THEN LOOP ; \ Selection Sort, stable 17:03 18.06.89 : SSELECTION-NAME ." Selectionsort, stable " ; : SPOINT-OUT ( n i -- x ) DUP -ROT DO I 1+ OVER COMPARE IF DROP I 1+ THEN LOOP ; : SSELECT ( n i -- n ) \ select i'th object 2DUP SPOINT-OUT SWAP 2DUP > IF MOVE ELSE 2DROP THEN ; : SSELECTION-SORT ( h l - ) TRACE \ sort by selecting n-1 times OVER SWAP ?DO I SSELECT TRACE LOOP DROP ; \ Stacksort, recursive 17:03 18.06.89 : STACK-NAME ." Stacksort " ; \ selection and exchanging all elements of less value than E(h) : STACKSELECT ( h l -- h l ) ( 2DUP > IF ) OVER 1- SWAP BEGIN 2DUP < NOT WHILE OVER 3 PICK COMPARE NOT ( max. exchange distance ) \ 2 PICK 2 PICK COMPARE ( best for multiple keys ) IF SWAP 1- SWAP ELSE RECURSE THEN REPEAT SWAP DROP 2DUP > IF 2DUP EXCHANGE THEN ( THEN ) 1+ TRACE ; : STACK-SORT ( h l -- ) TRACE BEGIN 2DUP > WHILE STACKSELECT REPEAT 2DROP ; \ Stacksort, stable 17:03 18.06.89 : SSTACK-NAME ." Stacksort, stable " ; : SSTACKSELECT ( h l -- h l ) \ selection and exchanging all elements of less value than E(h) ( 2DUP > IF ) OVER 1- SWAP BEGIN 2DUP < NOT WHILE 2 PICK 2 PICK COMPARE IF SWAP 1- SWAP ELSE RECURSE THEN REPEAT SWAP DROP 2DUP > IF 2DUP MOVE THEN ( THEN ) 1+ TRACE ; : SSTACK-SORT ( h l -- ) TRACE BEGIN 2DUP > WHILE SSTACKSELECT REPEAT 2DROP ; \ Heap Sort 17:03 18.06.89 : HEAP-NAME ." Heapsort / Treesort " ; : HEAP ( h l k -- h l ) \ insert in heap BEGIN >R 2DUP 1- +2/ R> SWAP OVER < IF DROP TRUE ELSE 2DUP OVER - 2* + 1+ DUP 1+ DUP 5 PICK > NOT IF 2DUP COMPARE IF SWAP THEN THEN DROP ( h l k k> ) 2DUP COMPARE IF 2DUP EXCHANGE SWAP DROP FALSE ELSE 2DROP TRUE THEN THEN UNTIL ; : HEAP-SORT ( h l -- ) TRACE 2DUP - 2 < IF 2DUP > IF TRACE 2SORT ELSE 2DROP THEN ELSE 2DUP 1- +2/ OVER SWAP DO I HEAP -1 +LOOP TRACE BEGIN 2DUP EXCHANGE SWAP 1- SWAP DUP HEAP TRACE 2DUP - 1 = UNTIL EXCHANGE THEN TRACE ; \ Shellsort 17:03 18.06.89 \\ This is standard Shellsort with fixed increment sequence : SHELL-SIFT ( l m i -- l m ) \ insert modulo m BEGIN 2 PICK OVER > IF FALSE ELSE 2DUP + OVER COMPARE THEN WHILE 2DUP + OVER EXCHANGE OVER - REPEAT DROP ; : SHELL-PASS ( h l m -- h l m ) \ sort modulo m 2 PICK 1+ OVER - 2 PICK DO I SHELL-SIFT LOOP ; : SHELL-SORT ( h l -- ) TRACE 2DUP - 1+ 2/ 0 BEGIN 3 * 1+ 2DUP < UNTIL SWAP DROP BEGIN 3 / DUP 0> WHILE SHELL-PASS TRACE REPEAT DROP 2DROP ; \ Shellsort sequences 23:30 14.06.89 2VARIABLE 2SEQ F: ?SDECR : DFIB 1 = IF 0 ELSE 2SEQ 2@ OVER - OVER 2SEQ 2! THEN ; : IFIB 2DUP - 1+ 2/ 1 1 BEGIN 2 PICK OVER < NOT WHILE SWAP OVER + REPEAT 2DUP 2SEQ 2! -ROT 2DROP ; : DFIB/2 1 = IF 0 ELSE 2SEQ 2@ 2 0 DO OVER - SWAP LOOP SWAP OVER 2SEQ 2! THEN ; : IFIB/2 2DUP - 1+ 2/ 1 1 BEGIN 2 PICK OVER < NOT WHILE 2 0 DO SWAP OVER + LOOP REPEAT 2DUP 2SEQ 2! -ROT 2DROP ; \ Shellsort sequences 23:30 14.06.89 : DFIB/3 1 = IF 0 ELSE 2SEQ 2@ 3 0 DO OVER - SWAP LOOP SWAP OVER 2SEQ 2! THEN ; : IFIB/3 2DUP - 1+ 2/ 1 1 BEGIN 2 PICK OVER < NOT WHILE 3 0 DO SWAP OVER + LOOP REPEAT 2DUP 2SEQ 2! -ROT 2DROP ; : D2N+1 2/ ; : I2N+1 2DUP - 1+ 0 BEGIN 2* 1+ 2DUP < UNTIL SWAP DROP ?SDECR ; \ Shellsort sequences 23:31 14.06.89 : D3N+1 3 / ; : I3N+1 2DUP - 1+ 0 BEGIN 3 * 1+ 2DUP < UNTIL SWAP DROP ?SDECR ; : D4N+1 4 / ; : I4N+1 2DUP - 1+ 0 BEGIN 4 * 1+ 2DUP < UNTIL SWAP DROP ?SDECR ; : DFIB* 1 = IF 0 ELSE 2SEQ 2@ 1- OVER / OVER 2SEQ 2! THEN ; : IFIB* 2DUP - 1+ 2/ 1 1 BEGIN 2 PICK OVER < NOT WHILE SWAP OVER * 1+ REPEAT 2DUP 2SEQ 2! -ROT 2DROP ; \ Shellsort sequences 23:31 14.06.89 : D3N-1 1+ 3 / ; : I3N-1 2DUP - 1 BEGIN 3 * 1- 2DUP < UNTIL SWAP DROP ?SDECR ; : D4N-1 1+ 4 / ; : I4N-1 2DUP - 1 BEGIN 4 * 1- 2DUP < UNTIL SWAP DROP ?SDECR ; : D4N 4 / ; : I4N 2DUP - 1 BEGIN 4 * 2DUP < UNTIL SWAP DROP ?SDECR ; \ Shellsort sequences 22:36 30.05.89 10 CASE: CASE-INIT IFIB IFIB/2 IFIB/3 IFIB* I2N+1 I3N+1 I4N+1 I3N-1 I4N-1 I4N ; 10 CASE: CASE-DECR DFIB DFIB/2 DFIB/3 DFIB* D2N+1 D3N+1 D4N+1 D3N-1 D4N-1 D4N ; : SHELL-DECR #SHELLSEQ @ CASE-DECR ; : SHELL-INIT #SHELLSEQ @ CASE-INIT ; R: ?SDECR DUP SHELL-DECR 1 > IF SHELL-DECR THEN ; \ Shell-Insert Sort 17:03 18.06.89 : INS.SHELL-NAME ." Shellsort with sift-insertion " ; : SEL.SHELL-NAME ." Shellsort with stack-selection " ; : SHELL-INSERT ( l m i -- l m ) \ insert modulo m BEGIN 2 PICK OVER > IF FALSE ELSE 2DUP + OVER COMPARE THEN WHILE 2DUP + OVER EXCHANGE OVER - REPEAT DROP ; : INS.SHELL-SORT ( h l -- ) TRACE SHELL-INIT BEGIN SHELL-DECR DUP 0> WHILE 2 PICK 1+ OVER - 2 PICK 2SWAP DUP 0 DO 2OVER I + ?DO I SHELL-INSERT DUP +LOOP TRACE LOOP 2SWAP 2DROP REPEAT DROP 2DROP ; \ Shell-Select Sort 17:03 18.06.89 VARIABLE SHELLNO : SHPOINT-OUT ( n n ... nx x i -- n n ... ni ) \ experimental 2DUP > IF >R 1- R> 2DUP - SHELLNO @ MOD SWAP >R - R> BEGIN 2DUP < NOT WHILE >R 2DUP COMPARE NOT IF DUP THEN SHELLNO @ - R> REPEAT 2DROP ELSE 2DROP THEN 2DUP = IF DUP THEN ; : SHELL-SELECT ( n n ... x i -- n n ... x ) DUP >R SHPOINT-OUT DUP R> 2DUP = IF 2DROP ELSE EXCHANGE THEN 2DUP > IF 1+ THEN ; : SEL.SHELL-SORT ( h l --- ) TRACE SHELL-INIT SHELLNO ! BEGIN SHELLNO @ SHELL-DECR DUP SHELLNO ! 0> WHILE SHELLNO @ 0 DO 2DUP I + SWAP OVER - DUP SHELLNO @ MOD - OVER + DUP ROT OVER DUP ROT ?DO I SHELL-SELECT SHELLNO @ +LOOP TRACE DROP 2DROP LOOP REPEAT 2DROP ; \ Splicesort names 23:33 14.06.89 : SPLICE-NAME ." Splicesort " ; : ISPLICE-NAME ." Splicesort with insertion " ; : SSPLICE-NAME ." Splicesort with selection " ; \ Splicesort, Ordinary 17:03 18.06.89 VARIABLE D VARIABLE L0 VARIABLE L1 VARIABLE L2 VARIABLE L3 VARIABLE T? : SPLICE ( h l d -- h l d ) \ from 2d-sorted to d-sorted DUP D ! 0 DO DUP I + DUP L1 ! D @ + L2 ! BEGIN OVER L2 @ < NOT WHILE T? ON L2 @ L1 @ COMPARE IF L2 @ BEGIN DUP D @ - SWAP OVER EXCHANGE DUP L1 @ = UNTIL DROP D @ DUP L1 +! 2* L2 +! ELSE D @ L1 +! L1 @ L2 @ = IF D @ L2 +! THEN THEN REPEAT T? @ IF TRACE T? OFF THEN LOOP D @ ; : SPLICE-SORT ( h l -- ) TRACE 2DUP - 1 BEGIN 2* 2DUP < UNTIL 2/ SWAP DROP BEGIN DUP 0> WHILE SPLICE 2/ REPEAT DROP 2DROP ; \ Splice Sort, with insertion 23:34 14.06.89 : ISPLICE2 L1 @ L3 @ = IF D @ DUP L3 +! 2* L1 +! ELSE L1 @ L0 @ > IF D @ 2* L3 +! L2 @ BEGIN DUP D @ 2* - SWAP OVER DUP L3 @ < NOT WHILE EXCHANGE REPEAT 2DROP DROP ELSE D @ 2* L1 +! THEN THEN D @ DUP L0 +! 2* L2 +! ; : ISPLICE3 L1 @ L3 @ = IF D @ DUP L1 +! DUP L2 +! L3 +! ELSE L1 @ L0 @ > IF D @ 2* L3 +! L3 @ L2 @ = IF L1 @ L3 ! THEN ELSE L3 @ BEGIN DUP D @ 2* + SWAP OVER DUP L2 @ < WHILE EXCHANGE REPEAT 2DROP DROP D @ 2* L1 +! THEN THEN D @ L0 +! ; \ Splice Sort, Insertion 17:03 18.06.89 : ISPLICE ( h l d -- h l d ) \ from 2d-sorted to d-sorted DUP D ! 0 DO DUP I + DUP L0 ! DUP L1 ! DUP D @ + L2 ! L3 ! BEGIN OVER L1 @ D @ + < NOT WHILE OVER L2 @ < NOT DUP IF L2 @ L3 @ COMPARE AND THEN IF L0 @ L2 @ EXCHANGE ISPLICE2 ELSE L0 @ L3 @ ?EXCHANGE ISPLICE3 THEN T? ON REPEAT T? @ IF TRACE THEN T? OFF LOOP D @ ; : ISPLICE-SORT ( h l -- ) TRACE 2DUP - 1 BEGIN 2* 2DUP < UNTIL 2/ SWAP DROP BEGIN DUP 0> WHILE ISPLICE 2/ REPEAT DROP 2DROP ; \ Splice Sort, with selection 23:34 14.06.89 : SSPLICE2 L1 @ L3 @ = IF D @ DUP L3 +! 2* L1 +! ELSE L1 @ L0 @ > IF L0 @ L3 @ = IF L2 @ L3 ! THEN ELSE D @ 2* L1 +! THEN THEN D @ DUP L0 +! 2* L2 +! ; : SSPLICE3 L1 @ L3 @ = IF D @ DUP L1 +! DUP L2 +! L3 +! ELSE L1 @ L0 @ > IF L2 @ L0 @ D @ 2* + > NOT IF L1 @ L3 ! ELSE L0 @ D @ 2* + DUP BEGIN D @ 2* + DUP L2 @ < WHILE 2DUP COMPARE NOT IF SWAP DROP DUP THEN REPEAT DROP L3 ! THEN ELSE D @ 2* L1 +! L0 @ D @ 3 * + L2 @ < IF L0 @ D @ + DUP L3 @ = IF D @ 2* + THEN DUP BEGIN D @ 2* + DUP L3 @ = IF D @ 2* + THEN DUP L2 @ < WHILE 2DUP COMPARE NOT IF SWAP DROP DUP THEN REPEAT DROP L3 ! THEN THEN THEN D @ L0 +! ; \ Splice Sort, Select 17:03 18.06.89 : SSPLICE ( h l d -- h l d ) \ from 2d-sorted to d-sorted DUP D ! 0 DO DUP I + DUP L0 ! DUP L1 ! DUP D @ + L2 ! L3 ! BEGIN OVER L1 @ D @ + < NOT WHILE OVER L2 @ < NOT DUP IF L2 @ L3 @ COMPARE AND THEN IF L0 @ L2 @ EXCHANGE SSPLICE2 ELSE L0 @ L3 @ ?EXCHANGE SSPLICE3 THEN T? ON REPEAT T? @ IF TRACE THEN T? OFF LOOP D @ ; : SSPLICE-SORT ( h l -- ) TRACE 2DUP - 1 BEGIN 2* 2DUP < UNTIL 2/ SWAP DROP BEGIN DUP 0> WHILE SSPLICE 2/ REPEAT DROP 2DROP ; \ Batcher Sort 17:03 18.06.89 : BATCHER-NAME ." Batchersort " ; VARIABLE DD VARIABLE PP VARIABLE QQ VARIABLE RR VARIABLE SS : BATCHER ( h l p -- h l p ) DUP PP ! DD ! 0 RR ! SS @ QQ ! BEGIN TRACE OVER 1+ DD @ - OVER ?DO I OVER - PP @ AND RR @ = IF I DD @ + I 2SORT THEN LOOP QQ @ PP @ 2DUP <> WHILE 2DUP - DD ! RR ! 2/ QQ ! REPEAT SWAP DROP ; : BATCHER-SORT ( h l --- ) 2DUP - 2 < IF 2DUP > IF TRACE 2SORT ELSE 2DROP THEN ELSE 2DUP - 1 BEGIN 2* 2DUP < UNTIL SWAP DROP 2/ DUP SS ! BEGIN BATCHER 2/ DUP 0= UNTIL DROP 2DROP THEN TRACE ; \ Merge Sort 17:03 18.06.89 : MERGE-NAME ." Mergesort, binary " ; : MERGE ( hh hl lh ll -- h l ) \ merge with shifts 3 PICK OVER 2ROT 2ROT BEGIN ROT SWAP 2DUP COMPARE IF 2DUP MOVE ROT 1+ ROT 1+ ROT THEN 1+ ROT SWAP 2OVER 2OVER < ROT ROT < OR UNTIL 2DROP 2DROP ; : SORTMERGE ( h l -- h l ) \ Recursive merge sort 2DUP 1+ +2/ DUP 1- ROT 2DUP > IF RECURSE THEN 2SWAP 2DUP > IF RECURSE THEN 2SWAP MERGE TRACE ; : MERGE-SORT ( h l --- ) TRACE 2DUP > IF SORTMERGE THEN 2DROP ; \ Natural Merge Sort 17:03 18.06.89 : NAT.MERGE-NAME ." Mergesort, natural " ; VARIABLE MDEPTH : STACK-NATURAL ( h l -- stk ) 1 MDEPTH ! 2DUP ?DO I 1+ I COMPARE IF I OVER 2SWAP DROP I 1+ 1 MDEPTH +! THEN LOOP ; : STACK-MERGE ( stk -- h l ) BEGIN MDEPTH @ 1 > WHILE MDEPTH @ 2* 1- >R R@ ROLL R@ ROLL R@ ROLL R> ROLL 2 PICK 2 PICK > IF MDEPTH @ 2* 1- >R R@ ROLL R> ROLL THEN 2SWAP MERGE -1 MDEPTH +! TRACE REPEAT ; : MERGE-NATURAL ( h l -- h l ) STACK-NATURAL TRACE STACK-MERGE ; : NAT.MERGE-SORT ( h l --- ) TRACE 2DUP > IF MERGE-NATURAL THEN 2DROP ; \ not very elegant implementation \ Quick-sort names 22:58 12.06.89 VARIABLE PIVOT : MQUICK-NAME ." Quicksort, middle element partition " ; : 1QUICK-NAME ." Quicksort, first element partition " ; : RQUICK-NAME ." Quicksort, random element partition " ; : M3QUICK-NAME ." Quicksort, median-of-three partition " ; : XQUICK-NAME ." Middle partition + other method " ; : X3QUICK-NAME ." Median-of-3 partition + other method " ; \ Quicksort, first element partition 17:03 18.06.89 : 1PARTITION ( h l p --- hh lh hl ll ) \ 1. element partition PIVOT ! 2DUP 1- SWAP 1+ BEGIN SWAP BEGIN 1+ 2DUP > NOT IF FALSE ELSE DUP PIVOT @ ?COMPARE THEN NOT UNTIL SWAP BEGIN 1- 2DUP > IF FALSE ELSE PIVOT @ OVER ?COMPARE THEN NOT UNTIL 2DUP < WHILE 2DUP EXCHANGE REPEAT DUP PIVOT @ ?EXCHANGE 2DUP = IF 1+ SWAP 1- THEN ROT ; : QUICKPART ( h l -- ) \ Recursive partition sort DUP 1+ SWAP 1PARTITION 1- TRACE \ 2OVER 2OVER - + < IF 2SWAP THEN \ smallest first 2DUP > IF RECURSE ELSE 2DROP THEN 2DUP > IF RECURSE ELSE 2DROP THEN ; : 1QUICK-SORT ( h l -- ) TRACE 2DUP > IF QUICKPART ELSE 2DROP THEN ; \ Quicksort, random element partition 17:03 18.06.89 : PARTITION ( h l p --- hh lh hl ll ) \ inside elem. partition PIVOT ! 2DUP 1- SWAP 1+ BEGIN SWAP BEGIN 1+ DUP PIVOT @ ?COMPARE NOT UNTIL SWAP BEGIN 1- PIVOT @ OVER ?COMPARE NOT UNTIL 2DUP < WHILE DUP PIVOT @ = IF OVER PIVOT ! ELSE OVER PIVOT @ = IF DUP PIVOT ! THEN THEN 2DUP EXCHANGE REPEAT 2DUP = IF 1+ SWAP 1- THEN ROT ; : RANDOMPART ( h l -- ) \ Recursive partition sort 2DUP - 1- SHRANDOM OVER + 1+ PARTITION TRACE \ 2OVER 2OVER - + < IF 2SWAP THEN \ smallest first 2DUP > IF RECURSE ELSE 2DROP THEN 2DUP > IF RECURSE ELSE 2DROP THEN ; : RQUICK-SORT ( h l -- ) TRACE 2DUP > IF RANDOMPART ELSE 2DROP THEN ; \ Quicksort, middle element partition 17:03 18.06.89 : MIDPART ( h l -- ) \ Recursive partition sort 2DUP +2/ PARTITION TRACE \ 2OVER 2OVER - + < IF 2SWAP THEN \ smallest first 2DUP > IF RECURSE ELSE 2DROP THEN 2DUP > IF RECURSE ELSE 2DROP THEN ; : MQUICK-SORT ( h l -- ) TRACE 2DUP > IF MIDPART ELSE 2DROP THEN ; \ Quicksort, median of three 17:03 18.06.89 : <3SORT ( h l -- ) \ sort 3 or less 2DUP 2+ = IF 2DUP +2/ SWAP 3SORT ELSE 2DUP 1+ = IF 2SORT ELSE 2DROP THEN THEN TRACE ; : M3PART ( h l -- ) \ Recursive partition sort 2DUP 2DUP +2/ SWAP 3SORT TRACE SWAP 1- SWAP 1+ 2DUP +2/ PARTITION 2SWAP SWAP 1+ SWAP 2SWAP 1- TRACE \ 2OVER 2OVER - + < IF 2SWAP THEN \ smallest first 2DUP - 3 < IF <3SORT ELSE RECURSE THEN 2DUP - 3 < IF <3SORT ELSE RECURSE THEN ; : M3QUICK-SORT ( h l -- ) TRACE 2DUP - 3 < IF <3SORT ELSE M3PART THEN ; \ Mixed-Quick Sort, middle element 17:03 18.06.89 VARIABLE QMIXER 10 QMIXER ! F: SUBSORT : QMIX ( h l -- ) \ Recursive mixed partition sort 2DUP - QMIXER @ < IF SUBSORT ELSE 2DUP +2/ PARTITION TRACE \ 2OVER 2OVER - + < IF 2SWAP THEN \ smallest first 2DUP > IF RECURSE ELSE 2DROP THEN 2DUP > IF RECURSE ELSE 2DROP THEN THEN ; : XQUICK-SORT ( h l -- ) TRACE \ 2DUP - 2* SQRT QMIXER ! 2DUP > IF QMIX ELSE 2DROP THEN ; \ Mixed-Quick Sort, median-of-three 17:05 18.06.89 : QM3MIX ( h l -- ) \ Recursive mixed partition sort 2DUP - QMIXER @ < IF SUBSORT ELSE 2DUP 2DUP +2/ SWAP 3SORT SWAP 1- SWAP 1+ TRACE 2DUP +2/ PARTITION 2SWAP SWAP 1+ SWAP 2SWAP 1- TRACE \ 2OVER 2OVER - + < IF 2SWAP THEN \ smallest first 2DUP > IF RECURSE ELSE 2DROP THEN 2DUP > IF RECURSE ELSE 2DROP THEN THEN ; : X3QUICK-SORT ( h l -- ) TRACE \ 2DUP - 2* SQRT QMIXER ! 2DUP - 3 < IF <3SORT ELSE QM3MIX THEN ; \ Case Name 12:53 16.06.89 28 CASE: CASE-NAME NO-NAME ODD/EVEN-NAME BUBBLE-NAME SHAKER-NAME SHAKERF-NAME SHAKERI-NAME SHUTTLE-NAME LINSERT-NAME AINSERT-NAME BINSERT-NAME SELECTION-NAME SSELECTION-NAME STACK-NAME SSTACK-NAME HEAP-NAME INS.SHELL-NAME SEL.SHELL-NAME SPLICE-NAME ISPLICE-NAME SSPLICE-NAME BATCHER-NAME MERGE-NAME NAT.MERGE-NAME 1QUICK-NAME RQUICK-NAME MQUICK-NAME M3QUICK-NAME X3QUICK-NAME ; : NAME #SORT @ DUP CASE-NAME 27 = IF #SUBSORT @ CASE-NAME THEN ; \ Case Sort 12:53 16.06.89 28 CASE: CASE-SORT NO-SORT ODD/EVEN-SORT BUBBLE-SORT SHAKER-SORT SHAKERF-SORT SHAKERI-SORT SHUTTLE-SORT LINSERT-SORT AINSERT-SORT BINSERT-SORT SELECTION-SORT SSELECTION-SORT STACK-SORT SSTACK-SORT HEAP-SORT INS.SHELL-SORT SEL.SHELL-SORT SPLICE-SORT ISPLICE-SORT SSPLICE-SORT BATCHER-SORT MERGE-SORT NAT.MERGE-SORT 1QUICK-SORT RQUICK-SORT MQUICK-SORT M3QUICK-SORT X3QUICK-SORT ; : SORT ( high low -- ) 2DUP > IF #SORT @ CASE-SORT ELSE 2DROP THEN ; R: SUBSORT ( high low -- ) 2DUP > IF #SUBSORT @ CASE-SORT ELSE 2DROP THEN ; \ Control of execution 08:40 15.06.89 VARIABLE RUN-MODE : STEP RUN-MODE @ 32 = IF KEY RUN-MODE ! THEN ; : JUMP ?TERMINAL #DEMO @ ABS 1 <> AND IF KEY RUN-MODE ! THEN RUN-MODE @ 13 = IF KEY RUN-MODE ! ELSE STEP THEN ; \ Counting operations 00:22 13.06.89 VARIABLE #COMP \ number of compare VARIABLE #EXCH \ number of exchange VARIABLE #MOVE \ number of shift VARIABLE #LOOP \ number of track : COUNTS-READY 0 #COMP ! 0 #EXCH ! 0 #MOVE ! 0 #LOOP ! ; : #C+ #COMP +! ; : #X+ #EXCH +! ; : #M+ #MOVE +! ; : #L+ #LOOP +! ; : CCOUNT ( n1 n2 -- n1 n2 ) 1 #C+ ; : XCOUNT ( n1 n2 -- n1 n2 ) 1 #X+ ; : MCOUNT ( n1 n2 -- n1 n2 ) 2DUP - ABS #X+ 1 #M+ ; : LCOUNT ( n1 n2 -- n1 n2 ) 1 #L+ ; \ Counting operations 10:22 14.06.89 : COUNTS-STATUS CR CR ." Performance:" #COMP @ CR ." Number of comparisons: " 8 .R #EXCH @ CR ." Number of interchanges: " 8 .R #MOVE @ DUP 0= IF DROP ELSE CR ." Number of moves: " 8 .R THEN CR ; \ Character data for sorting 00:21 13.06.89 CREATE CHAR-DATA 0 C, 256 ALLOT CREATE CHAR-COPY 0 C, 256 ALLOT : CHAR-COMPARE ( adr1 adr2 -- f ) C@ SWAP C@ > ; : CHAR-EXCHANGE ( adr1 adr2 --- ) 2DUP C@ SWAP C@ ROT C! SWAP C! ; : CHAR-MOVE-L ( high low --- ) OVER C@ OVER 2SWAP DUP DUP 1+ 2SWAP - CMOVE> C! ; : CHAR-MOVE-R ( low high --- ) SWAP 2DUP C@ SWAP 2SWAP DUP 1+ OVER 2SWAP - CMOVE C! ; : CHAR-MOVE ( n1 n2 -- ) 2DUP < IF CHAR-MOVE-R ELSE CHAR-MOVE-L THEN ; \ Character data for sorting 17:05 18.06.89 : CHAR-CTRACE CR 2DUP MIN CHAR-DATA - 1- SPACES ." C" 2DUP <> IF 2DUP - ABS 1- SPACES ." C" THEN ; : CHAR-XTRACE CR 2DUP MIN CHAR-DATA - 1- SPACES ." X" 2DUP - ABS 1- SPACES ." X" ; : CHAR-MTRACE CR 2DUP MIN CHAR-DATA - 1- SPACES 2DUP 2DUP MAX 1+ -ROT MIN ?DO ." S" LOOP ; : CHAR-LTRACE CR CHAR-DATA COUNT TYPE ; \ Character data for sorting 13:46 12.06.89 : CHAR-NEW BEGIN CR ." Type a string, end with " CR CHAR-COPY 1+ 80 EXPECT SPAN @ DUP CHAR-COPY C! 2 < WHILE CR ." Must be two characters or more" REPEAT ; : CHAR-RANGE ( -- high low ) CHAR-DATA DUP C@ OVER + SWAP 1+ ; \ Character data for sorting 12:37 16.06.89 : CHAR-READY ( -- h l ) COUNTS-READY 32 RUN-MODE ! CHAR-COPY C@ 0= IF CHAR-NEW ELSE CR ." Last string was:" CR CHAR-COPY COUNT TYPE CR ." Input new string ? " ?Y/N IF CHAR-NEW THEN THEN CHAR-COPY CHAR-DATA OVER C@ 1+ CMOVE CHAR-RANGE ; : CHAR-FINISH CR CR ." End of sorting" CR CR ." Algorithm: " NAME CR CR ." Data before sorting:" CR CHAR-COPY COUNT TYPE CR CR ." Data after sorting:" CR CHAR-DATA COUNT TYPE COUNTS-STATUS CR ." Press a key ... " KEY-BELL KEY DROP ; \ Word data for sorting 09:36 15.06.89 16> 256 CONSTANT W-MAX \ >256 will cause overflow 32> 2000 CONSTANT W-MAX \ patience limit, don't Bubblesort 2000 CREATE WORD-DATA 0 W, W-MAX 2* ALLOT \ data before sorting CREATE WORD-PNTS 0 W, W-MAX 2* ALLOT \ data pointers to sort : #PNTS ( -- n ) WORD-PNTS W@ ; \ number of data pointers : #DATA ( -- n ) WORD-DATA W@ ; \ number of diff. data values : >#WORD ( n -- addr ) 1+ 2* WORD-DATA + ; \ item number n : >#PNTR ( n -- addr ) 1+ 2* WORD-PNTS + ; \ pointer number n : P>#WORD ( n -- addr ) >#PNTR W@ >#WORD ; \ item of pointer n : PNTS-NEW \ initialize pointers #PNTS 0 ?DO I DUP >#PNTR W! LOOP ; : WORD-RANGE ( -- h l ) #PNTS 1- 0 ; \ Word data distribution 17:25 16.06.89 : ORDERED-WORDS ( -- ) \ initialize words in order #PNTS 0 ?DO I I >#WORD W! LOOP ; : REVERSE-WORDS ( -- ) \ initialize words in reverse order #PNTS 0 ?DO I #PNTS 1- I - >#WORD W! LOOP ; : WDATA-EXCHANGE ( n1 n2 --- ) \ exchange data, not pointers SWAP >#WORD SWAP >#WORD 2DUP W@ SWAP W@ ROT W! SWAP W! ; : WDATA-MOVE-L ( high low --- ) \ move data, not pointers SWAP >#WORD SWAP >#WORD OVER W@ OVER 2SWAP DUP DUP 2+ 2SWAP - CMOVE> W! ; \ Word data distribution 17:25 16.06.89 VARIABLE #INVERSIONS VARIABLE %INVERSIONS : COUNT-INVERSIONS \ count inversions in data distribution 0 #PNTS 1 DO I 0 DO I >#WORD W@ J >#WORD W@ > IF 1+ THEN LOOP LOOP #INVERSIONS ! ; : MOVE-LENGTH ( -- length ) \ random insertion length #PNTS 100 %INVERSIONS @ 2DUP - MIN 2* - 1+ 100 * SQRT OVER 100 */ - ; : DISTURB-WORDS \ partially randomize data by random insertion MOVE-LENGTH DUP 0> IF #PNTS 1 ?DO I 2DUP MIN 1+ SHRANDOM - 0 MAX I SWAP WDATA-MOVE-L LOOP THEN DROP ; : RANDOM-WORDS \ completely randomize data by random selection #PNTS 1- 0 ?DO #PNTS I - SHRANDOM I + I WDATA-EXCHANGE LOOP ; \ Word data distribution 17:26 16.06.89 VARIABLE MULTIPLICITY 1 MULTIPLICITY ! \ key multiplicity : MINOR-KEY ( key -- minor ) MULTIPLICITY @ DUP 1 > IF MOD ELSE DROP THEN ; : MAJOR-KEY ( key -- major ) MULTIPLICITY @ DUP 1 > IF / ELSE DROP THEN ; \ compare minor keys for equal major keys : MAJORMIN-COMPARE ( n1 n2 -- f ) >#WORD W@ SWAP >#WORD W@ 2DUP MAJOR-KEY SWAP MAJOR-KEY = IF MINOR-KEY SWAP MINOR-KEY < ELSE 2DROP FALSE THEN ; \ Word data distribution 17:26 16.06.89 : MMPOINT-OUT ( n i -- x ) DUP ROT 1- DO I 1+ OVER MAJORMIN-COMPARE IF DROP I 1+ THEN -1 +LOOP ; : MMSELECT ( n i -- n ) 2DUP MMPOINT-OUT WDATA-EXCHANGE ; : MAJORMIN-SORT ( h l -- ) OVER SWAP ?DO I MMSELECT LOOP DROP ; \ Word data for sorting 14:44 12.06.89 : WORD-COMPARE ( n1 n2 -- f ) SWAP P>#WORD SWAP P>#WORD W@ MAJOR-KEY SWAP W@ MAJOR-KEY > ; : WORD-EXCHANGE ( n1 n2 --- ) SWAP >#PNTR SWAP >#PNTR 2DUP W@ SWAP W@ ROT W! SWAP W! ; : WORD-MOVE-L ( high low --- ) SWAP >#PNTR SWAP >#PNTR OVER W@ OVER 2SWAP DUP DUP 2+ 2SWAP - CMOVE> W! ; : WORD-MOVE-R ( low high --- ) >#PNTR SWAP >#PNTR 2DUP W@ SWAP 2SWAP DUP 2+ OVER 2SWAP - CMOVE W! ; : WORD-MOVE ( n1 n2 -- ) 2DUP < IF WORD-MOVE-R ELSE WORD-MOVE-L THEN ; \ Word data for sorting 12:47 16.06.89 : WORD-NEW ( -- ) CR ." Number of data ( 8-" W-MAX . ." ) ? " #IN DUP 8 < IF DROP 32 THEN W-MAX MIN DUP WORD-PNTS W! 1- CR ." Multiplicity of data, default 1 ? " #IN 1 MAX DUP MULTIPLICITY ! / 1+ WORD-DATA W! CR ." % Inversions (0-100, random: 50) ? " #IN 0 MAX 100 MIN %INVERSIONS ! CR ." Calculating data distribution, " ." Wait ..." %INVERSIONS @ 50 < IF ORDERED-WORDS ELSE REVERSE-WORDS THEN %INVERSIONS @ 50 = IF RANDOM-WORDS ELSE DISTURB-WORDS THEN MULTIPLICITY @ 1 > IF WORD-RANGE MAJORMIN-SORT THEN COUNT-INVERSIONS PNTS-NEW CR ; \ Word data for sorting 13:31 16.06.89 : WORD-STATUS CR CR ." Number of elements: " #PNTS 8 .R CR ." Number of diff. keys: " #DATA 8 .R CR ." Number of inversions: " #INVERSIONS @ DUP 8 .R 1000 #PNTS 2 MAX DUP 1- 2 */ */ 10 /MOD ." (" 2 .R ." ." . ." %)" CR ; : WORD-FINISH CR CR ." Algorithm: " NAME WORD-STATUS COUNTS-STATUS CR ; \ Word data for sorting 13:05 16.06.89 : WORD-READY ( -- h l ) COUNTS-READY 27 RUN-MODE ! PNTS-NEW WORD-RANGE ; : STAT-READY WORD-READY CR ." Begin ... " 0 TIME -ROT ; : STAT-FINISH TIME-OUT ." End " CR WORD-FINISH CR ." Execution time " 10 / 10 /MOD 2 .R 46 EMIT . ." sec" CR CR ." Press a key ... " KEY-BELL KEY DROP ; \ Palette 15:49 14.06.89 VARIABLE SCALESIZE CREATE PALTAB ?COLORS ALLOT : !PALTAB ( color n --- ) PALTAB + C! ; \ store n'th color BINARY : 15MONO 1111 SCALESIZE ! \ Grey scale for mono screen 111111 110111 011111 110110 011110 110011 011011 110010 011010 110101 011101 110100 011100 110001 011001 000000 10000 0 DO I !PALTAB LOOP PALTAB !PALETTE ; : 10COLORS 1010 SCALESIZE ! \ Rainbow scale 111111 111111 111111 111111 111111 001001 011001 001011 011011 010011 010010 110110 100110 110100 100100 000000 10000 0 DO I !PALTAB LOOP PALTAB !PALETTE ; DECIMAL \ Palette 15:49 14.06.89 BINARY : WHITE 0001 SCALESIZE ! \ White on black 111111 111111 111111 111111 111111 111111 111111 111111 111111 111111 111111 111111 111111 111111 111111 000000 10000 0 DO I !PALTAB LOOP PALTAB !PALETTE ; : BLACK 0001 SCALESIZE ! \ Black on white 000000 000000 000000 000000 000000 000000 000000 000000 000000 000000 000000 000000 000000 000000 000000 111111 10000 0 DO I !PALTAB LOOP PALTAB !PALETTE ; DECIMAL \ Palette 13:13 16.06.89 4 CASE: CASE-PAL 10COLORS WHITE BLACK 15MONO ; : PAL ( --- ) #PAL @ CASE-PAL ; : >#COLOR ( n -- c ) #DEMO @ 2 = MULTIPLICITY @ 1 > AND IF MINOR-KEY SCALESIZE @ MULTIPLICITY @ */ 1+ ELSE MAJOR-KEY MULTIPLICITY @ * SCALESIZE @ #PNTS 1 MAX */ 1+ THEN ; \ Column demo 12:56 16.06.89 VARIABLE X0 VARIABLE Y0 VARIABLE DX VARIABLE DY : POSITION-COLUMNS ?YMAX 1+ DUP 16 / 2DUP - Y0 ! 2* - #DATA 1 MAX / NEGATE DY ! ?XMAX 1+ #PNTS 1 MAX 2DUP 2+ / DUP DX ! * - 2/ X0 ! DX @ 0= DY 0= OR IF CR ." Too many data to show " 0 #SORT ! THEN ; : !COLUMN ( n -- ) DX @ 0= DY @ 0= OR IF DROP ELSE 0 FOREGROUND DUP DX @ * X0 @ + DUP DX @ 2/ 1+ + SWAP DO I 0 I Y0 @ LINE LOOP DUP P>#WORD W@ DUP >#COLOR FOREGROUND MAJOR-KEY 1+ DY @ * Y0 @ + Y0 @ ROT DX @ * X0 @ + DUP DX @ 2/ 1+ + SWAP DO 2DUP I -ROT I SWAP LINE LOOP 2DROP 15 FOREGROUND THEN ; \ Column demo 13:01 16.06.89 : .COLUMN ( n -- ) DX @ * X0 @ + Y0 @ ?YMAX OVER - 2/ + !PEL ; : +COLUMN ( n -- ) 15 FOREGROUND .COLUMN ; : -COLUMNS 0 FOREGROUND #PNTS 0 ?DO I .COLUMN LOOP ; : !COLUMNS #PNTS 0 ?DO I !COLUMN LOOP ; \ Column demo 12:37 16.06.89 : COLUMN-READY GMODE PAL POSITION-COLUMNS WORD-READY 32 RUN-MODE ! !COLUMNS ; : COLUMN-FINISH KEY-BELL KEY DROP AMODE WORD-FINISH CR ." Press a key ... " KEY-BELL KEY DROP ; \ Column demo 17:05 18.06.89 : COLUMN-CTRACE 2DUP +COLUMN +COLUMN ; : COLUMN-XTRACE 2DUP !COLUMN !COLUMN ; : COLUMN-MTRACE OVER 1+ OVER DO I !COLUMN LOOP ; : COLUMN-LTRACE -COLUMNS ; \ Dot demo 12:59 16.06.89 : POSITION-DOTS ?YMAX 1+ DUP 16 / DUP Y0 ! - 1- #LOOP @ 4+ / DY ! ?XMAX 1+ #PNTS 2DUP 2+ / DY @ MIN DUP DX ! DUP DY ! * - 2/ X0 ! DX @ 0= IF CR ." Too many data to show " 0 #SORT ! THEN ; : !DOT ( n -- ) DX @ 0= IF DROP ELSE DUP P>#WORD W@ >#COLOR FOREGROUND DX @ * X0 @ + DUP DX @ 1- 1 MAX + SWAP ?DO I #LOOP @ DY @ * Y0 @ + I OVER DY @ 2- 0 MAX + LINE LOOP 15 FOREGROUND THEN ; : !DOTS #PNTS 0 ?DO I !DOT LOOP ; \ Dot demo 12:59 16.06.89 : .DOT ( n -- ) DX @ * X0 @ + Y0 @ 2/ !PEL ; : +DOT ( n -- ) 15 FOREGROUND .DOT ; : -DOTS 0 FOREGROUND #PNTS 0 ?DO I .DOT LOOP ; : DOT-READY CR ." Calculating graphics parameters, " ." Wait ... " #DEMO @ 1 #DEMO ! WORD-READY SORT #DEMO ! GMODE PAL POSITION-DOTS WORD-READY 32 RUN-MODE ! !DOTS 2 #L+ ; : DOT-FINISH 1 #L+ !DOTS KEY-BELL KEY DROP AMODE WORD-FINISH CR ." Press a key " KEY-BELL KEY DROP ; \ Dot demo 17:05 18.06.89 : DOT-CTRACE1 2DUP +DOT +DOT 2DUP !DOT !DOT ; : DOT-XTRACE1 2DUP !DOT !DOT ; : DOT-MTRACE1 OVER 1+ OVER DO I !DOT LOOP ; : DOT-LTRACE1 -DOTS ; \ Dot demo 17:05 18.06.89 : DOT-CTRACE2 2DUP +DOT +DOT ; : DOT-XTRACE2 2DUP !DOT !DOT ; : DOT-MTRACE2 OVER 1+ OVER DO I !DOT LOOP ; : DOT-LTRACE2 !DOTS -DOTS ; \ Case loop 17:05 18.06.89 5 CASE: CASE-LTRACE CHAR-LTRACE DUMMY COLUMN-LTRACE DOT-LTRACE1 DOT-LTRACE2 ; \ Case compare 17:05 18.06.89 5 CASE: CASE-COMPARE CHAR-COMPARE WORD-COMPARE WORD-COMPARE WORD-COMPARE WORD-COMPARE ; 5 CASE: CASE-CTRACE CHAR-CTRACE DUMMY COLUMN-CTRACE DOT-CTRACE1 DOT-CTRACE2 ; \ Case exchange 17:05 18.06.89 5 CASE: CASE-EXCHANGE CHAR-EXCHANGE WORD-EXCHANGE WORD-EXCHANGE WORD-EXCHANGE WORD-EXCHANGE ; 5 CASE: CASE-XTRACE CHAR-XTRACE DUMMY COLUMN-XTRACE DOT-XTRACE1 DOT-XTRACE2 ; \ Case move 17:05 18.06.89 5 CASE: CASE-MOVE CHAR-MOVE WORD-MOVE WORD-MOVE WORD-MOVE WORD-MOVE ; 6 CASE: CASE-MTRACE CHAR-MTRACE DUMMY COLUMN-MTRACE DOT-MTRACE1 DOT-MTRACE2 ; \ Sorting interface operations 17:05 18.06.89 R: COMPARE ( n1 n2 -- f ) 2DUP #DEMO @ CASE-COMPARE -ROT #DEMO @ CASE-CTRACE CCOUNT 2DROP STEP ; R: EXCHANGE ( n1 n2 --- ) 2DUP #DEMO @ CASE-EXCHANGE #DEMO @ CASE-XTRACE XCOUNT 2DROP STEP ; R: MOVE ( n1 n2 --- ) 2DUP #DEMO @ CASE-MOVE #DEMO @ CASE-MTRACE MCOUNT 2DROP STEP ; R: TRACE ( --- ) #DEMO @ CASE-LTRACE LCOUNT JUMP ; \ Menu windows layout 16:11 18.06.89 5 5 35 19 WINDOW W-SORT 25 5 65 18 WINDOW W-SUBSORT 15 10 55 14 WINDOW W-SORT+ 25 8 60 17 WINDOW W-SSEQ 20 13 65 16 WINDOW W-QUERY 20 10 60 14 WINDOW W-DEMO 25 5 55 11 WINDOW W-MAIN \ Data distribution selection 17:24 16.06.89 : WHICH-DATA CLS W-QUERY W-OUT " Data Distribution ?" WHEADER CLS WORD-NEW STD-OUT ; \ Palette selection 17:24 16.06.89 4 MENU: M-PALETTE " Rainbow scale, 10 colors" " White on black" " Black on white" " Grey scale for mono, 15 shades" ; : WHICH-PALETTE CLS W-QUERY W-OUT " Color Palette ?" WHEADER CLS #PAL @ MENU M-PALETTE #PAL ! ; \ Case ready and finish 05:28 15.06.89 5 CASE: CASE-READY CHAR-READY STAT-READY COLUMN-READY DOT-READY DOT-READY ; 5 CASE: CASE-FINISH CHAR-FINISH STAT-FINISH COLUMN-FINISH DOT-FINISH DOT-FINISH ; \ RUN 09:57 14.06.89 : READY #DEMO @ CASE-READY ; : FINISH #DEMO @ CASE-FINISH ; : RUN READY SORT FINISH ; \ Algorithm number constants 17:24 16.06.89 0 CONSTANT #NONE \ do not sort 1 CONSTANT #ODD/EVEN \ Odd/Even Transport 2 CONSTANT #BUBBLE \ Bubblesort 3 CONSTANT #SHAKER \ Shakersort 4 CONSTANT #SHAKERF \ Shakersort with a flag 5 CONSTANT #SHAKERI \ Shakersort with interval reduction 6 CONSTANT #SHUTTLE \ Shuttlesort - Sifting 7 CONSTANT #INSERT \ Straight Insertionsort 8 CONSTANT #INSERTA \ Insertionsort, assymmetric search 9 CONSTANT #INSERTB \ Insertionsort with bisection search \ Algorithm number constants 17:23 16.06.89 10 CONSTANT #SELECT \ Selectionsort 11 CONSTANT #SSELECT \ Selectionsort, stable 12 CONSTANT #STACK \ Stacksort (Selectionsort w. stack) 13 CONSTANT #SSTACK \ Stacksort, stable 14 CONSTANT #HEAP \ Heapsort - Treesort 15 CONSTANT #SHELLI \ Shellsort, dim. incr. insertion 16 CONSTANT #SHELLS \ Shellsort with stack-seletion 17 CONSTANT #SPLICE \ Splicesort 18 CONSTANT #SPLICEI \ Splicesort with insertion 19 CONSTANT #SPLICES \ Splicesort with selection \ Algorithm number constants 17:23 16.06.89 20 CONSTANT #BATCHER \ Batchersort 21 CONSTANT #MERGE \ Mergesort, binary subdivision 22 CONSTANT #MERGEN \ Mergesort, natural 23 CONSTANT #QUICK1 \ Quicksort, first pivot element 24 CONSTANT #QUICKR \ Quicksort, random pivot element 25 CONSTANT #QUICKM \ Quicksort, middle pivot element 26 CONSTANT #QUICK3 \ Quicksort, median-of-three pivot 27 CONSTANT #QUICKP \ Quicksort-partition + other sort \ Algorithm sub-selection 17:23 16.06.89 F: WHICH-SUBSORT ( --- n ) 3 MENU: M-SHAKER " Straight Shakersort" " Shakersort with flag" " - with interval reduction" ; 3 CASE: C-SHAKER #SHAKER #SHAKERF #SHAKERI ; \ Algorithm sub-selection 15:46 18.06.89 2 MENU: M-INSERTB " Assymmetric binary search" " Bisection binary search" ; 2 CASE: C-INSERTB #INSERTA #INSERTB ; \ Algorithm sub-selection 17:23 16.06.89 2 MENU: M-SELECT " Standard Selectionsort (with move)" " Stable Selectionsort (with exchange)" ; 2 MENU: M-STACK " Standard Stacksort (with exchange)" " Stable Stacksort (with move)" ; 2 CASE: C-SELECT #SELECT #SSELECT ; 2 CASE: C-STACK #STACK #SSTACK ; \ Algorithm sub-selection 17:23 16.06.89 2 MENU: M-SHELL " Shellsort with insertion" " with stack-selection" ; 2 CASE: C-SHELL #SHELLI #SHELLS ; \ Algorithm sub-selection 17:23 16.06.89 3 MENU: M-SPLICE " Straight Splicesort" " with insertion" " with selection" ; 3 CASE: C-SPLICE #SPLICE #SPLICEI #SPLICES ; \ Algorithm sub-selection 17:23 16.06.89 2 MENU: M-MERGE " Straight Mergesort" " Natural Mergesort" ; 2 CASE: C-MERGE #MERGE #MERGEN ; \ Algorithm sub-selection 17:22 16.06.89 5 MENU: M-QUICK " First element partition" " Random element partition" " Middle element partition" " Median-of-three partition" " Partition + other method" ; 5 CASE: C-QUICK #QUICK1 #QUICKR #QUICKM #QUICK3 WHICH-SUBSORT ; \ Shellsort increment sequence selection menu 17:22 16.06.89 10 MENU: M-SSEQ " Fibonacci: N(i) = N(i-1)+N(i-2)" " Every 2. Fibonacci" " Every 3. Fibonacci" " N(i) = N(i-1)*N(i-2)" " N(i) = 2*N(i-1)+1" " N(i) = 3*N(i-1)+1" " N(i) = 4*N(i-1)+1" " N(i) = 3*N(i-1)-1" " N(i) = 4*N(i-1)-1" " N(i) = 4*N(i-1)" ; \ Algorithm sub-selection 17:21 16.06.89 : WHICH-SSEQ W-SSEQ W-OUT " Which increment sequence ?" WHEADER CLS #SHELLSEQ @ MENU M-SSEQ #SHELLSEQ ! ; : WHICH-SELECT ( --- n ) W-SORT+ W-OUT " Which Selectionsort ?" WHEADER CLS 0 MENU M-SELECT C-SELECT ; : WHICH-STACK ( --- n ) W-SORT+ W-OUT " Which Stacksort ?" WHEADER CLS 0 MENU M-STACK C-STACK ; \ Algorithm sub-selection 15:46 18.06.89 : WHICH-SHAKER ( --- n ) W-SORT+ W-OUT " Which Shakersort ?" WHEADER CLS 0 MENU M-SHAKER C-SHAKER ; : WHICH-INSERTB ( --- n ) W-SORT+ W-OUT " Which Binary Insertionsort ?" WHEADER CLS 0 MENU M-INSERTB C-INSERTB ; : WHICH-SHELL ( --- n ) W-SORT+ W-OUT " Which Shellsort ?" WHEADER CLS 0 MENU M-SHELL C-SHELL WHICH-SSEQ ; \ Algorithm sub-selection 17:21 16.06.89 : WHICH-SPLICE ( --- n ) W-SORT+ W-OUT " Which Splicesort ?" WHEADER CLS 0 MENU M-SPLICE C-SPLICE ; : WHICH-MERGE ( --- n ) W-SORT+ W-OUT " Which Mergesort ?" WHEADER CLS 0 MENU M-MERGE C-MERGE ; : WHICH-QUICK ( --- n ) W-SORT+ W-OUT " Which Quicksort ?" WHEADER CLS 0 MENU M-QUICK C-QUICK ; \ Sort algorithm selection menu 15:43 18.06.89 15 MENU: M-SORT " None" " Odd/Even Transport" " Bubblesort" " Shakersort" " Shuttlesort - Sifting" " Straight Insertionsort" " Binary Insertionsort" " Selectionsort" " Stacksort (new)" " Heapsort / Treesort" " Shellsort" " Splicesort (new)" " Batchersort" " Mergesort" " Quicksort" ; \ Sort algorithm selection menu 15:43 18.06.89 15 CASE: C-SORT #NONE #ODD/EVEN #BUBBLE WHICH-SHAKER #SHUTTLE #INSERT WHICH-INSERTB WHICH-SELECT WHICH-STACK #HEAP WHICH-SHELL WHICH-SPLICE #BATCHER WHICH-MERGE WHICH-QUICK ; \ Menu for Partitionsort 15:45 18.06.89 14 MENU: M-SUBSORT " none (unsorted partitions)" " Odd/Even Transport" " Bubblesort" " Shakersort" " Shuttlesort - Sifting" " Straight Insertionsort" " Binary Insertionsort" " Selectionsort" " Stacksort (new)" " Heapsort / Treesort" " Shellsort" " Splicesort (new)" " Batchersort" " Mergesort" ; \ Cases for Partitionsort 15:45 18.06.89 14 CASE: C-SUBSORT #NONE #ODD/EVEN #BUBBLE #SHAKERI #SHUTTLE #INSERT #INSERTB #SELECT #STACK #HEAP #SHELLI #SPLICE #BATCHER #MERGE ; \ Which sorting algorithm 17:18 16.06.89 VARIABLE #M-SORT VARIABLE #M-SUBSORT : WHICH-SORT \ store algorithm number in #SORT CLS W-SORT W-OUT " Which Sorting Algorithm ?" WHEADER CLS #M-SORT @ MENU M-SORT DUP #M-SORT ! C-SORT #SORT ! ; R: WHICH-SUBSORT ( --- n ) W-QUERY W-OUT " Input number" WHEADER CLS CLS ." Min. partition interval, default 10 ? " #IN DUP 0> NOT IF DROP 10 THEN QMIXER ! W-SUBSORT W-OUT " Second Algorithm ?" WHEADER CLS #M-SUBSORT @ MENU M-SUBSORT DUP #M-SUBSORT ! C-SUBSORT #SUBSORT ! #QUICKP ; \ Which Demo 16:57 16.06.89 5 MENU: M-DEMO " Sort ascii text example" " Count number of operations" " Sort colored bars on screen" " Color image of traced operations" " Color image of traced data distribution" ; : WHICH-DEMO \ store demo number in #SORT CLS W-DEMO W-OUT " Which Demo ?" WHEADER CLS #DEMO @ MENU M-DEMO #DEMO ! ; \ Main menu 17:17 16.06.89 7 MENU: M-MAIN " RUN sorting demo" " Select type of demo" " Select sorting algorithm" " Define data to be sorted" " Select palette colors" " Sound on/off" " EXIT from program" ; \ Main cases 17:19 16.06.89 6 CASE: C-MAIN RUN WHICH-DEMO WHICH-SORT WHICH-DATA WHICH-PALETTE SOUND-ON/OFF ; \ Information on use of keyboard 16:22 16.06.89 : INFO CLS CR CR ." SORT-OUT program information" CR CR CR ." The execution of a sorting demo can be controlled" CR ." from the keyboard with these keys:" CR CR ." - single step to next operation." CR ." - jump to next main loop of algorithm." CR CR ." Other keys will make the program continue until" CR ." or is pressed or the sort is over." CR CR ." After running a demo, press one or two keys to" CR ." return to the main menu." CR CR ." Press a key to continue ... " KEY-BELL KEY DROP CR ; \ Goodbye message 20:12 18.06.89 : RED&WHITE CR 12 FOREGROUND REVERSE 4 SPACES REVERSE 2 SPACES REVERSE 7 SPACES REVERSE 2 SPACES 7 FOREGROUND ; : DK-FLAG RED&WHITE RED&WHITE CR RED&WHITE RED&WHITE CR ; : HEJ CLS CR CR DK-FLAG CR CR CR ." SORT-OUT is written by Henning Hansen" CR ." at the Technical University of Denmark. " CR ." The source code is placed in the public domain. " CR CR CR CR ; \ MAIN program loop 16:01 18.06.89 : MAIN \ run MAIN menu loop until escape from program INFO CLS BEGIN W-MAIN W-OUT " Main Menu" WHEADER CLS 0 MENU M-MAIN STD-OUT CLS DUP 0< OVER 5 > OR NOT WHILE C-MAIN STD-OUT CLS REPEAT DROP STD-OUT HEJ ; \ 17:15 16.06.89 \ 17:15 16.06.89