Power-Programmierung/CD1.mdf/basic/library/qb_pds/database/tdb/tdb.bas

BASIC Source File | 1992-01-22 | 22.4 KB | 868 lines

DECLARE FUNCTION CompareRecords% (index1%, index2%)
DECLARE SUB ShowMessage (message$)
DECLARE SUB ClearMessage ()
DECLARE FUNCTION GetYesNo% (prompt$)
DECLARE SUB LoadRecords ()
DECLARE SUB SaveRecords ()
DECLARE SUB ClearFields ()
DECLARE SUB KbdEdit (buffer$, maxlen%, fg%, bg%, cancel%)
DECLARE SUB AddRecord ()
DECLARE SUB DeleteRecord ()
DECLARE SUB EditRecord ()
DECLARE SUB SortRecords ()
DECLARE SUB FindRecord ()
DECLARE SUB PrevRecord ()
DECLARE SUB NextRecord ()
DECLARE SUB PrintRecords ()
DECLARE SUB ErrBeep ()
DECLARE FUNCTION GetKey$ ()
DECLARE SUB Help ()
DECLARE SUB ShowRecord ()
DECLARE SUB Terminate (confirm%)
DECLARE SUB PaintDisplay ()
DECLARE SUB Frame (top%, bottom%, left%, right%)

DEFINT A-Z
'
' The Telephone Data Base, Version 1.00, Copyright (c) 1992 SoftCircuits
' Redistributed by permission
'
'  SoftCircuits Programming
'  P.O. Box 16262
'  Irvine, CA 92713
'
' This program may be used and distributed freely on the condition
' that no fee is charged for such use and distribution with the
' exception of reasonable media and shipping charges.
'
' This program may not be used for commercial purposes without
' written permission from SoftCircuits Programming.
'

CONST MAXLAST = 25
CONST MAXFIRST = 25
CONST MAXPHONE = 20
CONST MAXSTREET = 20
CONST MAXCITY = 20
CONST MAXSTATE = 2
CONST MAXZIP = 10

CONST FIRSTROW = 7, FIRSTCOL = 27
CONST LASTROW = 9, LASTCOL = 26
CONST PHONEROW = 11, PHONECOL = 29
CONST STREETROW = 13, STREETCOL = 23
CONST CITYROW = 15, CITYCOL = 21
CONST STATEROW = 17, STATECOL = 22
CONST ZIPROW = 17, ZIPCOL = (STATECOL + MAXSTATE) + 16

CONST WINTOP = 5, WINBOTTOM = 19
CONST WINLEFT = 10, WINRIGHT = 70

CONST MESSAGEROW = 22

'Makes arrays dynamic
'$DYNAMIC

TYPE record
   first AS STRING * MAXFIRST
   last AS STRING * MAXLAST
   phone AS STRING * MAXPHONE
   street AS STRING * MAXSTREET
   city AS STRING * MAXCITY
   state AS STRING * MAXSTATE
   zip AS STRING * MAXZIP
END TYPE

COMMON SHARED scrnFg
COMMON SHARED scrnBg
COMMON SHARED winFg
COMMON SHARED winBg
COMMON SHARED statFg
COMMON SHARED statBg

