mgr's weblog

Forth insertion sort

January 26, 2016, Lisp

Long time, no post. To get back into forth after many years (see GPN7: FORTH und TILs) and to practice writing factored code, I tried to write a more idiomatic forth version of insertion sort. That is, factored out into many, really short words (i.e., functions).

To make sure of it, I used the retro line-based block editor of GForth. (Retro as in: Notice that i had to start line 7 with a blank because I really exhausted line 6. smug-smile)

Here you go:

Screen 5 not modified     
 0 forth   \ load forth vocabulary                                 
 1 create nums 4 , 5 , 2 , 1 , 3 , 7 , 0 , 6 , 8 ,                 
 2 here nums - cell / constant #num                                
 3                                                                 
 4 : @num ( n - vN) cell  nums + @ ;                              
 5 : !num ( v n -) cell  nums + ! ;                               
 6 : numswap ( n -) dup @num over 1- dup @num -rot !num swap !num ;
 7  : show #num 0 do i cell  nums + @ . loop ;                    
 8                                                                 
 9 : @2num ( n - n-1 n0) dup 1- @num swap @num ;                   
10 : fix ( n -) dup @2num > if dup numswap then drop ;             
11 : recfix ( n -) dup 0 do dup i - dup @2num <= if leave then     
12    fix loop drop ;                                              
13 : sort ( -) #num 1 do i @2num > if i recfix then loop ;         
14                                                                 
15 editor   \ switch back to editor vocabulary                     

GForth session:

$ gforth
Gforth 0.7.2, Copyright (C) 1995-2008 Free Software Foundation, Inc.
Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'
Type `bye' to exit
use blocked.fb  ok
1 load redefined insert   ok
5 l
Screen 5 not modified     
 0 forth   \ load forth vocabulary                                 
 1 create nums 4 , 5 , 2 , 1 , 3 , 7 , 0 , 6 , 8 ,                 
 2 here nums - cell / constant #num                                
 3                                                                 
 4 : @num ( n - vN) cell  nums + @ ;                              
 5 : !num ( v n -) cell  nums + ! ;                               
 6 : numswap ( n -) dup @num over 1- dup @num -rot !num swap !num ;
 7  : show #num 0 do i cell  nums + @ . loop ;                    
 8                                                                 
 9 : @2num ( n - n-1 n0) dup 1- @num swap @num ;                   
10 : fix ( n -) dup @2num > if dup numswap then drop ;             
11 : recfix ( n -) dup 0 do dup i - dup @2num <= if leave then     
12    fix loop drop ;                                              
13 : sort ( -) #num 1 do i @2num > if i recfix then loop ;         
14                                                                 
15 editor   \ switch back to editor vocabulary                     
 ok
5 load  ok
show 4 5 2 1 3 7 0 6 8  ok
sort  ok
show 0 1 2 3 4 5 6 7 8  ok

Here is a version that spits out a bit of debug messages so that you can see what the algorithm does while sorting (! means two elements have to be swapped, + means that the current interation can be stopped early):

Screen 5 not modified     
 0 forth                                                           
 1 create nums 4 , 5 , 2 , 1 , 3 , 7 , 0 , 6 , 8 ,                 
 2 9 constant #num                                                 
 3 : @num ( n - vN) cell  nums + @ ;                              
 4 : !num ( v n -) cell  nums + ! ;                               
 5 : numswap ( n -) dup @num over 1- dup @num -rot !num swap !num ;
 6  : show #num 0 do i cell * nums + @ . loop ;                    
 7 : @2num ( n - n-1 n0) dup 1- @num swap @num ;                   
 8 : debug ( n-) dup . ." - " dup 1- @num .  @num . ;              
 9 : test #num 1 do i debug  i @2num > if ." !" then  ." _" loop ; 
10 : fix dup @2num > if ." ! " dup numswap then drop ;             
11 : recfix ( n -) dup 0 do dup i - dup debug dup @2num <=         
12   if ." + " leave then fix loop drop ;                          
13 : wrecfix ." [" recfix ." ]" ;                                  
14  : sort #num 1 do i debug i @2num > if i wrecfix then  ." _ "   
15    loop ;  editor                                               
 ok
5 load  ok
show 4 5 2 1 3 7 0 6 8  ok
sort 1 - 4 5 _ 2 - 5 2 [2 - 5 2 ! 1 - 4 2 ! ]_ 3 - 5 1 [3 - 5 1 ! 2 - 4 1 ! 1 -
  2 1 ! ]_ 4 - 5 3 [4 - 5 3 ! 3 - 4 3 ! 2 - 2 3 + ]_ 5 - 5 7 _ 6 - 7 0 [6 - 7 0 !
  5 - 5 0 ! 4 - 4 0 ! 3 - 3 0 ! 2 - 2 0 ! 1 - 1 0 ! ]_ 7 - 7 6 [7 - 7 6 ! 
  6 - 5 6 + ]_ 8 - 7 8 _  ok
show 0 1 2 3 4 5 6 7 8  ok

Have fun.

Trackback pings for this entry are listed below. The URL to ping for this entry is: http://blog.matroid.org/trackback/70

Select a Theme:

Basilique du Sacré-Cœur de Montmartre (Paris) Parc Floral de Paris Castillo de Santa Barbara (Alicante) About the photos

Entries: