[Win32forth-cvs] win32forth/apps/Player4 mshell_r.f,NONE,1.1

[Jos v.d.V. <jo...@us...>]

Update of /cvsroot/win32forth/win32forth/apps/Player4
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12700/apps/Player4

Added Files:
	mshell_r.f 
Log Message:
Jos: 
\ New Characteristics:
\ Multiple keys can be used and can be sorted in one go.
\ The number of keys is limited by the size of the stack.
\ Each key can be ascending or descending sorted.

--- NEW FILE: mshell_r.f ---
anew mshell_rel.f       \  October 24th, 2005

\ A flexible shellsort.

\ Notes:
\ The database and the pointers must be mapped.
\ Minimum file size of the database must be 1 byte.
\ When the database is resized, the database has to be re-mapped.

\ Characteristics:
\ This version saves its pointers as relative offsets in an index file.
\ The sort is case-insensitive.
\ Multiple keys can be used and can be sorted in one go.
\ The number of keys is limited by the size of the stack.
\ Each key can be ascending or descending sorted.



needs w_search.f

    23 value record-size
   112 value #records
     0 value aptrs  \ an array of cells containing pointers to records
     0 value records-pointer

: n>aptr   ( n -- a )   S" aptrs +cells                 " EVALUATE ; IMMEDIATE
: r>record ( n -- a )   S" records-pointer ( CHARS) +   " EVALUATE ; IMMEDIATE
: record>r ( a -- n )   S" records-pointer ( CHARS) -   " EVALUATE ; IMMEDIATE
: n>record ( n -- a )   S" n>aptr @ r>record            " EVALUATE ; IMMEDIATE
\ : n>key    ( n -- a ) S" n>record >key                " EVALUATE ; IMMEDIATE
: records  ( n -- ra )  S" record-size *                " EVALUATE ; IMMEDIATE
: >record  ( n -- a )   S" records r>record             " EVALUATE ; IMMEDIATE
: xchange  ( a1 a2 -- ) S" dup>r @ over @ r> ! swap !   " EVALUATE ; IMMEDIATE
: &key-len ( key - &key-len )   s" cell+                " EVALUATE ; IMMEDIATE
: >key     ( ra - key-start )   s" by @ +               " EVALUATE ; IMMEDIATE
: key-len  ( ra - cnt )         s" by &key-len @        " EVALUATE ; IMMEDIATE

: <>=      ( n1 n2 - -1|0|1 )
   s" 2dup = if  2drop 0  else <  if 1 else  true  then  then " EVALUATE ; IMMEDIATE

: cmp-cell { by }   ( cand1 cand2 by - p1 p2 n )
   >key @ swap >key @  <>=
 ;

: cmp$     { by }   ( cand1 cand2 by - p1 p2 n )
   swap >key swap >key key-len tuck compareia
 ;

: mod-cell    ( n adr offset - ) >r swap r> cells+ !  ;
: Ascending   ( key - key ) dup 0 2 mod-cell ;
: Descending  ( key - key ) dup -1 2 mod-cell ;
: $sort       ( key - )     ['] cmp$ 3 mod-cell ;
: bin-sort    ( key - )     ['] cmp-cell 3 mod-cell ;

: Descending? ( key - )     s" 2 cells+ @ " EVALUATE ; IMMEDIATE

\ Ascending and cmp$ are default in key:
: key: \ Compiletime: ( start len -< name >- )  Runtime ( - adr-key )
   create swap , , 0 , ['] cmp$ ,
 ;

: by[ ( R: -  #stack )                  s" depth >r  "  EVALUATE ; IMMEDIATE
: ]by ( - #stack-inc) ( R: #stack - )   s" depth r> - " EVALUATE ; IMMEDIATE

: CmpBy  ( cand1 cand2  ByStackTop #keys - p1 p2 f )
   true LOCALS| flag #keys  ByStackTop cand2 cand1 |
   #keys 0
        do   cand1 cand2  ByStackTop i cells+ @ dup 3 cells+ @ execute
             dup 0=
                if    drop
                else   ByStackTop i cells+ @ Descending?
                        if    0<
                        else  0>
                        then
                      to flag leave             \ 0=exch
                then

        loop
   flag
 ;

: mshell-rel  ( keyx..key1 #keys aptrs #records -- )
    sp@ 3 cells+ 3 roll LOCALS| #keys by |
    dup 2 <
      if    2drop
      else  1  begin  3 * 1+ 2dup 1+ u< until  \ gap*3
            begin  3 / dup
            while  2dup - >r dup cells r> 0
                      do  dup 4 pick dup i cells +
                            do  dup i + dup @ r>record
                                i tuck @ r>record  by #keys CmpBy
                                    if    2drop  leave
                                    then
                                xchange dup negate
                            +loop  drop
                       loop  drop
           repeat  2drop drop
      then
    sp@ #keys cells+ sp!
  ;

: build-ptrs ( #records -- )
   to #records #records 1+ cells allocate throw  to aptrs  #records 1+ 0
     do   records-pointer i records ( chars ) + aptrs i cells + !
     loop ;

: free-ptrs     ( -- )  aptrs FREE THROW ;
: free-records  ( -- )  records-pointer FREE THROW ;

\ : check-keys  ( -- )
\    space #records 1-
\    0 do  i n>key i 1+ n>key  key-len tuck compareia 0>
\      if ." UN" leave then loop ." sorted " ;

: create-file-ptrs ( name -- )
   count r/w create-file abort" Can't create index file."  close-file throw
 ;

: open-file-ptrs ( name -- hndl )
   count r/w open-file abort" Can't open index file."
 ;

: extend-file ( size hndl - )
    dup>r file-size drop d>s +
    s>d r@ resize-file abort" Can't extend file."
    r> close-file  drop
 ;

: #records-in-database ( m_hndl - #records )  >hfileLength @ record-size /   ;

: add-file-ptrs ( #start #end - )
   dup to #records swap
      do  i records aptrs i cells + !
      loop
 ;

: build-file-ptrs ( #records -- ) 0 swap  add-file-ptrs ;

\s