COMMON SHARED numRecords
COMMON SHARED currRecord

   DIM SHARED records(0) AS record
   numRecords = 0
   currRecord = 0

   scrnFg = 7              'Default black and white colors
   scrnBg = 0
   winFg = 0
   winBg = 7
   statFg = 0
   statBg = 7

   'If display adapter is emulating CGA and /b switch not given
   'then set colors to work on color display
   IF INSTR(UCASE$(COMMAND$), "/B") = 0 THEN
      DEF SEG = &H40
      IF (PEEK(&H10) AND &H30) <> &H30 THEN
         scrnFg = 11
         scrnBg = 1
         winFg = 0
         winBg = 7
         statFg = 0
         statBg = 3
      END IF
   END IF

   CALL LoadRecords
   CALL PaintDisplay

   DO
      SELECT CASE GetKey$
         CASE CHR$(&H0) + CHR$(&H3B)   'F1 (Help)
            CALL Help
         CASE CHR$(&H0) + CHR$(&H3C)   'F2 (Add)
            CALL AddRecord
         CASE CHR$(&H0) + CHR$(&H3D)   'F3 (Delete)
            CALL DeleteRecord
         CASE CHR$(&H0) + CHR$(&H3E)   'F4 (Edit)
            CALL EditRecord
         CASE CHR$(&H0) + CHR$(&H3F)   'F5 (Sort)
            CALL SortRecords
         CASE CHR$(&H0) + CHR$(&H40)   'F6 (Find)
            CALL FindRecord
         CASE CHR$(&H0) + CHR$(&H41)   'F7 (Previous)
            CALL PrevRecord
         CASE CHR$(&H0) + CHR$(&H42)   'F8 (Next)
            CALL NextRecord
         CASE CHR$(&H0) + CHR$(&H5A)   'Shift+F7 (First)
            IF currRecord > 1 THEN currRecord = 1
            CALL ShowRecord
         CASE CHR$(&H0) + CHR$(&H5B)   'Shift+F8 (Last)
            IF currRecord < numRecords THEN currRecord = numRecords
            CALL ShowRecord
         CASE CHR$(&H0) + CHR$(&H43)   'F9 (Print)
            CALL PrintRecords
         CASE CHR$(&H0) + CHR$(&H44)   'F10 (Quit)
            CALL Terminate(confirm)
            IF confirm THEN EXIT DO
         CASE ELSE
            CALL ErrBeep
      END SELECT
   LOOP

   COLOR 7, 0, 0
   CLS

END

