sort-benchmarks.fs

500000 constant //dataset

//dataset value /dataset
: /dataset-1
  /dataset 1 cells - ;

create unsorted  ( rely on random contents from ASLR )
  16 , 15 , 14 , 13 , 12 , 11 , 10 , 9 , 8 , 7 , 6 , 5 , 4 , 3 , 2 , 1 ,
  //dataset allot

create sorted
  //dataset allot

: restore	unsorted sorted //dataset move ;


\ =========== INSERTION SORT ============
\ This insertion sort code has several flaws:
\
\ 1.  It spends a fair amount of time adding base addresses to compute pointers from offsets.
\ 2.  It references two buffers of memory instead of just one.
\ 3.  It does not use MOVE to copy memory, but moves it manually, word for word, in a loop.
\
\ In other words, this can potentially be made a whole lot faster.

: cell-
  [ -1 cells ] literal + ;

: vacate
  sorted +  /dataset-1 sorted +  begin
    2dup u>= if 2drop exit then
    dup dup cell- @ swap !
    cell-
  again ;

: insert
  0 begin
    dup /dataset u>= if 2drop exit then
    2dup sorted + @ u< if
      dup vacate sorted + ! exit
    then
    cell+
  again ;

: insertionSort
  sorted /dataset -1 fill
  0 begin
    dup /dataset u>= if drop exit then
    dup unsorted + @ insert
    cell+
  again ;

\ ========== QSORT ==========
\ Taken from http://home.hccnet.nl/a.w.m.van.der.horst/forthlecture8.html
\ and simplified to remove extraneous indirection.

: exchange
  dup @ >r over @ swap ! r> swap ! ;

: partition
  2dup over - 2/ [ -1 cells ] literal and + @ >r
  2dup begin
    swap begin dup @ r@ < while cell+ repeat
    swap begin r@ over @ < while cell- repeat
    2dup > 0= if 2dup exchange >r cell+ r> cell- then
  2dup > until
  r> drop
  swap rot ;

: qsort_
  partition 2over 2over - + < if
    2swap
  then
  2dup < if recurse else 2drop then
  2dup < if recurse else 2drop then ;

: qsort
  restore
  sorted /dataset
  dup 2 < if 2drop exit then
  1- cells over + qsort_ ;

\ ========== BUBBLE ==========
\ I think this is the shortest bubble sort logic I've ever written.

variable swapped
variable limit

: exchange	>r r@ @ r@ cell+ @ r@ ! r> cell+ !  1 swapped +! ;
: -order?	dup @ swap cell+ @ u>= ;
: blub		begin dup limit @ u< while dup -order? if dup exchange then cell+ repeat drop ;
: bub		begin swapped off  sorted blub  [ -1 cells ] literal limit +!  swapped @ 0= until ;
: bubbleSort	unsorted sorted //dataset move  sorted /dataset cells + -2 cells + limit !  bub ;

\ ========== BENCHMARKER =========

: seconds	( don't run this near midnight. ;)
  time&date 2drop 2drop 60 * + ;

variable iterations
: .iterations
  ." Iterations = " iterations ? cr
  ." Time elapsed = " seconds - negate . cr ;

: done
  .iterations drop ;

: bench
  ." /dataset = " /dataset . cr
  iterations off
  seconds begin
    key? if key drop done exit then
    dup seconds - abs 15 u>= if done exit then
    1 iterations +!
    over execute
  again ;

: benchmark
  5 to /dataset  dup bench
  50 to /dataset  dup bench
  500 to /dataset  dup bench
  5000 to /dataset  dup bench
  50000 to /dataset  dup bench
  500000 to /dataset  dup bench ;


.( Insertion Sort Results... ) cr cr
' insertionSort benchmark

.( QSort Results... ) cr cr
' qsort benchmark

.( Bubble Sort Results... ) cr cr
' bubbleSort benchmark