2variable dbref

: sort-DBname ( -- z-addr n )
  z" SortDemoData"   ;

id Srt2  \ creator id
id DATA

: dbRecordCount (  -- u )
  dbref 2@ DmNumRecords  ;

: ?openDB ( -- dbref.|null. Err )
  dmModeReadWrite Srt2 DATA
  DmOpenDatabaseByTypeCreator
  2dup or 0= ;

: openDatabase ( -- )
  ?openDB if
    2drop
    false   DATA   Srt2
    sort-DBname drop >abs
    0  DmCreateDatabase throw
    ?openDB drop
  then
  dbref 2! ;

: closeDatabase ( -- )
  dbref 2@ DmCloseDatabase drop ;

Pretty much boilerplate database code for open and close. openDatabase checks for existence of the DB and creates it if not found. (Later during start-up sequence we will populate the DB with records if the record count is found to be zero.)

The creator ID is registered. Always do that.

(I'm pretty sure there's some legacy fragments from Ron Doerfler's Database Tutorial in here. Thanks again, Ron)

: releaseRecord
( dirtyflag index dbref. recptr.-- err)
  MemPtrUnlock >r
  DmReleaseRecord r> or ;

: sizeRecord ( index -- size )
  dbref 2@ DmQueryRecord
  MemHandleSize d>s ;

create (index) 0 ,

: newRecord ( addr len  -- )
  \ store index
  dbRecordCount  (index)  !
  \ Convert len to 32bit and dup
   s>d 2dup (index) >abs dbref 2@
  ( addr len. len.  index-addr. dbref. )
  DmNewRecord MemHandleLock
  2>r rot >abs 0.
  2r@ DmWrite drop
  2r> true (index) @ 2swap
  dbref 2@ 2swap
  releaseRecord throw
  ;

More database utility words. (index) is passed by reference to DmNewRecord so we stuff it in a variable.

create recordbuff 38 allot

: assembleRecord
  ( n str-addr cnt -- n=size )
  \ zero out the buffer
  recordbuff 38 0 fill
  dup >R
  \ move the string
  recordbuff 2 + swap move
  \ store n
  recordbuff !
  \ and return cnt+3=size
  R> 3 +
  ;

: addRecord ( n str-addr cnt --  )
  assembleRecord
  recordbuff swap newRecord
  ;

: populateDB? ( -- )
  dbRecordCount 0= if
  7701  s" Barringer" addRecord
  3360  s" Abernathy" addRecord
  9021  s" Spelling" addRecord
  6222  s" Washington" addRecord
  3360  s" McMurphy" addRecord
  4042  s" cummings" addRecord
  1012  s" McMurphy" addRecord
  8290  s" Fitzgerald" addRecord
  4042  s" Harrigan" addRecord
  then
  ;

We create recordbuff as a place to assemble our records for writing to the DB.

Record layout is:

FIELD 1: 2 bytes to hold the ID number.

FIELD 2: variable length zero terminated string.

The ID is just a number with no special meaning for our purposes. It provides a column of numbers we can sort on. Name field is a zero terminated string so the field offset to the text (which will be passed to the string compare routine) is 2.

addRecord takes the ID number and string, assembles it into record format and writes it to the DB.

populateDB? checks the DB's record count and runs if there are no records. Do this at start-up, it will only run through the first time, or again if someone deletes the DB.

If you add more records here, the display will over-run and be ugly. Also, the name column lines up because the numbers are all 4 digits. Just a demo. If you make other changes to the data you will have to manually delete the DB before running or demo will not generate the new records. Or you could change the code to always delete and regenerate on each launch.

Note that I've included one lower-case name in the sample data to show how strCaselessCompare will still order it properly. e e cummings. Yes.

Also, I have included a couple of duplicate numbers and names in the list. What if we wanted to have the duplicate names sorted in ID order? Hmmm.

: getRecord ( index  -- )
  dup dbref 2@
  DmQueryRecord
  MemHandleLock 2>R
  sizeRecord S>D
  2R@ recordbuff >ABS
  MemMove throw
  2R> MemPtrUnlock throw
  ;

: eraseForm
  0 rect1 >ABS winEraseRectangle
  ;

: printRecord ( recIndex -- )
  dup getRecord
  3 spaces 1+ . 2 spaces
  recordbuff @ . 2 spaces
  recordbuff 2 +
  dup >ABS strLen type
  ;

: printList
  eraseForm
  33 currenty ! 0 currentx !
  dbRecordCount 0 do
    i printRecord cr
  loop
  ;

getRecord queries the DB by index and MemMove's the record data to recordbuff.

printList loops on printRecord after erasing the form. All standard FORTH output words. Quite ordinary.

create Z-A? 0 ,

: descending? (  n  --   n'  )
  Z-A? @ if  negate  then
  ;

: dmComparFname
  callback
  (  H. P. P. n rec2. rec1. -- ...  n  )
  2 m+ 2swap 2 m+ 2swap
  strCaselessCompare
  descending?
  0 d0.L! (  ...  n --  )
  end-callback
  ;

: sortRecordsName ( -- )
  0 \ other
  ['] dmComparFname xt>ABS
  dbref 2@
  dmQuickSort throw
  ;

: dmComparFid
  callback
  (  H. P. P. n rec2. rec1. -- ...  n  )
  @a rot rot @a -
  descending?
  0 d0.L! (  ...  n --  )
  end-callback
  ;

: sortRecordsID
  0 \ other
  ['] dmComparFid xt>ABS
  dbref 2@
  dmQuickSort throw
  ;

The Data Manager sort routine will call our compare function to compare records. Our function will use only the top two double-precision items, the two record pointers. We need to adjust both by 2 to access the name field of the record:

2 m+ 2swap 2 m+ 2swap

We then pass these adjusted pointers to strCaselessCompare to learn which is alphabetically predominant.

Z-A? holds the boolean for our sort direction, true if descending (Z-A). The string comparison call strCaselessCompare will return a positive, negative, or zero value to indicate the precedence of record1 over record2. To reverse the order we invert the sign of this return value as long as it is not zero, with descending?.

We then return the result back to the calling sort routine by placing it in register d0:

0 d0.L!

The callback and end-callback wrapper words set up their own stack, so we needn't worry about dropping the unused parameters. All that remains is to place the call to DmQuickSort (or DmInsertionSort.) Pass the DmComparF function with:

['] dmComparFname xt>ABS

We do pretty much the same for sorting the ID column. We generate the proper value (positive, zero, or negative) by pulling the first cell from each record and subtracting:

@a rot rot @a -

: doControls
  ZA-btn GetControlValue Z-A? !
  Name-btn GetControlValue
  if
    sortRecordsName
  else
    sortRecordsID
  then
  printList
  ;

: eventLoop
  begin
    ekey ctlSelectEvent =
    if doControls then
  again
  ;

The form has two push-button pairs which allow you to specify the sort order and select which data is to be sorted. eventLoop looks only for the ctlSelectevent and then passes to doControls.

The boolean variable Z-A? will be set to the value of the ZA-btn. The Name-btn value affects branching to the appropriate sort routine. Note that no check is performed to see if these values have changed since the last draw. They just re-sort and re-draw the list upon the event of any control tap. A real application would probably want to behave with more finesse.

: (go)
  1024 callback-stack
  1001 showForm
  openDatabase
  populateDB?
  sortRecordsName
  printList
  eventLoop
  ;

: go ( -- )
  ['] (go) catch
  dup byethrow = if
      closeDatabase
  then
  throw ;

' go Srt2 makeprc DmSortDemo

1001 (id) tFRM copyrsrc

Don't forget the 1024 callback-stack. This must be done prior to any invocation of a callback/end-callback word.

Normal type start-up code. Show the form. Open the DB. We check to see if the DB's got its records, because if it's just been created, it won't. We also do a name sort to rectify the list's sorting with the fixed status of the push-button controls upon start-up. It would be bad UI if the controls indicated sorted data when the data wasn't sorted. A real app would store this state in an appPrefs and restore it upon start-up.

Close the database upon a byethrow. Grind out the PRC. Copy the form resource.

Or run from the console with go.

Done. May someone find this useful in some way.