REM $STATIC
'
' Adds a new record to the database and makes it the current record
'
SUB AddRecord

   DIM newEntry AS record        'Temporary record

   COLOR winFg, winBg
   CALL ClearFields              'Clear current record from window

   LOCATE FIRSTROW, FIRSTCOL     'Let user type in information
   CALL KbdEdit(newEntry.first, MAXFIRST, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEntry
   LOCATE LASTROW, LASTCOL
   CALL KbdEdit(newEntry.last, MAXLAST, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEntry
   LOCATE PHONEROW, PHONECOL
   CALL KbdEdit(newEntry.phone, MAXPHONE, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEntry
   LOCATE STREETROW, STREETCOL
   CALL KbdEdit(newEntry.street, MAXSTREET, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEntry
   LOCATE CITYROW, CITYCOL
   CALL KbdEdit(newEntry.city, MAXCITY, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEntry
   LOCATE STATEROW, STATECOL
   CALL KbdEdit(newEntry.state, MAXSTATE, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEntry
   LOCATE ZIPROW, ZIPCOL
   CALL KbdEdit(newEntry.zip, MAXZIP, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEntry

   'Allocate temporary storage for records
   REDIM temp(numRecords) AS record
   FOR i = 1 TO numRecords
      temp(i) = records(i)
   NEXT i

   'Resize records array and restore records
   REDIM records(numRecords + 1) AS record
   FOR i = 1 TO numRecords
      records(i) = temp(i)
   NEXT i
   ERASE temp

   numRecords = numRecords + 1
   currRecord = numRecords
   records(currRecord) = newEntry

cancelEntry:
   CALL ShowRecord               'Update display

END SUB

'
' Clears all record fields using the current color
'
SUB ClearFields

   LOCATE FIRSTROW, FIRSTCOL:    PRINT SPACE$(MAXFIRST)
   LOCATE LASTROW, LASTCOL:      PRINT SPACE$(MAXLAST)
   LOCATE PHONEROW, PHONECOL:    PRINT SPACE$(MAXPHONE)
   LOCATE STREETROW, STREETCOL:  PRINT SPACE$(MAXSTREET)
   LOCATE CITYROW, CITYCOL:      PRINT SPACE$(MAXCITY)
   LOCATE STATEROW, STATECOL:    PRINT SPACE$(MAXSTATE)
   LOCATE ZIPROW, ZIPCOL:        PRINT SPACE$(MAXZIP)

END SUB

'
' Clears the current message from the message area
'
SUB ClearMessage

   COLOR scrnFg, scrnBg
   LOCATE MESSAGEROW, 1
   PRINT SPACE$(80)

END SUB

'
' Compares two records. Returns 1 if the first record should
' come after the second. Otherwise 0 is returned.
'
FUNCTION CompareRecords (index1, index2)

   CompareRecords = 0

   IF UCASE$(records(index1).last) > UCASE$(records(index2).last) THEN
      CompareRecords = 1
   ELSEIF UCASE$(records(index1).last) = UCASE$(records(index2).last) THEN
      IF UCASE$(records(index1).first) > UCASE$(records(index2).last) THEN
         CompareRecords = 1
      END IF
   END IF

END FUNCTION

'
' Deletes the current record (after confirmation)
'
SUB DeleteRecord

   IF numRecords > 0 THEN     'Must be something to delete

      IF GetYesNo("Delete the current record [Y/N]?") THEN

         'Allocate temporary storage for records
         REDIM temp(numRecords - 1) AS record

         'Fill temporary array with all records except
         'the current record
         FOR i = 1 TO (currRecord - 1)
            temp(i) = records(i)
         NEXT i
         FOR i = currRecord TO (numRecords - 1)
            temp(i) = records(i + 1)
         NEXT i

         'One less record
         numRecords = numRecords - 1

         'Resize records array and restore records
         REDIM records(numRecords) AS record
         FOR i = 1 TO numRecords
            records(i) = temp(i)
         NEXT i
         ERASE temp

         'Make sure currRecord remains within range
         IF currRecord > numRecords THEN currRecord = numRecords

         CALL ShowRecord      'Update display

      END IF

   END IF

END SUB

'
' Allows the user to edit the current record
'
SUB EditRecord

   DIM newEntry AS record        'Temporary record

   IF currRecord = 0 THEN        'Nothing to edit
      CALL ErrBeep
      EXIT SUB
   END IF

   CALL ShowMessage("Edit the current field  <Enter>=Next field  <Esc>=Cancel")
   newEntry = records(currRecord)

   COLOR statFg, statBg          'Edit record a field at a time
   LOCATE FIRSTROW, FIRSTCOL
   CALL KbdEdit(newEntry.first, MAXFIRST, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEdit
   LOCATE LASTROW, LASTCOL
   CALL KbdEdit(newEntry.last, MAXLAST, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEdit
   LOCATE PHONEROW, PHONECOL
   CALL KbdEdit(newEntry.phone, MAXPHONE, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEdit
   LOCATE STREETROW, STREETCOL
   CALL KbdEdit(newEntry.street, MAXSTREET, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEdit
   LOCATE CITYROW, CITYCOL
   CALL KbdEdit(newEntry.city, MAXCITY, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEdit
   LOCATE STATEROW, STATECOL
   CALL KbdEdit(newEntry.state, MAXSTATE, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEdit
   LOCATE ZIPROW, ZIPCOL
   CALL KbdEdit(newEntry.zip, MAXZIP, winFg, winBg, cancel)
   IF cancel THEN GOTO cancelEdit

   records(currRecord) = newEntry

cancelEdit:
   CALL ShowRecord               'Update display
   CALL ClearMessage

END SUB

'
' Sounds the computers internal speaker
'
SUB ErrBeep

   SOUND 800, 2
   SOUND 400, 2

   WHILE INKEY$ <> "": WEND         'Flush keyboard buffer

END SUB

'
' Searches the database for a given string (not case sensitive)
'
SUB FindRecord

   'Get input and convert to upper case
   LOCATE MESSAGEROW, 15
   COLOR scrnFg, scrnBg
   PRINT "Enter search string: ";
   CALL KbdEdit(inputString$, 30, scrnFg, scrnBg, cancel)
   CALL ClearMessage

   IF cancel = 1 THEN EXIT SUB
   searchString$ = UCASE$(inputString$)

   'Scan records for match
   FOR i = 1 TO numRecords
      found = 0
      IF INSTR(UCASE$(records(i).first), searchString$) <> 0 THEN
         found = 1
      ELSEIF INSTR(UCASE$(records(i).last), searchString$) <> 0 THEN
         found = 1
      ELSEIF INSTR(UCASE$(records(i).phone), searchString$) <> 0 THEN
         found = 1
      ELSEIF INSTR(UCASE$(records(i).street), searchString$) <> 0 THEN
         found = 1
      ELSEIF INSTR(UCASE$(records(i).city), searchString$) <> 0 THEN
         found = 1
      ELSEIF INSTR(UCASE$(records(i).state), searchString$) <> 0 THEN
         found = 1
      ELSEIF INSTR(UCASE$(records(i).zip), searchString$) <> 0 THEN
         found = 1
      END IF

      'If a match was found, show matching record and
      'ask if the search should continue
      IF found = 1 THEN
         currRecord = i
         CALL ShowRecord
         IF GetYesNo("Find next match [Y/N]?") = 0 THEN EXIT SUB
      END IF
   NEXT i

   'Tell user no more matches found
   a$ = "Match not found for " + CHR$(&H22) + inputString$
   a$ = a$ + CHR$(&H22) + ", press any key"
   CALL ShowMessage(a$)
   a$ = GetKey$
   CALL ClearMessage

END SUB

'
' Displays a box with the specified coordinates
' The inside of the box is cleared to the current color
'
SUB Frame (top, bottom, left, right)

   LOCATE top, left
   PRINT CHR$(&HC9); STRING$((right - left) - 1, CHR$(&HCD)); CHR$(&HBB);

   FOR row = (top + 1) TO (bottom - 1)
      LOCATE row, left
      PRINT CHR$(&HBA); SPACE$((right - left) - 1); CHR$(&HBA);
   NEXT row

   LOCATE bottom, left
   PRINT CHR$(&HC8); STRING$((right - left) - 1, CHR$(&HCD)); CHR$(&HBC);

END SUB

'
' Returns the next available keystroke (read with INKEY$)
'
FUNCTION GetKey$

   ch$ = "": WHILE ch$ = "": ch$ = INKEY$: WEND
   GetKey$ = ch$

END FUNCTION

'
' Displays the given prompt and gets a yes/no response from the user
' Returns 1 if "Y" was pressed or 0 if "N" was pressed
'
FUNCTION GetYesNo (prompt$)

   CALL ShowMessage(prompt$)

   DO
      a$ = UCASE$(GetKey$)             'Wait for "Y" or "N"
      IF a$ = "Y" OR a$ = "N" THEN
         EXIT DO
      ELSE
         CALL ErrBeep
      END IF
   LOOP

   CALL ClearMessage

   IF a$ = "Y" THEN GetYesNo = 1 ELSE GetYesNo = 0

END FUNCTION

'
' Displays help screen
'
SUB Help

   COLOR winFg, winBg
   CALL Frame(5, 19, 3, 78)   'Create help window

   LOCATE 7, 33               'Display help info
   PRINT "Help Screen"

   tab1 = 7
   tab2 = 44
   LOCATE 9, tab1
   PRINT "<F1>=Help (this screen)";
   LOCATE , tab2
   PRINT "<F2>=Add a new record"
   LOCATE , tab1
   PRINT "<F3>=Delete the current record";
   LOCATE , tab2
   PRINT "<F4>=Edit the current record"
   LOCATE , tab1
   PRINT "<F5>=Sort records";
   LOCATE , tab2
   PRINT "<F6>=Find a record"
   LOCATE , tab1
   PRINT "<F7>=Show the previous record";
   LOCATE , tab2
   PRINT "<F8>=Show the next record"
   LOCATE , tab1
   PRINT "<Shift+F7>=Show the first record";
   LOCATE , tab2
   PRINT "<Shift+F8>=Show the last record"
   LOCATE , tab1
   PRINT "<F9>=Send records to a printer";
   LOCATE , tab2
   PRINT "<F10>=Save records and quit"

   LOCATE 17, 27
   PRINT "Press any key to exit help"
   a$ = GetKey$

   CALL PaintDisplay          'Restore screen

END SUB

'
'  Keyboard editor, recognizes Escape,
'  If first key pressed is an edit key the old string is edited
'  otherwise, the old string is discarded
'
SUB KbdEdit (buffer$, maxlen, fg, bg, cancel)

   row = CSRLIN               'Save cursor position
   col = POS(0)

   'Remove trailing spaces or uninitialized 0's
   IF LEFT$(buffer$, 1) = CHR$(0) THEN buffer$ = ""
   buffer$ = RTRIM$(buffer$)

   LOCATE row, col, 1         'Display string in inverse video
   COLOR fg, bg
   PRINT STRING$(maxlen, CHR$(&HF9));
   LOCATE row, col
   COLOR bg, fg
   PRINT buffer$;
   COLOR fg, bg

   a$ = GetKey$               'Get a key

   'If the key was a edit key, we will edit the original string
   'otherwise, we assume the user's typing a new string and the
   'original is discarded
   IF a$ >= " " AND a$ <= "~" THEN
      temp$ = ""
   ELSE
      temp$ = buffer$
   END IF
   posn = LEN(temp$)

   done = 0                   '0 until <Esc> or <Enter> is pressed
   first = 1                  'Indicates first time through

   DO
      'Don't read a new key if it's our first time through
      IF first = 1 THEN
         first = 0
      ELSE
         LOCATE row, col
         PRINT temp$; STRING$(maxlen - LEN(temp$), CHR$(&HF9))
         LOCATE row, col + posn
         a$ = GetKey$
      END IF

      SELECT CASE a$
         CASE " " TO "~"
            IF LEN(temp$) < maxlen THEN
               first$ = LEFT$(temp$, posn)
               last$ = RIGHT$(temp$, LEN(temp$) - posn)
               temp$ = first$ + a$ + last$
               posn = posn + 1
            ELSE
               CALL ErrBeep
            END IF
         CASE CHR$(8)               'Backspace
            IF posn > 0 THEN
               first$ = LEFT$(temp$, posn - 1)
               last$ = RIGHT$(temp$, LEN(temp$) - posn)
               temp$ = first$ + last$
               posn = posn - 1
            ELSE
               CALL ErrBeep
            END IF
         CASE CHR$(0) + CHR$(&H53)  'Delete
            IF posn < LEN(temp$) THEN
               first$ = LEFT$(temp$, posn)
               last$ = RIGHT$(temp$, LEN(temp$) - (posn + 1))
               temp$ = first$ + last$
            ELSE
               CALL ErrBeep
            END IF
         CASE CHR$(0) + CHR$(&H4B)  'Left
            IF posn > 0 THEN
               posn = posn - 1
            ELSE
               CALL ErrBeep
            END IF
         CASE CHR$(0) + CHR$(&H4D)  'Right
            IF posn < LEN(temp$) THEN
               posn = posn + 1
            ELSE
               CALL ErrBeep
            END IF
         CASE CHR$(0) + CHR$(&H47)  'Home
            posn = 0
         CASE CHR$(0) + CHR$(&H4F)  'End
            posn = LEN(temp$)
         CASE CHR$(13)              'Enter (Accept)
            buffer$ = temp$
            done = 1
            cancel = 0
         CASE CHR$(27)              'Escape (Cancel)
            done = 1
            cancel = 1
         CASE ELSE
            CALL ErrBeep
      END SELECT

   LOOP UNTIL done

   COLOR fg, bg                     'Display the resulting string
   LOCATE row, col, 0
   PRINT buffer$; SPACE$(maxlen - LEN(buffer$))

END SUB

'
' Loads a database from disk
'
SUB LoadRecords

   CALL ShowMessage("Loading records...")

   'Open data file
   OPEN "TDB.DAT" FOR RANDOM AS #1 LEN = LEN(records(0))

   'Calculate numRecords and allocate records array
   numRecords = LOF(1) \ LEN(records(0))
   REDIM records(numRecords) AS record

   'Read records
   FOR i = 1 TO numRecords
      GET #1, i, records(i)
   NEXT i
   CLOSE #1

   IF numRecords > 0 THEN currRecord = 1

   CALL ClearMessage

END SUB

'
' Makes the next record the current record
'
SUB NextRecord

   IF currRecord < numRecords THEN
      currRecord = currRecord + 1
      CALL ShowRecord
   ELSE
      CALL ErrBeep
   END IF

END SUB

'
' Creates the main display and calls ShowRecord
'
SUB PaintDisplay

   COLOR scrnFg, scrnBg, scrnBg        'Clear screen
   CLS

   COLOR statFg, statBg                'Create title status bar
   LOCATE 1, 1: PRINT SPACE$(80)
   LOCATE 1, 20: PRINT "The Telephone Data Base, Version 1.00"

   COLOR winFg, winBg                  'Create record window
   CALL Frame(WINTOP, WINBOTTOM, WINLEFT, WINRIGHT)

   LOCATE LASTROW, LASTCOL - 11        'Print field labels
   PRINT "Last Name:"
   LOCATE FIRSTROW, FIRSTCOL - 12
   PRINT "First Name:"
   LOCATE PHONEROW, PHONECOL - 14
   PRINT "Phone Number:"
   LOCATE STREETROW, STREETCOL - 8
   PRINT "Street:"
   LOCATE CITYROW, CITYCOL - 6
   PRINT "City:"
   LOCATE STATEROW, STATECOL - 7
   PRINT "State:"
   LOCATE ZIPROW, ZIPCOL - 10
   PRINT "Zip Code:"

   LOCATE 25, 1                        'Display function-key bar
   COLOR scrnFg, scrnBg: PRINT "1";
   COLOR statFg, statBg: PRINT "Help  ";
   COLOR scrnFg, scrnBg: PRINT " 2";
   COLOR statFg, statBg: PRINT "Add   ";
   COLOR scrnFg, scrnBg: PRINT " 3";
   COLOR statFg, statBg: PRINT "Delete";
   COLOR scrnFg, scrnBg: PRINT " 4";
   COLOR statFg, statBg: PRINT "Edit  ";
   COLOR scrnFg, scrnBg: PRINT " 5";
   COLOR statFg, statBg: PRINT "Sort  ";
   COLOR scrnFg, scrnBg: PRINT " 6";
   COLOR statFg, statBg: PRINT "Find  ";
   COLOR scrnFg, scrnBg: PRINT " 7";
   COLOR statFg, statBg: PRINT "Prev  ";
   COLOR scrnFg, scrnBg: PRINT " 8";
   COLOR statFg, statBg: PRINT "Next  ";
   COLOR scrnFg, scrnBg: PRINT " 9";
   COLOR statFg, statBg: PRINT "Print ";
   COLOR scrnFg, scrnBg: PRINT " 10";
   COLOR statFg, statBg: PRINT "Quit  ";

   CALL ShowRecord                     'Display current record

END SUB

'
' Makes the previous record the current record
'
SUB PrevRecord

   IF currRecord > 1 THEN
      currRecord = currRecord - 1
      CALL ShowRecord
   ELSE
      CALL ErrBeep
   END IF

END SUB

'
' Send the database to the printer
'
SUB PrintRecords

   IF GetYesNo("Send records to printer [Y/N]?") THEN
      CALL ShowMessage("Printing records...")
      FOR i = 1 TO numRecords
         LPRINT RTRIM$(records(i).first); " ";
         LPRINT RTRIM$(records(i).last); " ";
         LPRINT RTRIM$(records(i).phone)
         LPRINT RTRIM$(records(i).street)
         LPRINT RTRIM$(records(i).city); " ";
         LPRINT RTRIM$(records(i).state); " ";
         LPRINT RTRIM$(records(i).zip)
         LPRINT
      NEXT i
      CALL ClearMessage
   END IF

END SUB

'
' Writes the database to disk
'
SUB SaveRecords

   IF GetYesNo("Save records to disk [Y/N]?") THEN
      CALL ShowMessage("Saving records...")
      KILL "TDB.DAT"

      'Open the data file
      OPEN "TDB.DAT" FOR RANDOM AS #1 LEN = LEN(records(0))

      'Write the records to disk
      FOR i = 1 TO numRecords
         PUT #1, i, records(i)
      NEXT i
      CLOSE #1

      CALL ClearMessage
   END IF

END SUB

'
' Displays the given message in the message area
'
SUB ShowMessage (message$)

   COLOR scrnFg, scrnBg
   LOCATE MESSAGEROW, (80 - LEN(message$)) / 2    'Center message string
   PRINT message$

END SUB

'
' Displays the current record
'
SUB ShowRecord

   COLOR winFg, winBg

   'Show current record number against number of records
   LOCATE WINTOP, WINLEFT + 5
   PRINT "["; currRecord; "/"; numRecords; "]"; STRING$(10, &HCD)

   IF numRecords = 0 THEN
      CALL ClearFields
   ELSE
      LOCATE FIRSTROW, FIRSTCOL
      PRINT records(currRecord).first
      LOCATE LASTROW, LASTCOL
      PRINT records(currRecord).last
      LOCATE PHONEROW, PHONECOL
      PRINT records(currRecord).phone
      LOCATE STREETROW, STREETCOL
      PRINT records(currRecord).street
      LOCATE CITYROW, CITYCOL
      PRINT records(currRecord).city
      LOCATE STATEROW, STATECOL
      PRINT records(currRecord).state
      LOCATE ZIPROW, ZIPCOL
      PRINT records(currRecord).zip
   END IF

END SUB

'
' Uses a shell sort to sort all the records in the database.
' Records are compared by calling CompareRecords.
'
SUB SortRecords

   IF numRecords = 0 THEN        'Nothing to sort
      CALL ErrBeep
      EXIT SUB
   END IF

   IF GetYesNo("Sort records [Y/N]?") THEN

      'Set comparison offset to half the number of records
      offset = numRecords \ 2

      DO WHILE offset > 0        'Loop until offset gets to 0
         limit = numRecords - offset
         DO
            switch = 0           'Assume no switches at this offset

            'Compare elements and switch those out of order
            FOR i = 1 TO limit
               IF CompareRecords(i, i + offset) THEN
                  SWAP records(i), records(i + offset)
                  switch = i
               END IF
            NEXT i

            'Sort on next pass only to where last switch was made
            limit = switch - offset
         LOOP WHILE switch

         'No switches at last offset, try one half as big
         offset = offset \ 2

      LOOP
      currRecord = 1             'Go to first record and update screen
      CALL ShowRecord
   END IF

END SUB

'
' Saves the records to disk and sets confirm to 1 if the user confirms
' they want to exit. Otherwise, confirm is set to 0
'
SUB Terminate (confirm)

   IF GetYesNo("Exit to DOS [Y/N]?") THEN
      CALL SaveRecords
      confirm = 1
   ELSE
      confirm = 0
   END IF

END SUB