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.
