Microsoft Programmer's Library 1.3/Microsoft_Programmers_Library.7z/MPL/basic/bassam.txt

Text File | 2013-11-08 | 1.6 MB | 46,339 lines

 Microsoft BASIC (Professional Development System) Sample Code


 BALLPSET.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\BALLPSET.BAS

 DECLARE FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom)

 SCREEN 2

 ' Define a viewport and draw a border around it:
 VIEW (20, 10)-(620, 190),,1

 CONST PI = 3.141592653589#

 ' Redefine the coordinates of the viewport with view
 ' coordinates:
 WINDOW (-3.15, -.14)-(3.56, 1.01)

 ' Arrays in program are now dynamic:
 ' $DYNAMIC

 ' Calculate the view coordinates for the top and bottom of a
 ' rectangle large enough to hold the image that will be
 ' drawn with CIRCLE and PAINT:
 WLeft = -.21
 WRight = .21
 WTop = .07
 WBottom = -.07

 ' Call the GetArraySize function,
 ' passing it the rectangle's view coordinates:
 ArraySize% = GetArraySize(WLeft, WRight, WTop, WBottom)

 DIM Array (1 TO ArraySize%) AS INTEGER

 ' Draw and paint the circle:
 CIRCLE (0, 0), .18
 PAINT (0, 0)

 ' Store the rectangle in Array:
 GET (WLeft, WTop)-(WRight, WBottom), Array
 CLS
 ' Draw a box and fill it with a pattern:
 LINE (-3, .8)-(3.4, .2), , B
 Pattern$ = CHR$(126) + CHR$(0) + CHR$(126) + CHR$(126)
 PAINT (0, .5), Pattern$

 LOCATE 21, 29
 PRINT "Press any key to end."

 ' Initialize loop variables:
 StepSize = .02
 StartLoop = -PI
 Decay = 1

 DO
    EndLoop = -StartLoop
    FOR X = StartLoop TO EndLoop STEP StepSize

       ' Each time the ball "bounces" (hits the bottom of the
       ' viewport), the Decay variable gets smaller, making
       ' the height of the next bounce smaller:
       Y = ABS(COS(X)) * Decay - .14
       IF Y < -.13 THEN Decay = Decay * .9

       ' Stop if key pressed or Decay less than .01:
       Esc$ = INKEY$
       IF Esc$ <> "" OR Decay < .01 THEN EXIT FOR

       ' Put the image on the screen. The StepSize offset is
       ' smaller than the border around the circle. Thus,
       ' each time the image moves, it erases any traces
       ' left from the previous PUT (and also erases anything
       ' else on the screen):
       PUT (X, Y), Array, PSET
    NEXT X

    ' Reverse direction:
    StepSize = -StepSize
    StartLoop = -StartLoop
 LOOP UNTIL Esc$ <> "" OR Decay < .01

 END

 FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) STATIC

    ' Map the view coordinates passed to this function to
    ' their physical-coordinate equivalents:
    VLeft = PMAP(WLeft, 0)
    VRight = PMAP(WRight, 0)
    VTop = PMAP(WTop, 1)
    VBottom = PMAP(WBottom, 1)
 ' Calculate the height and width in pixels
    ' of the enclosing rectangle:
    RectHeight = ABS(VBottom - VTop) + 1
    RectWidth = ABS(VRight - VLeft) + 1

    ' Calculate size in bytes of array:
    ByteSize = 4 + RectHeight * INT((RectWidth + 7) / 8)

    ' Array is integer, so divide bytes by two:
    GetArraySize = ByteSize \ 2 + 1
 END FUNCTION



 BALLXOR.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\BALLXOR.BAS

 DECLARE FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom)

 SCREEN 2

 ' Define a viewport and draw a border around it:
 VIEW (20, 10)-(620, 190), , 1

 CONST PI = 3.141592653589#

 ' Redefine the coordinates of the viewport with view
 ' coordinates:
 WINDOW (-3.15, -.14)-(3.56, 1.01)

 ' Arrays in program are now dynamic:
 ' $DYNAMIC

 ' Calculate the view coordinates for the top and bottom of a
 ' rectangle large enough to hold the image that will be
 ' drawn with CIRCLE and PAINT:
 WLeft = -.18
 WRight = .18
 WTop = .05
 WBottom = -.05

 ' Call the GetArraySize function,
 ' passing it the rectangle's view coordinates:
 ArraySize% = GetArraySize(WLeft, WRight, WTop, WBottom)

 DIM Array(1 TO ArraySize%)  AS INTEGER

 ' Draw and paint the circle:
 CIRCLE (0, 0), .18
 PAINT (0, 0)

 ' Store the rectangle in Array:
 GET (WLeft, WTop)-(WRight, WBottom), Array
 CLS
 ' Draw a box and fill it with a pattern:
 LINE (-3, .8)-(3.4, .2), , B
 Pattern$ = CHR$(126) + CHR$(0) + CHR$(126) + CHR$(126)
 PAINT (0, .5), Pattern$

 LOCATE 21, 29
 PRINT "Press any key to end."

 ' Initialize loop variables:
 StepSize = .02
 StartLoop = -PI
 Decay = 1

 DO
    EndLoop = -StartLoop
    FOR X = StartLoop TO EndLoop STEP StepSize
       Y = ABS(COS(X)) * Decay - .14

       ' The first PUT statement places the image
       ' on the screen:
       PUT (X, Y), Array, XOR

       ' Use an empty FOR...NEXT loop to delay
       ' the program and reduce image flicker:
       FOR I = 1 TO 5: NEXT I

       IF Y < -.13 THEN Decay = Decay * .9
       Esc$ = INKEY$
       IF Esc$ <> "" OR Decay < .01 THEN EXIT FOR

       ' The second PUT statement erases the image and
       ' restores the background:
       PUT (X, Y), Array, XOR
    NEXT X

    StepSize = -StepSize
    StartLoop = -StartLoop
 LOOP UNTIL Esc$ <> "" OR Decay < .01

 END
 '  .
 '  .
 '  .

 FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) STATIC

    ' Map the view coordinates passed to this function to
    ' their physical-coordinate equivalents:
    VLeft = PMAP(WLeft, 0)
    VRight = PMAP(WRight, 0)
    VTop = PMAP(WTop, 1)
    VBottom = PMAP(WBottom, 1)
 ' Calculate the height and width in pixels
    ' of the enclosing rectangle:
    RectHeight = ABS(VBottom - VTop) + 1
    RectWidth = ABS(VRight - VLeft) + 1

    ' Calculate size in bytes of array:
    ByteSize = 4 + RectHeight * INT((RectWidth + 7) / 8)

    ' Array is integer, so divide bytes by two:
    GetArraySize = ByteSize \ 2 + 1
 END FUNCTION



 BAR.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\BAR.BAS

 ' Define type for the titles:
 TYPE TitleType
    MainTitle AS STRING * 40
    XTitle AS STRING * 40
    YTitle AS STRING * 18
 END TYPE

 DECLARE SUB InputTitles (T AS TitleType)
 DECLARE FUNCTION DrawGraph$ (T AS TitleType, Label$(), Value!(), N%)
 DECLARE FUNCTION InputData% (Label$(), Value!())

 ' Variable declarations for titles and bar data:
 DIM Titles AS TitleType, Label$(1 TO 5), Value(1 TO 5)

 CONST FALSE = 0, TRUE = NOT FALSE

 DO
    InputTitles Titles
    N% = InputData%(Label$(), Value())
    IF N% <> FALSE THEN
       NewGraph$ = DrawGraph$(Titles, Label$(), Value(), N%)
    END IF
 LOOP WHILE NewGraph$ = "Y"

 END

 ' ======================== DRAWGRAPH ======================
 '   Draws a bar graph from the data entered in the
 '   INPUTTITLES and INPUTDATA procedures.
 ' =========================================================

 FUNCTION DrawGraph$ (T AS TitleType, Label$(), Value(), N%) STATIC

    ' Set size of graph:
    CONST GRAPHTOP = 24, GRAPHBOTTOM = 171
    CONST GRAPHLEFT = 48, GRAPHRIGHT = 624
    CONST YLENGTH = GRAPHBOTTOM - GRAPHTOP

    ' Calculate maximum and minimum values:
    YMax = 0
    YMin = 0
    FOR I% = 1 TO N%
       IF Value(I%) < YMin THEN YMin = Value(I%)
       IF Value(I%) > YMax THEN YMax = Value(I%)
    NEXT I%

    ' Calculate width of bars and space between them:
    BarWidth = (GRAPHRIGHT - GRAPHLEFT) / N%
    BarSpace = .2 * BarWidth
    BarWidth = BarWidth - BarSpace

    SCREEN 2
    CLS

    ' Draw y-axis:
    LINE (GRAPHLEFT, GRAPHTOP)-(GRAPHLEFT, GRAPHBOTTOM), 1

    ' Draw main graph title:
    Start% = 44 - (LEN(RTRIM$(T.MainTitle)) / 2)
    LOCATE 2, Start%
    PRINT RTRIM$(T.MainTitle);

    ' Annotate y-axis:
    Start% = CINT(13 - LEN(RTRIM$(T.YTitle)) / 2)
    FOR I% = 1 TO LEN(RTRIM$(T.YTitle))
       LOCATE Start% + I% - 1, 1
       PRINT MID$(T.YTitle, I%, 1);
    NEXT I%

    ' Calculate scale factor so labels aren't bigger than four digits:
    IF ABS(YMax) > ABS(YMin) THEN
       Power = YMax
    ELSE
       Power = YMin
    END IF
    Power = CINT(LOG(ABS(Power) / 100) / LOG(10))
    IF Power < 0 THEN Power = 0

    ' Scale minimum and maximum values down:
    ScaleFactor = 10 ^ Power
    YMax = CINT(YMax / ScaleFactor)
    YMin = CINT(YMin / ScaleFactor)
    ' If power isn't zero then put scale factor on chart:
    IF Power <> 0 THEN
       LOCATE 3, 2
       PRINT "x 10^"; LTRIM$(STR$(Power))
    END IF

    ' Put tic mark and number for Max point on y-axis:
    LINE (GRAPHLEFT - 3, GRAPHTOP) -STEP(3, 0)
    LOCATE 4, 2
    PRINT USING "####"; YMax

    ' Put tic mark and number for Min point on y-axis:
    LINE (GRAPHLEFT - 3, GRAPHBOTTOM) -STEP(3, 0)
    LOCATE 22, 2
    PRINT USING "####"; YMin

    YMax = YMax * ScaleFactor ' Scale minimum and maximum back
    YMin = YMin * ScaleFactor ' up for charting calculations.

    ' Annotate x-axis:
    Start% = 44 - (LEN(RTRIM$(T.XTitle)) / 2)
    LOCATE 25, Start%
    PRINT RTRIM$(T.XTitle);

    ' Calculate the pixel range for the y-axis:
    YRange = YMax - YMin

    ' Define a diagonally striped pattern:
    Tile$ = CHR$(1)+CHR$(2)+CHR$(4)+CHR$(8)+CHR$(16)+CHR$(32)+CHR$(64)+CHR$(12

    ' Draw a zero line if appropriate:
    IF YMin < 0 THEN
       Bottom = GRAPHBOTTOM - ((-YMin) / YRange * YLENGTH)
       LOCATE INT((Bottom - 1) / 8) + 1, 5
       PRINT "0";
    ELSE
       Bottom = GRAPHBOTTOM
    END IF

    ' Draw x-axis:
    LINE (GRAPHLEFT - 3, Bottom)-(GRAPHRIGHT, Bottom)
    ' Draw bars and labels:
    Start% = GRAPHLEFT + (BarSpace / 2)
    FOR I% = 1 TO N%

       ' Draw a bar label:
       BarMid = Start% + (BarWidth / 2)
       CharMid = INT((BarMid - 1) / 8) + 1
       LOCATE 23, CharMid - INT(LEN(RTRIM$(Label$(I%))) / 2)
       PRINT Label$(I%);

       ' Draw the bar and fill it with the striped pattern:
       BarHeight = (Value(I%) / YRange) * YLENGTH
       LINE (Start%, Bottom) -STEP(BarWidth, -BarHeight), , B
       PAINT (BarMid, Bottom - (BarHeight / 2)), Tile$, 1

       Start% = Start% + BarWidth + BarSpace
    NEXT I%
    LOCATE 1, 1
    PRINT "New graph? ";
    DrawGraph$ = UCASE$(INPUT$(1))

 END FUNCTION
 ' ======================== INPUTDATA ======================
 '     Gets input for the bar labels and their values
 ' =========================================================

 FUNCTION InputData% (Label$(), Value()) STATIC

    ' Initialize the number of data values:
    NumData% = 0

    ' Print data-entry instructions:
    CLS
    PRINT "Enter data for up to 5 bars:"
    PRINT "   * Enter the label and value for each bar."
    PRINT "   * Values can be negative."
    PRINT "   * Enter a blank label to stop."
    PRINT
    PRINT "After viewing the graph, press any key ";
    PRINT "to end the program."

    ' Accept data until blank label or 5 entries:
    Done% = FALSE
    DO
       NumData% = NumData% + 1
       PRINT
       PRINT "Bar("; LTRIM$(STR$(NumData%)); "):"
       INPUT ; "        Label? ", Label$(NumData%)

       ' Only input value if label isn't blank:
       IF Label$(NumData%) <> "" THEN
          LOCATE , 35
          INPUT "Value? ", Value(NumData%)

       ' If label is blank, decrement data counter
       ' and set Done flag equal to TRUE:
       ELSE
          NumData% = NumData% - 1
          Done% = TRUE
       END IF
    LOOP UNTIL (NumData% = 5) OR Done%

    ' Return the number of data values input:
    InputData% = NumData%

 END FUNCTION
 ' ====================== INPUTTITLES ======================
 '     Accepts input for the three different graph titles
 ' =========================================================

 SUB InputTitles (T AS TitleType) STATIC
    SCREEN 0, 0                ' Set text screen.
    DO                        ' Input titles.
       CLS
       INPUT "Enter main graph title: ", T.MainTitle
       INPUT "Enter x-axis title    : ", T.XTitle
       INPUT "Enter y-axis title    : ", T.YTitle

       ' Check to see if titles are OK:
       LOCATE 7, 1
       PRINT "OK (Y to continue, N to change)? ";
       LOCATE , , 1
       OK$ = UCASE$(INPUT$(1))
    LOOP UNTIL OK$ = "Y"
 END SUB



 BIGSTRIN.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\BIGSTRIN.BAS

 'Define arrays which will be passed to each new level
 '       of recursion.
 DECLARE SUB BigStrings (n%, s1$(), s2$(), s3$(), s4$())
 DEFINT A-Z
 DIM s1$(1 TO 2), s2$(1 TO 2), s3$(1 TO 2), s4$(1 TO 2)
 ' Compute the # of 64K blocks available in far memory.
 n = FRE(-1) \ 65536
 CLS
 'Quit if not enough memory.
 IF n < 1 THEN
              PRINT "Not enough memory for operation."
              END
 END IF

 ' Start the recursion.
 CALL BigStrings(n, s1$(), s2$(), s3$(), s4$())

 SUB BigStrings (n, s1$(), s2$(), s3$(), s4$())
 ' Create a new array (up to 64K) for each level of recursion.
 DIM a$(1 TO 2)
 ' Have n keep track of recursion level.
 SELECT CASE n
 ' When at highest recusion level, process the strings.
         CASE 0
                 PRINT s1$(1); s1$(2); s2$(1); s2$(2); s3$(1); s3$(2); s4$(1);
         CASE 1
                 a$(1) = "Each "
                 a$(2) = "word "
                 s1$(1) = a$(1)
                 s1$(2) = a$(2)
         CASE 2
                 a$(1) = "pair "
                 a$(2) = "comes "
                 s2$(1) = a$(1)
                 s2$(2) = a$(2)
         CASE 3
                 a$(1) = "from "
                 a$(2) = "separate "
                 s3$(1) = a$(1)
                 s3$(2) = a$(2)
         CASE 4
                 a$(1) = "recursive "
                 a$(2) = "procedures."
                 s4$(1) = a$(1)
                 s4$(2) = a$(2)
 END SELECT

 ' Keep going until we're out of memory.
 IF n > 0 THEN
                 n = n - 1
 ' For each recursion, pass in previously created arrays.
                 CALL BigStrings(n, s1$(), s2$(), s3$(), s4$())
 END IF

 END SUB




 BOOKLOOK.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\BOOKLOOK.BAS

 '****************************** Main  Module *******************************
 '* This window contains the module-level code of BOOKLOOK.BAS, a program   *
 '* used to manage the database of a hypothethical library (BOOKS.MDB). The *
 '* program requires the following additional modules: BOOKMOD1.BAS,        *
 '* BOOKMOD2.BAS, and BOOKMOD3.BAS, all named in the file BOOKLOOK.MAK. The *
 '* include file BOOKLOOK.BI and the database file BOOKS.MDB must also be   *
 '* accessible. The program is discussed in Chapter 10, Database Programming*
 '* with ISAM in the BASIC 7.0 Programmer's Guide.                          *
 '*                                                                         *
 '* If you do NOT have expanded memory available, you should have invoked   *
 '* the PROISAM.EXE TSR as PROISAM /Ib:n, where n can be between 10-20.     *
 '* The /Ib: option specifies the number of buffers ISAM needs. Higher n    *
 '* values improve performance. Too few buffers, and the program will fail  *
 '* with an "Out of Memory" error. However if /Ib: is set too high, there   *
 '* may not be enough memory to load and run the program. If you do HAVE    *
 '* expanded memory, ISAM automatically uses up to 1.2 megabytes, even if   *
 '* you set Ib: to a low value. With a program the size of BOOKLOOK, use the*
 '* /Ie: option to reserve some expanded memory for QBX. This indirectly    *
 '* limits the amount of expanded memory ISAM uses, but make sure ISAM gets *
 '* enough EMS for at least 15 buffers (each buffer = 2K). As a last resort,*
 '* you can start QBX with the /NOF switch to make more memory available.   *
 '*                                                                         *
 '* BOOKLOOK manages 3 tables, BookStock, CardHolders, and BooksOut. The    *
 '* data in the BookStock and CardHolders tables is displayed as forms on   *
 '* screen. The user can switch between table displays by pressing "V" (for *
 '* View Other Table). Each table is defined as a separate structure. The   *
 '* structure for BookStock is Books, for CardHolders it is Borrowers, and  *
 '* for BooksOut it is BookStatus. Each of these is incorporated as an      *
 '* element of the structure RecStruct. RecStruct also has an element of    *
 '* INTEGER type called TableNum (to keep track of which table is being     *
 '* displayed), and a STRING element called WhichIndex that holds the name  *
 '* of the index by which the user chooses to order presentation of records.*
 '* Press F2 to see a list of procedures called by the program.             *
 '***************************************************************************

 DEFINT A-Z
 '$INCLUDE: 'BOOKLOOK.BI'
 SCREEN 0
 CLS                         ' TempRec is for editing and adding records
 DIM TempRec AS RecStruct    ' Used only to blank out a TempRec
 DIM EmptyRec AS RecStruct   ' See BOOKLOOK.BI for declaration of
 DIM BigRec AS RecStruct     ' this structure and its elements
 DIM Marker(25) AS INTEGER   ' Array to hold SAVEPOINT returns

 ' Open the database and the BookStock, CardHolders, and BooksOut tables

 ON ERROR GOTO MainHandler
 OPEN "BOOKS.MDB" FOR ISAM Books "BookStock" AS cBookStockTableNum
 OPEN "BOOKS.MDB" FOR ISAM Borrowers "CardHolders" AS cCardHoldersTableNum
 OPEN "BOOKS.MDB" FOR ISAM BookStatus "BooksOut" AS cBooksOutTableNum
 ON ERROR GOTO 0

 BigRec.TableNum = cBookStockTableNum   ' Decide which table to show first

    ' Since the database has multiple tables, this outer DO loop is used to
    ' reset the number associated with the table the user wants to
    ' to access, then draw the screen appropriate to that table, etc.
 DO
   EraseMessage                          ' Show the interface
   CALL DrawScreen(BigRec.TableNum)
   Checked = CheckIndex%(BigRec, TRUE)   ' Show current index
   CALL Retriever(BigRec, DimN, DimP, Answer) ' Retrieve and show a record
   CALL ShowMessage(" Press V to View other table", 0)
   CALL ShowStatus(" Total records in table: ", CDBL(LOF(BigRec.TableNum)))

   ' This loop lets the user traverse BigRec.TableNum and insert, delete,
   ' or modify records.
   DO                                           ' At start of each loop, show
                                                ' the user valid operations
     CALL Retriever(BigRec, DimN, DimP, Answer) ' and display current record

     STACK 4000                          ' Set large stack for recursions-it
                                         ' also resets FRE(-2) to stack 4000.

     Answer% = GetInput%(BigRec)         ' Find out what the user wants to do

     IF Answer < UNDO THEN               ' Excludes UNDOALL & INVALIDKEY too
       CALL EditCheck(PendingFlag, Answer, BigRec)
     END IF

     SELECT CASE Answer         ' Process valid user requests
       CASE QUIT
         CALL ShowMessage(" You chose Quit. So long! ", 0)
         END

                                ' If user picks "N" (Next Record), MOVENEXT.
                                ' CheckPosition handles end-of-file (i.e. the
       CASE GOAHEAD, ENDK       ' position just past the last record). If EOF
                                ' or BOF = TRUE, CheckPosition holds position
         MOVENEXT BigRec.TableNum
         CALL CheckPosition(BigRec, Answer, DimN, DimP)

                                ' Same logic as GOAHEAD, but reversed
       CASE GOBACK, HOME

         MOVEPREVIOUS BigRec.TableNum
         CALL CheckPosition(BigRec, Answer, DimN, DimP)

                                ' If user chooses "E", let him edit a field.
                                ' Assign the value returned by SAVEPOINT to
                                ' an array element, then update the table and
                                ' show the changed field. Trap any "duplicate
       CASE EDITRECORD          ' value for unique index" (error 86) and
                                ' handle it. The value returned by SAVEPOINT
                                ' allows rollbacks so the user can undo edits

         IF LOF(BigRec.TableNum) THEN
           IF EditField(Argument%, BigRec, Letter$, EDITRECORD, Answer%) THEN

               ' You save a sequence of savepoint identifiers in an array so
               ' you can let the user roll the state of the file back to a
               ' specific point. The returns from SAVEPOINT aren't guaranteed
               ' to be sequential.
             n = n + 1              ' Increment counter first so savepoint
             Marker(n) = SAVEPOINT  ' is synced with array-element subscript

             Alert$ = "Setting Savepoint number " + STR$(Marker(n))
             CALL ShowMessage(Alert$, 0)
             ON ERROR GOTO MainHandler
             SELECT CASE BigRec.TableNum   ' Update the table being displayed
               CASE cBookStockTableNum
                 UPDATE BigRec.TableNum, BigRec.Inventory
               CASE cCardHoldersTableNum
                 UPDATE BigRec.TableNum, BigRec.Lendee
             END SELECT
             ON ERROR GOTO 0
           ELSE
             COMMITTRANS               ' Use COMMITTRANS abort transaction if
             PendingFlag = FALSE       ' the user presses ESC
             n = 0                     ' Reset array counter
           END IF
         ELSE
           CALL ShowMessage("Sorry, no records in this table to edit", 0): SLE
         END IF
                           ' If choice is "A", get the values the user wants
                           ' in each of the fields (with AddOne). If there
                           ' is no ESCAPE from the edit, INSERT the record.
                           ' Trap "Duplicate value for unique index" errors
                           ' and handle them in MainHandler (error 86).
       CASE ADDRECORD
         added = AddOne(BigRec, EmptyRec, TempRec, Answer%)
         IF added THEN
           Alert$ = "A new record assumes proper place in current index"
           CALL ShowMessage(Alert$, 0)
           ON ERROR GOTO MainHandler
           SELECT CASE BigRec.TableNum     ' Insert into table being shown
             CASE cBookStockTableNum
               INSERT BigRec.TableNum, TempRec.Inventory
             CASE cCardHoldersTableNum
               INSERT BigRec.TableNum, TempRec.Lendee
           END SELECT
           ON ERROR GOTO 0
         END IF
         TempRec = EmptyRec

                               ' If choice is "D" --- prompt for confirmation.
                               ' If so, delete it and show new current record.
       CASE TOSSRECORD
         AnyRecords = LOF(BigRec.TableNum)
         IF BigRec.TableNum = cBookStockTableNum THEN CheckedOut = GetStatus(B
         IF BigRec.TableNum = cCardHoldersTableNum THEN
           SETINDEX cBooksOutTableNum, "CardNumIndexBO"
           SEEKEQ cBooksOutTableNum, BigRec.Lendee.CardNum
           IF NOT EOF(cBooksOutTableNum) THEN CheckedOut = TRUE
         END IF
         IF AnyRecords AND CheckedOut = FALSE THEN
           Alert$ = "Press D again to Delete this record, ESC to escape"
           CALL ShowMessage(Alert$, 0)
           DeleteIt% = GetInput%(BigRec)
           IF DeleteIt% = TOSSRECORD THEN   ' Delete currently-displayed recor
             DELETE BigRec.TableNum
             CALL ShowMessage("Record deleted...Press a key to continue", 0)
           ELSE
             CALL ShowMessage("Record not deleted. Press a key to continue", 0
             CALL ShowRecord(BigRec)
           END IF
           ' The following code checks whether the record deleted was the last
           ' record in the index, then makes the new last record current
           IF EOF(BigRec.TableNum) THEN
             MOVELAST BigRec.TableNum
           END IF
         ELSE
           IF BigRec.TableNum = cBookStockTableNum THEN
             IF AnyRecords = 0 THEN Alert$ = "Sorry, no records in this table
             IF CheckedOut THEN Alert$ = "Can't delete --- this book currently
           ELSEIF BigRec.TableNum = cCardHoldersTableNum THEN
             IF AnyRecords = 0 THEN Alert$ = "Sorry, no records in this table
             IF CheckedOut THEN Alert$ = "Can't delete --- this cardholder sti
           END IF
           CALL ShowMessage(Alert$, 0): SLEEP
         END IF
         CheckedOut = FALSE

                                ' If user chooses "R", walk the fields so he
                                ' can choose new index to order presentation
       CASE REORDER
         Letter$ = CHR$(TABKEY)
         GotOne = ChooseOrder(BigRec, EmptyRec, TempRec, Letter$, REORDER)

                                ' If a choice of indexes was made, retrieve
                                ' the index name, set an error trap, and try
                                ' to set the index, then display new index.
         IF GotOne THEN
           IndexName$ = LTRIM$(RTRIM$(TempRec.WhichIndex))
           ON ERROR GOTO MainHandler
           IF IndexName$ <> "NULL" THEN            ' This string is placed in
             SETINDEX BigRec.TableNum, IndexName$  ' TempRec.WhichIndex if
           ELSE                                    ' user chooses "Default."
             SETINDEX BigRec.TableNum, ""          ' "" is valid index name
           END IF                                  'representing NULL index
           ON ERROR GOTO 0                         '(i.e. the default order)
           CALL AdjustIndex(BigRec)
           LSET TempRec = EmptyRec
         END IF

                           ' If choice is "F", first set current index
       CASE SEEKFIELD      ' using same procedure as REORDER. Then do seek.

         Letter$ = CHR$(TABKEY)        ' Pass TABKEY for PlaceCursor
         GotOne = ChooseOrder(BigRec, EmptyRec, TempRec, Letter$, SEEKFIELD)

         IF GotOne AND TEXTCOMP(TempRec.WhichIndex, "NULL") THEN
           CALL SeekRecord(BigRec, TempRec, Letter$)
           FirstLetter$ = ""
           DimN = EOF(BigRec.TableNum): DimP = BOF(BigRec.TableNum)
         END IF

                           ' STATUS gets the due date of a book & displays it
       CASE STATUS
         IF BigRec.TableNum = cBookStockTableNum THEN
           CALL ShowStatus("", 0#)                  ' Explicitly type the 0
           GotIt = GetStatus(BigRec, DateToShow#)   ' to avoid type mismatch
           IF GotIt THEN
             Alert$ = "Press B for information on Borrower of this book"
             CALL ShowMessage(Alert$, 0)
             CALL ShowStatus("Due Date: ", DateToShow#)
           END IF
         END IF

                          ' LendeeProfile displays borrower of displayed book
       CASE BORROWER
         CALL LendeeProfile(BigRec)

                          ' BooksBorrowed shows books borrowed by CardHolder
       CASE WHICHBOOKS
         IF Borrowed THEN CALL BooksBorrowed(BigRec)

                          ' If user hits "V" cycle through displayable tables
       CASE OTHERTABLE
         IF BigRec.TableNum < cDisplayedTables THEN
           BigRec.TableNum = BigRec.TableNum + 1
         ELSE
           BigRec.TableNum = 1
         END IF
         EXIT DO
                          ' If user picks "I" to check current book back in,
                          ' make sure it is out, then check it back in
       CASE CHECKIN
         IF Borrowed THEN
           GotIt = GetStatus(BigRec, DateToShow#)
           IF DateToShow# THEN
             CALL ReturnBook(BigRec, DateToShow#)
           END IF
         END IF
                          ' If user picks "O" to check current book out,
                          ' make sure it is available, then check it out
       CASE CHECKOUT
         GotIt = GetStatus(BigRec, DateToShow#)
           IF DateToShow# = 0# THEN
              CALL BorrowBook(BigRec)
           ELSE
              CALL ShowMessage("Sorry, this book is already checked out...", 0
           END IF

                         ' If user wants to Undo all or some of a series of
                         ' uncommitted edits, make sure there is a pending
                         ' transaction to undo, then restore the state of the
                         ' file one step at a time, or altogether, depending
                         ' on whether U or ^U was entered.
       CASE UNDO, UNDOALL
         IF PendingFlag = TRUE THEN
           IF n < 1 THEN
             CALL ShowMessage("No pending edits left to Undo...", 0)
           ELSE
             IF Answer = UNDO THEN
               Alert$ = "Restoring back to Savepoint # " + STR$(Marker(n))
               CALL ShowMessage(Alert$, 0)
               ROLLBACK Marker(n)
               n = n - 1
             ELSE                    ' If it's not UNDO, it must be UNDOALL
               CALL ShowMessage("Undoing the whole last series of edits", 0)
               ROLLBACK ALL
               n = 0
             END IF
          END IF
        ELSE
          CALL ShowMessage("There are no pending edits left to Undo...", 0)
        END IF

       CASE INVALIDKEY              ' Alert user if wrong key is pressed
         CALL ShowMessage(KEYSMESSAGE, 0)
         IF PendingFlag = TRUE THEN CALL DrawIndexBox(BigRec.TableNum, EDITREC
     END SELECT
     CALL DrawHelpKeys(BigRec.TableNum)
     CALL ShowKeys(BigRec, BRIGHT + FOREGROUND, DimN, DimP)
   LOOP
 LOOP
 CLOSE
 END

 ' This error handler takes care of the most common ISAM errors

 MainHandler:

 IF ERR = 73 THEN        ' 73 = Feature unavailable
   CALL ShowMessage("You forgot to load the ISAM TSR program", 0)
   END
 ELSEIF ERR = 88 THEN        ' 88 = Database inconsistent
   ' If you have text files corresponding to each of the tables, then
   ' MakeOver prompts for their names and creates an ISAM file from them.
   CALL MakeOver(BigRec)
   RESUME NEXT

 ELSEIF ERR = 83 THEN        ' 83 = Index not found
     CALL DrawScreen(BigRec.TableNum)
     CALL ShowMessage("Unable to set the index. Need more buffers?", 0)
     RESUME NEXT
 ELSEIF ERR = 86 THEN        ' 86 = Duplicate value for unique index
     ' Trap errors when a user tries to enter a value for the Card Number or
     ' ID fields that duplicates a value already in the table
     CALL DupeFixer(BigRec)
     RESUME
 ELSE
   Alert$ = "Sorry, not able to handle this error in BOOKLOOK: " + STR$(ERR)
   CALL ShowMessage(Alert$, 0)
   END
 END IF

 '***************************************************************************
 '*  The AddOne FUNCTION is called once for each field when the user wants  *
 '*  to add a record to the displayed table.                                *
 '*                                Parameters                               *
 '*  BigRec    RecStruct variable containing information on all tables      *
 '*  EmptyRec  Empty record of same type as BigRec                          *
 '*  TempRec   Temporary record record of same type as BigRec               *
 '*  Answer    Integer passed through to EditField; tells task to perform   *
 '***************************************************************************
 FUNCTION AddOne (BigRec AS RecStruct, EmptyRec AS RecStruct, TempRec AS RecSt
   CALL ClearEm(BigRec.TableNum, 1, 1, 1, 1, 1, 1)
   LSET TempRec = EmptyRec
   CALL ShowMessage("Enter the first field of the new record", 0)
   TempRec.TableNum = BigRec.TableNum
   Edited = EditField(Argument%, TempRec, FirstLetter$, ADDRECORD, Answer%)
   IF Edited THEN
     AddOne = -1
   ELSE
     AddOne = 0
   END IF
   COLOR FOREGROUND, BACKGROUND
 END FUNCTION

 '***************************************************************************
 '* The CheckPosition SUB checks the table position after the requested user*
 '* action is completed. If EOF follows a MOVENEXT or the user has chosen   *
 '* MOVELAST, the Keys for Database Viewing/Editing box is updated to say   *
 '* "No Next Record." If BOF  follows a MOVEPREVIOUS or user has chosen a   *
 '* MOVEFIRST, "No Previous Record" is displayed.                           *
 '* In either case, the position is held by executing MOVELAST or MOVEFIRST.*
 '*                            Parameters:                                  *
 '*   Big Rec      User-defined type containing all table information       *
 '*   Answer       Tells what operation retrieve results from               *
 '*   DimN & DimP  Flags telling which menu items should be dimmed/changed  *
 '***************************************************************************
 SUB CheckPosition (BigRec AS RecStruct, Answer, DimN%, DimP%)
   SELECT CASE Answer
     CASE GOAHEAD, ENDK
       IF EOF(BigRec.TableNum) OR (Answer = ENDK) THEN
         CALL ShowMessage("This is the last record in this index", 0)
         DimN = TRUE: DimP = FALSE
         MOVELAST BigRec.TableNum
       ELSE                    ' If not EOF, turn on N
         DimN = FALSE: DimP = FALSE
         CALL EraseMessage
       END IF
     CASE GOBACK, HOME
       IF BOF(BigRec.TableNum) OR (Answer = HOME) THEN
         CALL ShowMessage("This is the first record in this index", 0)
         DimP = TRUE: DimN = FALSE
         MOVEFIRST BigRec.TableNum
       ELSE
         DimP = FALSE: DimN = FALSE
         CALL EraseMessage
       END IF
   END SELECT
 END SUB

 '***************************************************************************
 '* The ChooseOrder FUNCTION calls PlaceCursor so the user can move around  *
 '* the form to pick the index to set.                                      *
 '*                                  Parameters                             *
 '*  BigRec       BigRec has all the table information in updated form      *
 '*  EmptyRec     EmptyRec is same template as BigRec, but fields are empty *
 '*  TempRec      Holds intermediate and temporary data                     *
 '*  FirstLetter  Catches letter if user starts typing during SEEKFIELD     *
 '*  Task         Either REORDER or SEEKFIELD - passed on to PlaceCursor    *
 '***************************************************************************
 FUNCTION ChooseOrder (BigRec AS RecStruct, EmptyRec AS RecStruct, TempRec AS
   CALL DrawTable(BigRec.TableNum)
   CALL DrawIndexBox(BigRec.TableNum, Task)
   Argument = TITLEFIELD                    ' Always start with first field
   TempRec = EmptyRec: TempRec.TableNum = BigRec.TableNum

   ' Pass temporary RecStruct variable so user can't trash BigRec
   value = PlaceCursor(Argument, TempRec, FirstLetter$, 1, Task)

   ' If the user chooses ESC, redraw everything, then exit to module level
   IF ASC(TempRec.WhichIndex) = 0 THEN
     CALL DrawIndexBox(BigRec.TableNum, Task)
     CALL ShowRecord(BigRec)
     CALL ShowMessage(KEYSMESSAGE, 0)
     ChooseOrder = 0
     EXIT FUNCTION
   ELSE                                ' Otherwise, if user makes a choice
     ChooseOrder = -1                  ' of Indexes, signal success to the
   END IF                              ' module-level code
 END FUNCTION

 '***************************************************************************
 '*                                                                         *
 '*  The DupeFixer SUB is called when the tries to enter a duplicate value  *
 '*  for the BookStock table's IDnum column or the the CardHolders table's  *
 '*  CardNum column, because their indexes are Unique. The procedure prompts*
 '*  the user to enter a new value.                                         *
 '***************************************************************************
 SUB DupeFixer (BigRec AS RecStruct)
     IF BigRec.TableNum = cBookStockTableNum THEN
       DO
         Alert$ = STR$(BigRec.Inventory.IDnum) + " is not unique. "
         CALL ShowMessage(Alert$, 1)
         COLOR YELLOW + BRIGHT, BACKGROUND
         INPUT "Try another number: ", TempString$
         BigRec.Inventory.IDnum = VAL(TempString$)
       LOOP UNTIL BigRec.Inventory.IDnum
     ELSEIF BigRec.TableNum = cCardHoldersTableNum THEN
       DO
         Alert$ = STR$(BigRec.Lendee.CardNum) + " is not unique. "
         CALL ShowMessage(Alert$, 1)
         COLOR YELLOW + BRIGHT, BACKGROUND
         INPUT "Try another number: ", TempString$
         BigRec.Lendee.CardNum = VAL(TempString$)
       LOOP UNTIL BigRec.Lendee.CardNum
     END IF
     COLOR FOREGROUND, BACKGROUND
 END SUB

 '********************************* EditCheck SUB ***************************
 '*                                                                         *
 '* The EditCheck procedure monitors what the user wants to do, and if the  *
 '* choice is EDITRECORD, makes sure that a transaction is begun, or if it  *
 '* already has begun, continues it. If a transaction has been pending, and *
 '* the user chooses anything except EDITRECORD, then the transaction is    *
 '* committed.                                                              *
 '*                                                                         *
 '*                            Parameters:                                  *
 '*   Pending      A flag that indicates whether transaction is pending     *
 '*   Task         Tells what operation the user wants to perform now       *
 '*   TablesRec    Structure containing information about the tables        *
 '*                                                                         *
 '***************************************************************************
 SUB EditCheck (Pending, Task, TablesRec AS RecStruct)
   ' First, decide if this is a new or pending transaction, or not one at all
   ' The only transaction in this program keeps edits to the current record
   ' pending until the user moves on to a new record or a new operation
   ' (for example a Reorder).
 SHARED n                          ' n is index to array of savepoint ids

       IF Task = EDITRECORD THEN
         IF Pending = FALSE THEN
           BEGINTRANS
           Pending = TRUE
         END IF
       ELSEIF Pending = TRUE THEN  ' Equivalent to Task<>EDITRECORD AND
         COMMITTRANS               ' Pending=TRUE
         Pending = FALSE
         n = 0                     ' Reset array index for savepoint ids
         CALL DrawIndexBox(TablesRec.TableNum, 0)
       END IF
 END SUB

 '***************************************************************************
 '*  The GetInput FUNCTION takes the keystroke input by the user and returns*
 '*  a constant indicating what the user wants to do. If the keystroke rep- *
 '*  resents a valid operation, the choice is echoed to the screen.         *
 '***************************************************************************
 FUNCTION GetInput% (BigRec AS RecStruct)
 DO
   Answer$ = INKEY$
 LOOP WHILE Answer$ = EMPTYSTRING
   IF LEN(Answer$) > 1 THEN
     RightSide = HighKeys%(Answer$)
     GetInput = RightSide
   ELSE
     SELECT CASE Answer$
       CASE "A", "a"
         CALL UserChoice(BigRec, ALINE, 7, "Add Record")
         GetInput% = ADDRECORD
       CASE "B", "b"
         IF BigRec.TableNum = cBookStockTableNum THEN
           CALL UserChoice(BigRec, WLINE, 28, "Borrower")
           GetInput% = BORROWER
         ELSE
           CALL UserChoice(BigRec, WLINE, 13, "Books Outstanding")
           GetInput% = WHICHBOOKS
         END IF
       CASE "O", "o"
         CALL UserChoice(BigRec, CLINE, 7, "Check Book Out")
         GetInput% = CHECKOUT
       CASE "I", "i"
         CALL UserChoice(BigRec, CLINE, 28, "Check In")
         GetInput% = CHECKIN
       CASE "D", "d"
         CALL UserChoice(BigRec, ALINE, 28, "Drop Record")
         GetInput% = TOSSRECORD
       CASE "N", "n"
         GetInput% = GOAHEAD
       CASE "P", "p"
         GetInput% = GOBACK
       CASE "Q", "q"
         CALL UserChoice(BigRec, ELINE, 28, "Quit")
         GetInput% = QUIT
       CASE "E", "e"
         CALL UserChoice(BigRec, ELINE, 7, "Edit Record")
         GetInput% = EDITRECORD
       CASE "F", "f"
         CALL UserChoice(BigRec, RLINE, 28, "Find Record")
         GetInput% = SEEKFIELD
       CASE "R", "r"
         CALL UserChoice(BigRec, RLINE, 7, "Reorder Records")
         GetInput% = REORDER
       CASE "V", "v"
         GetInput% = OTHERTABLE
       CASE "W", "w"
         CALL UserChoice(BigRec, WLINE, 7, "When Due Back")
         GetInput% = STATUS
       CASE CHR$(ESCAPE)
         GetInput% = ESCAPE
       CASE "U", "u"
         GetInput = UNDO       ' U signals rollback request after editing
       CASE CHR$(CTRLU)        ' ^U = rollback a whole series of edits
         GetInput = UNDOALL
       CASE ELSE
         GetInput% = INVALIDKEY
         BEEP
     END SELECT
   END IF
 END FUNCTION

 '**************************************************************************
 '*  The HighKeys FUNCTION handles common two-byte keys input by the user. *
 '*  The Answer parameter is the keystroke entered by the user.            *
 '**************************************************************************
 FUNCTION HighKeys (Answer AS STRING)
   SELECT CASE ASC(RIGHT$(Answer$, 1))     ' Look at code for right byte
     CASE UP
       HighKeys = GOBACK                   ' UP is the up-arrow key
     CASE DOWN
       HighKeys = GOAHEAD                  ' DOWN is the down-arrow key
     CASE HOME
       HighKeys = HOME                     ' etc.
     CASE ENDK
       HighKeys = ENDK
       CASE LEFT
       HighKeys = OTHERTABLE
     CASE RIGHT
       HighKeys = OTHERTABLE
     CASE PGUP
       CALL ShowMessage("You could program so PGUP moves back n records", 0):
       HighKeys = INVALIDKEY
     CASE PGDN
       CALL ShowMessage("You could program so PGDN moves forward n records", 0
       HighKeys = INVALIDKEY
     CASE ELSE
       CALL ShowMessage("Sorry, that key isn't handled yet.", 0): SLEEP
       HighKeys = INVALIDKEY
   END SELECT
 END FUNCTION

 '****************************** Retriever SUB ******************************
 '* The Retriever SUB retrieves records from the database file and puts     *
 '* them into the appropriate recordvariable for the table being displayed. *
 '* An error trap is set in case the retrieve fails, in which case a message*
 '* is displayed. Note that if a preceding SEEKoperand fails, EOF is TRUE.  *
 '* In that case, position is set to the last record, which is retrieved.   *
 '*                            Parameters:                                  *
 '*   Big Rec      User-defined type containing all table information       *
 '*   DimN & DimP  Flags telling which menu items should be dimmed/changed  *
 '*   Task         Tells what operation retrieve results from               *
 '***************************************************************************
 SUB Retriever (BigRec AS RecStruct, DimN, DimP, Task)
   STATIC PeekFlag         ' Set this if user is just peeking at other table
   LOCATE , , 0            ' Turn off the cursor
   ' Show the user which choice was made, and whether EOF or BOF
   CALL ShowKeys(BigRec, FOREGROUND + BRIGHT, DimN, DimP)
   ' If table is empty, don't try to retrieve anything
   IF LOF(BigRec.TableNum) = 0 THEN
     DrawTable (BigRec.TableNum)
     CALL ShowMessage("There are no records in this table", 0): EXIT SUB
   END IF

   IF Task <> ENDK AND Task <> HOME THEN
     IF Task < EDITRECORD THEN                         ' Edit needs its
       CALL Indexbox(BigRec, CheckIndex%(BigRec, 0))   ' own prompts. Show
     ELSEIF Task > INVALIDKEY THEN                     ' indexbox otherwise
       IF Task <> ESC THEN CALL DrawIndexBox(BigRec.TableNum, 0)
       CALL Indexbox(BigRec, CheckIndex%(BigRec, 0))
     END IF
   END IF
   IF BOF(BigRec.TableNum) THEN MOVEFIRST (BigRec.TableNum)
   ON LOCAL ERROR GOTO LocalHandler           ' Trap errors on the retrieve.
   IF NOT EOF(BigRec.TableNum) THEN           ' Retrieve current record
     SELECT CASE BigRec.TableNum              ' from table being displayed
       CASE cBookStockTableNum                ' if EOF is not true
         RETRIEVE BigRec.TableNum, BigRec.Inventory
       CASE cCardHoldersTableNum
         RETRIEVE BigRec.TableNum, BigRec.Lendee
     END SELECT
   ELSE                                       ' If EOF is true, set position
     MOVELAST BigRec.TableNum                 ' to the last record in table,
     SELECT CASE BigRec.TableNum              ' then retrieve the record
       CASE cBookStockTableNum
         RETRIEVE BigRec.TableNum, BigRec.Inventory
       CASE cCardHoldersTableNum
         RETRIEVE BigRec.TableNum, BigRec.Lendee
     END SELECT
     DimN = TRUE
   END IF
   ON LOCAL ERROR GOTO 0                             ' Turn off error trap
   CALL ClearEm(BigRec.TableNum, 1, 1, 1, 1, 1, 1)
   CALL ShowRecord(BigRec)
   IF Task = OTHERTABLE THEN   ' If user is just peeking at the other table
     IF PeekFlag = 0 THEN      ' remind him how to get back to first table
       CALL ShowMessage("Press V to return to the other table", 0)
       PeekFlag = 1
     END IF
   ELSE
     PeekFlag = 0
   END IF
 EXIT SUB

 LocalHandler:
   IF ERR = 85 THEN
     CALL ShowMessage("Unable to retrieve your record...", 0)
   END IF
   RESUME NEXT
 END SUB

 '********************************* SeekRecord SUB *************************
 '*  SeekRecord takes the name of the user's chosen index, sets it as the  *
 '*  current index, then prompts the user to enter the value to seek. A    *
 '*  minimal editor, MakeString, gets user input. If the SEEK is on a com- *
 '*  bined index, GetKeyVals is called to get the input. Input is checked  *
 '*  for minimal acceptability by ValuesOK. If it is OK, GetOperand is     *
 '*  called to let the user specify how to conduct the SEEK.               *
 '*                              Parameters:                               *
 '*      TablesRec  Contains current record information for all tables     *
 '*      TempRec    Contains the name of the index on which to seek (in    *
 '*                 TempRec.WhichIndex element)                            *
 '*      Letter$    If the user starts typing instead of pressing ENTER    *
 '*                 Letter$ catches the keystroke, passes it to MakeString *
 '**************************************************************************
 SUB SeekRecord (TablesRec AS RecStruct, TempRec AS RecStruct, Letter$)
   DIM EmptyRec AS RecStruct             ' Make an empty record.
   IF LEFT$(Letter$, 1) < " " THEN       ' Exit if value is not a valid
                                         ' character, then redraw
     CALL DrawIndexBox(TablesRec.TableNum, SEEKFIELD)
     CALL Indexbox(TablesRec, CheckIndex%(TablesRec, TRUE))
     CALL ShowMessage("You must enter a valid string or numeric value", 0)
     EXIT SUB
   END IF
   TheTable = TablesRec.TableNum
   IndexName$ = RTRIM$(TempRec.WhichIndex)
   IF GETINDEX$(TheTable) <> IndexName$ THEN  ' If index to seek on is not
     ON LOCAL ERROR GOTO SeekHandler          ' current, set it now. Trap
     SETINDEX TheTable, IndexName$            ' possible failure of SETINDEX
     ON LOCAL ERROR GOTO 0                    ' then turn off error trap.
   END IF
   CALL AdjustIndex(TablesRec)                ' Show the current index
   TablesRec.WhichIndex = TempRec.WhichIndex
   TempRec = EmptyRec                         ' Clear TempRec for data
   TempRec.TableNum = TablesRec.TableNum
   ' Get the value to SEEK for from the user. The data type you assign the
   ' input to must be the same as the data in the database, so get it as a
   ' string with MakeString, then convert it to proper type for index. If
   ' the index is the combined index BigIndex, use GetKeyVals for input...

  SELECT CASE RTRIM$(LTRIM$(IndexName$))
    CASE "TitleIndexBS", "AuthorIndexBS", "PubIndexBS", "NameIndexCH", "StateI
     Prompt$ = "Value To Seek: "
     Key1$ = MakeString$(ASC(Letter$), Prompt$): IF Key1$ = "" THEN EXIT SUB
    CASE "IDIndex", "CardNumIndexCH", "ZipIndexCH"
     ValueToSeek$ = MakeString$(ASC(Letter$), Prompt$)
     IF ValueToSeek$ = "" THEN EXIT SUB
     IF IndexName$ = "IDIndex" THEN
       NumberToSeek# = VAL(ValueToSeek$)
       Key1$ = ValueToSeek$
     ELSE
       NumberToSeek& = VAL(ValueToSeek$)
       Key1$ = ValueToSeek$
     END IF
    CASE "BigIndex"
     CALL GetKeyVals(TempRec, Key1$, Key2$, Key3#, Letter$)
     ValueToSeek$ = STR$(Key3#)
    CASE ""
      Alert$ = "Sorry, can't search for field values on the default index"
      CALL ShowMessage(Alert$, 0)
    CASE ELSE
   END SELECT

   ' Make sure the input values are minimally acceptable

   IF NOT ValuesOK(TablesRec, Key1$, Key2$, ValueToSeek$) THEN
     CALL ShowMessage("Sorry, problem with your entry. Try again!", 0)
     EXIT SUB
   END IF

   ' Show the user the values he entered in their appropriate fields
   CALL ClearEm(TablesRec.TableNum, 1, 1, 1, 1, 1, 1)
   CALL ShowIt(TempRec, IndexName$, TheTable, Key1$)

   ' GetOperand lets user specify the way the SEEK is to be conducted ---
   ' either  =, >, >=, <, or <= the value that was entered above

   DidIt = GetOperand%(Operand$)

   ' The actual SEEK has to be done according to two factors, the Index on
   ' which it is conducted, and the condition chosen in GetOperand. In the
   ' next section, case on the Operand returned, then IF and ELSEIF on the
   ' basis of the index on which the search is being conducted

   IF Operand$ <> "<>" THEN                ' "<>" represents user ESC choice

    SELECT CASE Operand$
     CASE "", "="                        ' If operand ="" or "=", use =
       IF IndexName$ = "BigIndex" THEN
         IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$) ' a name
         SEEKEQ TheTable, Key1$, Key2$, Key3#
       ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN
         IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$) ' a name
         SEEKEQ TheTable, LTRIM$(RTRIM$(Key1$))
       ELSEIF IndexName$ = "IDIndex" THEN
         SEEKEQ TheTable, NumberToSeek#
       ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN
         SEEKEQ TheTable, NumberToSeek&
       ELSE
         SEEKEQ TheTable, Key1$
       END IF
     CASE ">="                      ' at least gets them close
       IF IndexName$ = "BigIndex" THEN
         IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$) ' a name
         SEEKGE TheTable, Key1$, Key2$, Key3#
       ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN
         IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$)
         SEEKGE TheTable, Key1$
       ELSEIF IndexName$ = "IDIndex" THEN
         SEEKGE TheTable, NumberToSeek#
       ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN
         SEEKGE TheTable, NumberToSeek&
       ELSE
         SEEKGE TheTable, Key1$
       END IF
     CASE ">"
       IF IndexName$ = "BigIndex" THEN
         IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$)
         SEEKGT TheTable, Key1$, Key2$, Key3#
       ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN
         IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$)
         SEEKGT TheTable, Key1$
       ELSEIF IndexName$ = "IDIndex" THEN
         SEEKGT TheTable, NumberToSeek#
       ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN
         SEEKGT TheTable, NumberToSeek&
       ELSE
         SEEKGT TheTable, Key1$
       END IF
     CASE "<="
       IF IndexName$ = "BigIndex" THEN
         IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$)
         SEEKGT TheTable, Key1$, Key2$, Key3#
         MOVEPREVIOUS TheTable
       ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN
         IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$)
         SEEKGT TheTable, Key1$
         MOVEPREVIOUS TheTable
       ELSEIF IndexName$ = "IDIndex" THEN
         SEEKGT TheTable, NumberToSeek#
         MOVEPREVIOUS TheTable
       ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN
         SEEKGT TheTable, NumberToSeek&
         MOVEPREVIOUS TheTable
       ELSE
         SEEKGT TheTable, Key1$
         MOVEPREVIOUS TheTable
       END IF
     CASE "<"
       IF IndexName$ = "BigIndex" THEN
         IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$)
         SEEKGE TheTable, Key1$, Key2$, Key3#
         MOVEPREVIOUS TheTable
       ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN
         IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$)
         SEEKGE TheTable, Key1$
         MOVEPREVIOUS TheTable
       ELSEIF IndexName$ = "IDIndex" THEN
         SEEKGE TheTable, NumberToSeek#
         MOVEPREVIOUS TheTable
       ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN
         SEEKGE TheTable, NumberToSeek&
         MOVEPREVIOUS TheTable
       ELSE
         SEEKGE TheTable, Key1$
         MOVEPREVIOUS TheTable
       END IF
     CASE ELSE
       Alert$ = "The returned operand was " + Operand$
       CALL ShowMessage(Alert$, 0)
       SLEEP
   END SELECT
  ELSE                        ' If they choose ESC, go back to module level
    CALL DrawScreen(TheTable)
    CALL ShowRecord(TablesRec)
    Alert$ = "You've escaped. " + KEYSMESSAGE
    CALL ShowMessage(Alert$, 0)
    SLEEP
    Operand$ = ""
  END IF
   CALL EraseMessage
   CALL DrawScreen(TheTable)
   CALL Indexbox(TablesRec, CheckIndex%(TablesRec, FALSE))
  IF EOF(TablesRec.TableNum) THEN
   Alert$ = "Sorry,  unable to match value you entered with any field value"
   CALL ShowMessage(Alert$, 0):  ' SLEEP: EraseMessage
  END IF

 EXIT SUB

 SeekHandler:
  IF ERR = 83 THEN                          ' 83 = Index not found
     CALL DrawScreen(TablesRec.TableNum)
     Alert$ = "SETINDEX for " + IndexName$ + " failed. Need more buffers?"
     CALL ShowMessage(Alert$, 0)
     EXIT SUB
  END IF

 END SUB   ' End of SeekRecord procedure



 BOOKMOD1.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\BOOKMOD1.BAS

 '***********************************************************************
 '*      This is module level code for BOOKMOD2.BAS, and contains screen*
 '*      drawing and user interface maintenance routines. This module   *
 '*      doesn't contain ISAM statements.                               *
 '***********************************************************************

 DEFINT A-Z
 '$INCLUDE: 'booklook.bi'
 KeysBox:
   DATA "╔══════════════════════════════════════╗"
   DATA "║                                      ║"
   DATA "║                                      ║"
   DATA "║                                      ║"
   DATA "║                                      ║"
   DATA "║                                      ║"
   DATA "║                                      ║"
   DATA "║                                      ║"
   DATA "╚═╡ Keys for Database Viewing/Editing ╞╝"

 HelpKeys1:
   DATA ""
   DATA "N = Next Record      P = Previous   "
   DATA "R = Reorder Records  F = Find Record"
   DATA "W = When Due Back    B = Borrower   "
   DATA "      V = View Other Table          "
   DATA "A = Add Record       D = Drop Record"
   DATA "E = Edit Record      Q = Quit       "
   DATA "O = Check Book Out   I = Check In   "
   DATA ""

 HelpKeys2:
   DATA ""
   DATA "N = Next Record      P = Previous   "
   DATA "R = Reorder Records  F = Find Record"
   DATA "      B = Books Outstanding         "
   DATA "      V = View Other Table          "
   DATA "A = Add Record       D = Drop Record"
   DATA "E = Edit Record      Q = Quit       "
   DATA "                                    "
   DATA ""

 Indexbox1:
   DATA "╔═══════════════════════════╗"
   DATA "║ By Titles                 ║"
   DATA "║ By Authors                ║"
   DATA "║ By Publishers             ║"
   DATA "║ By ID numbers             ║"
   DATA "║ By Title + Author + ID    ║"
   DATA "║ Default = Insertion order ║"
   DATA "║                           ║"
   DATA "╚═╡ Current Sorting Order ╞═╝"
 Indexbox2:
   DATA "╔═══════════════════════════╗"
   DATA "║ By Name                   ║"
   DATA "║ By State                  ║"
   DATA "║ By Zip code               ║"
   DATA "║ By Card number            ║"
   DATA "║                           ║"
   DATA "║ Default = Insertion order ║"
   DATA "║                           ║"
   DATA "╚═╡ Current Sorting Order ╞═╝"


 BooksTable:
 DATA "╔════════════════════════════════════════════════════════════════════╗"
 DATA "║                                                                    ║"
 DATA "║    Title:                                                          ║"
 DATA "║                                                                    ║"
 DATA "║    Author:                                                         ║"
 DATA "║                                                                    ║"
 DATA "║    Publisher:                                                      ║"
 DATA "║                                                                    ║"
 DATA "║    Edition:                                                        ║"
 DATA "║                                                                    ║"
 DATA "║    Price:                                                          ║"
 DATA "║                                                                    ║"
 DATA "║    ID number:                                                      ║"
 DATA "╚════════════════════════════════════════════════════════════════════╝"


 LendeesTable:
 DATA "╔════════════════════════════════════════════════════════════════════╗"
 DATA "║                                                                    ║"
 DATA "║   Name:                                                            ║"
 DATA "║                                                                    ║"
 DATA "║   Street:                                                          ║"
 DATA "║                                                                    ║"
 DATA "║   City:                                                            ║"
 DATA "║                                                                    ║"
 DATA "║   State:                                                           ║"
 DATA "║                                                                    ║"
 DATA "║   Zipcode:                                                         ║"
 DATA "║                                                                    ║"
 DATA "║   Card number:                                                     ║"
 DATA "╚════════════════════════════════════════════════════════════════════╝"

 OperandBox:
 DATA "╔═══════════════════════════╗"
 DATA "║                           ║"
 DATA "║ Greater Than              ║"
 DATA "║ or                        ║"
 DATA "║ Equal To     Value Entered║"
 DATA "║ or                        ║"
 DATA "║ Less Than                 ║"
 DATA "║                           ║"
 DATA "╚══╡ Relationship to Key ╞══╝"

 EditMessage:
 DATA "╔═══════════════════════════╗"
 DATA "║ A log is being kept while ║"
 DATA "║ you edit fields in this   ║"
 DATA "║ record. Press U to undo   ║"
 DATA "║ each preceding edit, or   ║"
 DATA "║ CTRL+U to undo all of the ║"
 DATA "║ pending edits as a group. ║"
 DATA "║                           ║"
 DATA "╚═════╡ To Undo Edits ╞═════╝"

 '***************************************************************************
 '*  The ClearEm SUB erases the parts of the screen where table record col- *
 '*  umn information is displayed, depending on which fields are specified. *
 '*                                Parameters                               *
 '*  TableNum    Integer specifying the table being displayed               *
 '*  Field?      Boolean values specifying which fields to erase            *
 '***************************************************************************
 SUB ClearEm (TableNum%, Field1%, Field2%, Field3%, Field4%, Field5%, Field6%)

   DIM ToClear(10) AS INTEGER

   ToClear(0) = Field1: ToClear(1) = Field2: ToClear(2) = Field3
   ToClear(3) = Field4: ToClear(4) = Field5: ToClear(5) = Field6

   COLOR FOREGROUND, BACKGROUND

       FOR Index = 0 TO 5
         IF ToClear(Index) THEN
           SELECT CASE Index
             CASE 0
               LOCATE TITLEFIELD, 18
               PRINT "                                                    "
             CASE 1
               LOCATE AUTHORFIELD, 18
               PRINT "                                                    "
             CASE 2
               LOCATE PUBFIELD, 18
               PRINT "                                                    "
             CASE 3
               LOCATE EDFIELD, 18
               PRINT "                                                    "
             CASE 4
               IF TableNum% = cCardHoldersTableNum THEN
                 LOCATE PRICEFIELD, 18
                 PRINT "                                                    "
               ELSE
                 LOCATE PRICEFIELD, 19
                 PRINT "                                                   "
               END IF
             CASE 5
               LOCATE IDFIELD, 18
               PRINT "                                                    "
           END SELECT
         END IF
       NEXT Index
 END SUB

 '**************************************************************************
 '*  The ConfirmEntry FUNCTION echoes the user's input and processes his   *
 '*  response to make sure the proper action is taken.                     *
 '*                                 Parameters                             *
 '*  Letter$   Contains the input that the user has just entered.          *
 '**************************************************************************
 FUNCTION ConfirmEntry% (Letter$)
   Alert$ = "Press ENTER to confirm choice, type value, or TAB to move on"
   CALL ShowMessage(Alert$, 1)
   DO
   Answer$ = INKEY$
   LOOP WHILE Answer$ = EMPTYSTRING
   Reply% = ASC(Answer$)

   SELECT CASE Reply%
     CASE ENTER
       ConfirmEntry% = -1
       Letter$ = ""
     CASE TABKEY
       ConfirmEntry% = 0
       Letter$ = Answer$
     CASE ASC(" ") TO ASC("~")
       Letter$ = Answer$
       ConfirmEntry = -1
     CASE ELSE
       ConfirmEntry% = 0
       Letter$ = "eScApE"
       CALL ShowMessage("Invalid key --- Try again", 0)
    END SELECT
 END FUNCTION

 '***************************************************************************
 '*    The DrawHelpBoox SUB draws the menu box that links a key to a task.  *
 '***************************************************************************
 SUB DrawHelpBox
   COLOR FOREGROUND, BACKGROUND
   RESTORE KeysBox
     FOR Row = BOXTOP TO BOXEND
       LOCATE Row, 1
       READ Temp$
       PRINT Temp$
       IF Row = BOXEND THEN
         COLOR BACKGROUND, FOREGROUND + BRIGHT
         LOCATE Row, HELPCOL + 3
         PRINT " Keys for Database Viewing/Editing "
         COLOR FOREGROUND, BACKGROUND
       END IF
     NEXT Row
   COLOR FOREGROUND, BACKGROUND
 END SUB

 '***************************************************************************
 '*    The DrawHelpKeys SUB refills the menu box that links a key to a task.*
 '*                                Parameters                               *
 '*    TableNum    Integer identifying the table being displayed            *
 '***************************************************************************
 SUB DrawHelpKeys (TableNum AS INTEGER)

 COLOR FOREGROUND, BACKGROUND
 IF TableNum = cBookStockTableNum THEN RESTORE HelpKeys1 ELSE RESTORE HelpKeys
 FOR Row = BOXTOP TO BOXEND
   LOCATE Row, HELPCOL + 2
   READ Temp$
   PRINT Temp$
   IF Row = BOXEND THEN
     COLOR BACKGROUND, FOREGROUND + BRIGHT
     LOCATE Row, HELPCOL + 3
     PRINT " Keys for Database Viewing/Editing "
     COLOR FOREGROUND, BACKGROUND
     END IF
 NEXT Row
 COLOR FOREGROUND, BACKGROUND

 END SUB

 '***************************************************************************
 '*  The DrawIndexBox procedure draws the appropriate index box, depending  *
 '*  the table being displayed. If the task is EDITRECORD, the index box    *
 '*  information is replaced with information about Undo and Undo All       *
 '*                               Parameters                                *
 '*  TableNum    Integer identifying the table being displayed              *
 '*  Task        Integer identifying the task the user is involved in       *
 '***************************************************************************
 SUB DrawIndexBox (TableNum AS INTEGER, Task%)

 COLOR FOREGROUND, BACKGROUND

 IF Task = EDITRECORD THEN
   RESTORE EditMessage
 ELSE
   IF TableNum = 1 THEN RESTORE Indexbox1 ELSE RESTORE Indexbox2
 END IF

 FOR Row = BOXTOP TO BOXEND
   LOCATE Row, 42
   READ Temp$
   PRINT Temp$
   IF Row = BOXEND THEN
     IF Task = EDITRECORD THEN
       COLOR FOREGROUND + BRIGHT, BACKGROUND
       LOCATE 19, INDBOX + 16
       PRINT "U"
       LOCATE 21, INDBOX + 2
       PRINT "CTRL+U"
       LOCATE Row, INDBOX + 7
       PRINT " To Undo Edits "
       COLOR FOREGROUND, BACKGROUND
     ELSE
       COLOR BACKGROUND, FOREGROUND + BRIGHT
       LOCATE Row, INDBOX + 3
       PRINT " Current Sorting Order "
       COLOR FOREGROUND, BACKGROUND
     END IF
   END IF
 NEXT Row
 COLOR FOREGROUND, BACKGROUND

 END SUB

 '***************************************************************************
 '*  The DrawScreen SUB calls other procedures to draw the appropriate parts*
 '*  of the screen for the table to be displayed.                           *
 '*                                Parameters                               *
 '*  TableNum    Integer telling which table is to be shown                 *
 '***************************************************************************
 SUB DrawScreen (TableNum AS INTEGER)
   CALL DrawTable(TableNum)
   CALL DrawHelpBox
   CALL DrawHelpKeys(TableNum)
   CALL DrawIndexBox(TableNum, Task)
   CALL ShowMessage("", 0)
   COLOR FOREGROUND, BACKGROUND
 END SUB

 '***************************************************************************
 '*  The DrawTable SUB draws and lables the table being displayed.          *
 '*                                Parameters                               *
 '*  TableNum    The number of the table currently being displayed          *
 '***************************************************************************
 SUB DrawTable (TableNum AS INTEGER)
 CALL ClearEm(TableNum, 1, 1, 1, 1, 1, 1)
 VIEW PRINT
 COLOR FOREGROUND, BACKGROUND
 SELECT CASE TableNum
   CASE 1
     TableName$ = " Book Stock Table "
   CASE 2
     TableName$ = " Card Holders Table "
 END SELECT

 HowLong = LEN(TableName$)
 NameSpace$ = "╡" + STRING$(HowLong, 32) + "╞"
 PlaceName = (72 \ 2) - (HowLong \ 2)

 IF TableNum = 1 THEN RESTORE BooksTable ELSE RESTORE LendeesTable

 COLOR FOREGROUND, BACKGROUND

 FOR Row = TABLETOP TO TABLEEND
   LOCATE Row, 1
   READ Temp$
   PRINT Temp$
   IF Row = TABLETOP THEN
     LOCATE TABLETOP, PlaceName
     PRINT NameSpace$
     COLOR BACKGROUND, BRIGHT + FOREGROUND
     LOCATE 1, PlaceName + 1
     PRINT TableName$
     COLOR FOREGROUND, BACKGROUND
   END IF
 NEXT Row
 COLOR FOREGROUND, BACKGROUND

 END SUB

 '***************************************************************************
 '*  The EraseMessage SUB erases the message in the message box between the *
 '*  displayed table and the menus at the bottom of the screen. It replaces *
 '*  the corners of the table and menus that may have been overwritten      *
 '***************************************************************************
 SUB EraseMessage
   COLOR FOREGROUND, BACKGROUND
        LOCATE MESBOXTOP, 1
        PRINT "╚"; STRING$(68, CHR$(205)); "╝"
        LOCATE MESFIELD, 1
        PRINT SPACE$(70)
        LOCATE MESBOXEND, 1
        PRINT "╔"; STRING$(38, CHR$(205)); "╗ ╔"; STRING$(27, CHR$(205)); "╗"

 END SUB

 '**************************** MakeString FUNCTION **************************
 '*                                                                         *
 '* The MakeString FUNCTION provides a minimal editor to operate in the     *
 '* BOOKLOOK message box. A prompt is shown. The user can enter numbers,    *
 '* letters, punctuation, the ENTER, BACKSPACE and ESC keys.                *
 '*                                                                         *
 '*                            Parameters:                                  *
 '*   FilterTrap   Brings in a keystroke or letter by ASCII value           *
 '*   ThisString   Prompt passed in depends on calling function             *
 '*                                                                         *
 '***************************************************************************
 FUNCTION MakeString$ (FilterTrap AS INTEGER, ThisString$)

 MessageLen = LEN(ThisString$)                   ' Save length of the prompt
 IF FilterTrap THEN                              ' then, if a letter was
   ThisString$ = ThisString$ + CHR$(FilterTrap)  ' passed in, add it to the
   NewString$ = CHR$(FilterTrap)                 ' prompt and use it to start
 END IF                                          ' string to be returned.
 CALL ShowMessage(ThisString$, 1)                ' Show the string and turn
 DO                                              ' on cursor at end.
   DO
   Answer$ = INKEY$
   LOOP WHILE Answer$ = EMPTYSTRING
       SELECT CASE Answer$
         CASE CHR$(ESCAPE)
           FilterTrap = ESCAPE
           CALL ShowMessage(KEYSMESSAGE, 0)
           EXIT FUNCTION
         CASE " " TO "~"
           NewString$ = NewString$ + Answer$
           ThisString$ = ThisString$ + Answer$
           CALL ShowMessage(ThisString$, 1)
         CASE CHR$(BACKSPACE)
           ShortLen = LEN(ThisString$) - 1
           ThisString$ = MID$(ThisString$, 1, ShortLen)
           NewString$ = MID$(ThisString$, MessageLen + 1)
           CALL ShowMessage(ThisString$, 1)
         CASE CHR$(ENTER)
           LOCATE , , 0
           MakeString$ = LTRIM$(RTRIM$(NewString$))
           EXIT FUNCTION
         CASE ELSE
           BEEP
           CALL ShowMessage("Not a valid key --- press Space bar", 0)
       END SELECT
 LOOP
 END FUNCTION

 '***************************************************************************
 '*  The ReturnKey$ FUNCTION gets a key from the user and returns its value *
 '***************************************************************************
 FUNCTION ReturnKey$
   DO
     Answer$ = INKEY$
   LOOP WHILE Answer$ = EMPTYSTRING
   ReturnKey$ = Answer$
 END FUNCTION

 '******************************** ShowIt SUB ******************************
 '*                                                                        *
 '*    After the user enters a value to search for in a specific index,    *
 '*    this SUB places the value in the proper element of the temporary    *
 '*    record variable, then displays the value in the field. Finally,     *
 '*    the user is prompted to choose the relationship the indexed value   *
 '*    should have to the key that has been entered.                       *
 '*                            Parameters:                                 *
 '*    TabesRec:       A temporary recordvariable - same as BigRec         *
 '*    WhichIndex:     Tells name of Index on which key should be sought   *
 '*    WhichTable:     The number of the table currently being displayed   *
 '*    StringTo Show:  Value user wants to search for in index             *
 '*                                                                        *
 '**************************************************************************
 SUB ShowIt (TablesRec AS RecStruct, WhichIndex$, WhichTable%, StringToShow$)
   TablesRec.TableNum = WhichTable
   TablesRec.WhichIndex = WhichIndex$
   COLOR BRIGHT + FOREGROUND, BACKGROUND
       SELECT CASE WhichIndex$
         CASE "TitleIndexBS"
           TablesRec.Inventory.Title = StringToShow$
         CASE "AuthorIndexBS"
           TablesRec.Inventory.Author = StringToShow$
         CASE "PubIndexBS"
           TablesRec.Inventory.Publisher = StringToShow$
         CASE "IDIndex"
           TablesRec.Inventory.IDnum = VAL(StringToShow$)
         CASE "NameIndexCH"
           TablesRec.Lendee.TheName = StringToShow$
         CASE "StateIndexCH"
           TablesRec.Lendee.State = StringToShow$
         CASE "ZipIndexCH"
           TablesRec.Lendee.Zip = VAL(StringToShow$)
         CASE "CardNumIndexCH"
           TablesRec.Lendee.CardNum = VAL(StringToShow$)
       END SELECT
     CALL ShowRecord(TablesRec)
   COLOR FOREGROUND, BACKGROUND
 END SUB

 '***************************************************************************
 '*  The ShowKeys SUB presents the key the user should press for a desired  *
 '*  operation associated with a description of the task.                   *
 '*                               Parameters                                *
 '*  TablesRec   RecStruct type variable containing table information       *
 '*  ForeGrnd    Integer indicating whether key is highlighted or not       *
 '*  TableDone   1 for No Next Record, 0 otherwise (usually DimN)           *
 '*  TableStart  1 for No Previous Record, 0 otherwise (usually DimP)       *
 '***************************************************************************
 SUB ShowKeys (TablesRec AS RecStruct, ForeGrnd%, TableDone%, TableStart%)
   COLOR ForeGrnd, BACKGROUND                    'foreground bright
   LOCATE NLINE, 3
   PRINT "N"
   LOCATE NLINE, 24
   PRINT "P"
   LOCATE RLINE, 3
   PRINT "R"
   LOCATE RLINE, 24
   PRINT "F"
   IF TablesRec.TableNum = cBookStockTableNum THEN
     LOCATE WLINE, 3
     PRINT "W"
     LOCATE WLINE, 24
     PRINT "B"
   ELSE
     LOCATE WLINE, 9
     PRINT "B"
   END IF
   LOCATE VLINE, 9
   PRINT "V"
   LOCATE ALINE, 3
   PRINT "A"
   LOCATE ALINE, 24
   PRINT "D"
   LOCATE ELINE, 3
   PRINT "E"
   LOCATE ELINE, 24
   PRINT "Q"
   IF TablesRec.TableNum = cBookStockTableNum THEN
     LOCATE CLINE, 3
     PRINT "O"
     LOCATE CLINE, 24
     PRINT "I"
   END IF
   IF TableDone = TRUE THEN

     LOCATE NLINE, 3
     PRINT " No Next Record"
   ELSE
     LOCATE NLINE, 3
     PRINT "N "
     COLOR FOREGROUND, BACKGROUND
     LOCATE NLINE, 5
     PRINT "= "
     LOCATE NLINE, 6
     PRINT " Next Record"
   END IF
   IF TableStart = TRUE THEN
     COLOR ForeGrnd, BACKGROUND
     LOCATE NLINE, 20
     PRINT " No Previous Record"
   ELSE
     COLOR ForeGrnd, BACKGROUND
     LOCATE NLINE, 20
     PRINT "    P "
     COLOR FOREGROUND, BACKGROUND
     LOCATE NLINE, 26
     PRINT "= "
     LOCATE NLINE, 27
     PRINT " Previous   "
     END IF
   COLOR FOREGROUND, BACKGROUND
 END SUB

 '**************************************************************************
 '*  The ShowMessage SUB displays the message string passed in the message *
 '*  box between the displayed table and the menus. If the Cursor parameter*
 '*  is 0, no cursor appears in the box; if it is 1, a cursor is displaed. *
 '*                                 Parameters                             *
 '*  Message$    Prompt or message to display                              *
 '*  Cursor      Boolean value telling whether or not to show a cursor     *
 '**************************************************************************
 SUB ShowMessage (Message$, Cursor)
   CALL EraseMessage
   IF (LEN(Message$) MOD 2) THEN
         Borderlen = 1
   END IF
   MesLen = LEN(Message$)
   SELECT CASE Cursor                          ' No cursor request means to
   CASE FALSE                                  ' center the message in box
     HalfMes = (MesLen \ 2) + 1                ' and display without cursor
     Start = (SCREENWIDTH \ 2) - HalfMes
   CASE ELSE
     Start = 4                                 ' Message is part of an edit
   END SELECT                                  ' so display flush left, and
     LOCATE MESBOXTOP, 2                       ' keep cursor visible
     PRINT "╔"; STRING$(66, CHR$(205)); "╗"
     LOCATE MESFIELD, 2
     PRINT "║"; SPACE$(66); "║"
     LOCATE MESBOXEND, 2
     PRINT "╚"; STRING$(37, CHR$(205)); "╦"; "═╦"; STRING$(26, CHR$(205)); "╝"
     COLOR BRIGHT + FOREGROUND, BACKGROUND
     LOCATE MESFIELD, Start, Cursor
     PRINT Message$;
     LOCATE MESFIELD, Start + MesLen, Cursor
     PRINT "";
     COLOR FOREGROUND, BACKGROUND
 END SUB

 '**************************************************************************
 '*  The ShowRecord SUB displays the columns of the current record of the  *
 '*  table being displayed. Numerics are only displayed if they are <> 0.  *
 '*                                Parameters                              *
 '*  TablesRec   RecStruct type variable containing table information      *
 '**************************************************************************
 SUB ShowRecord (TablesRec AS RecStruct)
 COLOR FOREGROUND, BACKGROUND
   SELECT CASE TablesRec.TableNum
     CASE cBookStockTableNum
       LOCATE TITLEFIELD, 18: PRINT TablesRec.Inventory.Title
       LOCATE AUTHORFIELD, 18: PRINT TablesRec.Inventory.Author
       LOCATE PUBFIELD, 18: PRINT TablesRec.Inventory.Publisher
       IF TablesRec.Inventory.Edition <> 0 THEN LOCATE EDFIELD, 17: PRINT STR$
       IF TablesRec.Inventory.Price <> 0 THEN LOCATE PRICEFIELD, 17: PRINT " $
       IF TablesRec.Inventory.IDnum <> 0 THEN LOCATE IDFIELD, 17: PRINT STR$(T
     CASE cCardHoldersTableNum
       LOCATE NAMEFIELD, 18: PRINT TablesRec.Lendee.TheName
       LOCATE STREETFIELD, 18: PRINT TablesRec.Lendee.Street
       LOCATE CITYFIELD, 18: PRINT TablesRec.Lendee.City
       LOCATE STATEFIELD, 18: PRINT TablesRec.Lendee.State
       IF TablesRec.Lendee.Zip <> 0 THEN LOCATE ZIPFIELD, 17: PRINT STR$(Table
       IF TablesRec.Lendee.CardNum <> 0 THEN LOCATE CARDNUMFIELD, 17: PRINT ST
     CASE ELSE
        CALL ShowMessage("There are no other forms defined", 0)
   END SELECT
 END SUB

 '**************************************************************************
 '*  The UserChoice SUB is used to echo back to the user the most recent   *
 '*  menu selection he has made. Not all menu choices are echoed back.     *
 '*                                Parameters                              *
 '*  BigRec    RecStruct type variable containing table information        *
 '*  Row       Row on which to put the Feedback$                           *
 '*  Column    Column at which to start the Feedback$                      *
 '*  Feedback$ Menu-choice string to highlight                             *
 '**************************************************************************
 SUB UserChoice (BigRec AS RecStruct, Row, Column, Feedback$)
     CALL DrawHelpKeys(BigRec.TableNum)
     CALL ShowKeys(BigRec, BRIGHT + FOREGROUND, DimN, DimP)
     COLOR FOREGROUND + BRIGHT, BACKGROUND
     LOCATE Row, Column
     PRINT Feedback$
     COLOR FOREGROUND, BACKGROUND
 END SUB



 BOOKMOD2.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\BOOKMOD2.BAS

 '***********************************************************************
 '*  This is module level code for BOOKMOD2.BAS. It contains procedures *
 '*  that use ISAM statements as well as procedures that support them.  *
 '*  It is the third module of the BOOKLOOK program.                    *
 '***********************************************************************
 DEFINT A-Z
 '$INCLUDE: 'booklook.bi'

 EditMessage:
 DATA "╔═══════════════════════════╗"
 DATA "║ A log is being kept while ║"
 DATA "║ you edit fields in this   ║"
 DATA "║ record. Press U to undo   ║"
 DATA "║ each preceding edit, or   ║"
 DATA "║ CTRL+U to undo all of the ║"
 DATA "║ pending edits as a group. ║"
 DATA "║                           ║"
 DATA "╚═════╡ To Undo Edits ╞═════╝"

 OperandBox:
 DATA "╔═══════════════════════════╗"
 DATA "║                           ║"
 DATA "║ Greater Than              ║"
 DATA "║ or                        ║"
 DATA "║ Equal To     Value Entered║"
 DATA "║ or                        ║"
 DATA "║ Less Than                 ║"
 DATA "║                           ║"
 DATA "╚══╡ Relationship to Key ╞══╝"

 '************************************************************************
 '*                                                                      *
 '*  This SUB checks the real current index after a try to set an index. *
 '*  If the index was successfully set, it's name is displayed, other-   *
 '*  wise the current index is displayed. IndexBox is called to update   *
 '*  Current Sorting Order box on the screen.                            *
 '*                                                                      *
 '************************************************************************
 SUB AdjustIndex (TablesRec AS RecStruct)
   RealIndexName$ = GETINDEX$(TablesRec.TableNum)
   CALL Indexbox(TablesRec, CheckIndex%(TablesRec, 0))
   IF RealIndexName$ <> EMPTYSTRING THEN
     Alert$ = "Records are now ordered by the index called " + RealIndexName$
   ELSE
     Alert$ = "Records now ordered by the default (NULL) index"
   END IF
   CALL ShowMessage(Alert$, 0)
 END SUB

 '***************************************************************************
 '*  The ChangeRecord FUNCTION gets the new field value with MakeString. It *
 '*  then assigns the value (converted if necessary) to its proper element  *
 '*  in the recordvariable (TablesRec) used to update the table.            *
 '*                                Parameters                               *
 '*  FirstLetter   If the user has started typing, this contains a letter   *
 '*  Argument      Tells what field the cursor is currently in              *
 '*  TablesRec     RecStruct type variable holding all table information    *
 '*  Task          Tells which operation is being performed                 *
 '***************************************************************************
 FUNCTION ChangeRecord (FirstLetter$, Argument, TablesRec AS RecStruct, Task A
   STATIC SaveTitle AS STRING
   Prompt$ = "New Field Value: "

   IF Task <> SEEKFIELD THEN            ' Adjust the Argument --- It is in-
     IF Argument = TITLEFIELD THEN      ' cremented as part of PlaceCursor.
       Argument = IDFIELD               ' But it needs the user's original
     ELSE                               ' choice in this function.
        Argument = Argument - 2
     END IF
   END IF

   Filter% = ASC(FirstLetter$)                ' Convert FirstLetter$ to ascii
   Remainder$ = MakeString$(Filter%, Prompt$) ' number to pass to MakeString.
   IF Filter% = ESCAPE THEN                   ' This lets the user press ESC
     ChangeRecord = 0                         ' to abandon function.
     CALL ShowRecord(TablesRec)
     EXIT FUNCTION
   END IF
                                            ' Select for proper assignment of
   SELECT CASE Argument                     ' string user makes with MakeStrin
     CASE TITLEFIELD, NAMEFIELD
       IF Task = EDITRECORD OR Task = ADDRECORD OR Task = SEEKFIELD THEN
         IF TablesRec.TableNum = cBookStockTableNum THEN
           TablesRec.Inventory.Title = Remainder$
         ELSE
           TablesRec.Lendee.TheName = Remainder$
         END IF
       END IF
       COLOR FOREGROUND, BACKGROUND
     CASE AUTHORFIELD, STREETFIELD
       IF Task = EDITRECORD OR Task = ADDRECORD THEN
         IF TablesRec.TableNum = cBookStockTableNum THEN
           TablesRec.Inventory.Author = Remainder$
         ELSE
           TablesRec.Lendee.Street = Remainder$
         END IF
       END IF
       COLOR FOREGROUND, BACKGROUND
     CASE PUBFIELD, CITYFIELD
       IF Task = EDITRECORD OR Task = ADDRECORD THEN
         IF TablesRec.TableNum = cBookStockTableNum THEN
           TablesRec.Inventory.Publisher = Remainder$
         ELSE
           TablesRec.Lendee.City = Remainder$
         END IF
       END IF
       COLOR FOREGROUND, BACKGROUND
     CASE EDFIELD, STATEFIELD
       IF Task = EDITRECORD OR Task = ADDRECORD THEN
         IF TablesRec.TableNum = cBookStockTableNum THEN
           TablesRec.Inventory.Edition = VAL(Remainder$)
         ELSE
           TablesRec.Lendee.State = Remainder$
         END IF
       END IF
       COLOR FOREGROUND, BACKGROUND
     CASE PRICEFIELD, ZIPFIELD
       IF Task = EDITRECORD OR Task = ADDRECORD THEN
         IF TablesRec.TableNum = cBookStockTableNum THEN
           TablesRec.Inventory.Price = VAL(Remainder$)
         ELSE
           TablesRec.Lendee.Zip = VAL(Remainder$)
         END IF
       END IF
       COLOR FOREGROUND, BACKGROUND
     CASE IDFIELD, CARDNUMFIELD
       IF Task = EDITRECORD OR Task = ADDRECORD THEN
         IF TablesRec.TableNum = cBookStockTableNum THEN
           size = LEN(Remainder$)
           FOR counter = 1 TO size
             IF ASC(MID$(Remainder$, counter, 1)) = 0 THEN
               Remainder$ = MID$(Remainder$, (counter + 1), size)
             END IF
           NEXT counter
           TablesRec.Inventory.IDnum = VAL(LTRIM$(RTRIM$(Remainder$)))
         ELSE
           TablesRec.Lendee.CardNum = VAL(Remainder$)
         END IF
       END IF
       COLOR FOREGROUND, BACKGROUND
     CASE ELSE
         CALL ShowMessage("  Can't change that field ", 0)
         BEEP
         SLEEP 1
 END SELECT
  ChangeRecord = 1
 END FUNCTION

 '***************************************************************************
 '*  The CheckIndex uses the GETINDEX function to find the current index.   *
 '*  Since only some displayed fields correspond to indexes, the number     *
 '*  returned is a code indicating what to do, not the index name           *
 '*                                Parameters                               *
 '*  TablesRec   RecStuct type variable holding all table information       *
 '*  FirstTime   If first time is TRUE, Index is NULL index                 *
 '***************************************************************************
 FUNCTION CheckIndex% (TablesRec AS RecStruct, FirstTime)
   Check$ = GETINDEX$(TablesRec.TableNum)
   SELECT CASE Check$
     CASE "TitleIndexBS", "NameIndexCH"
       CheckIndex% = 0
     CASE "AuthorIndexBS"
       CheckIndex% = 1
     CASE "PubIndexBS"
       CheckIndex% = 2
     CASE "StateIndexCH"
       CheckIndex% = 3
     CASE "ZipIndexCH"
       CheckIndex% = 4
     CASE "IDIndex", "CardNumIndexCH"
       CheckIndex% = 5
     CASE "BigIndex"                 ' There's no combined index on
       CheckIndex% = 6               ' CardHolders table
     CASE ""
       CheckIndex% = 7               ' This is a special case for the
                                     ' Blank line in CardHolders table
     IF FirstTime% THEN
       CALL Indexbox(TablesRec, 7)
     END IF
   END SELECT
 END FUNCTION

 '***************************************************************************
 '*  The EdAddCursor function is used to place the cursor in the proper     *
 '*  when the task is to Edit or Add a record.  Note when printing numeric  *
 '*  fields LOCATE 1 column left to compensate  for the implicit "+" sign.  *
 '*                                Parameters                               *
 '*  NextField   Tells which field is to be highlighted next                *
 '*  Job         Tells operation user wants to engage in                    *
 '*  TablesRec   RecStruct type variable holding all table information      *
 '*  FirstShot   Nonzero value indicates this is first time through         *
 '***************************************************************************
 FUNCTION EdAddCursor (NextField%, Job%, TablesRec AS RecStruct, FirstShot%)
   SELECT CASE TablesRec.TableNum
     CASE cBookStockTableNum                       ' BookStock table is 1
       SELECT CASE NextField
         CASE TITLEFIELD, NAMEFIELD
           LOCATE IDFIELD, 17
           IF FirstShot THEN COLOR FOREGROUND, BACKGROUND
           PRINT TablesRec.Inventory.IDnum
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE TITLEFIELD, 18
           PRINT TablesRec.Inventory.Title
           NextField% = AUTHORFIELD
         CASE AUTHORFIELD, STREETFIELD
           LOCATE TITLEFIELD, 18
           PRINT TablesRec.Inventory.Title
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE AUTHORFIELD, 18
           PRINT TablesRec.Inventory.Author
           NextField% = PUBFIELD
         CASE PUBFIELD, CITYFIELD
           LOCATE AUTHORFIELD, 18
           PRINT TablesRec.Inventory.Author
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE PUBFIELD, 18
             PRINT TablesRec.Inventory.Publisher
             NextField% = EDFIELD
         CASE EDFIELD, STATEFIELD
           LOCATE PUBFIELD, 18
           PRINT TablesRec.Inventory.Publisher
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE EDFIELD, 17
           PRINT TablesRec.Inventory.Edition
           NextField% = PRICEFIELD
         CASE PRICEFIELD, ZIPFIELD
           LOCATE EDFIELD, 17
           PRINT TablesRec.Inventory.Edition
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE PRICEFIELD, 19
           PRINT ; TablesRec.Inventory.Price
           NextField% = IDFIELD
         CASE IDFIELD, CARDNUMFIELD
           LOCATE PRICEFIELD, 18
           PRINT "$"; TablesRec.Inventory.Price
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE IDFIELD, 17
           PRINT TablesRec.Inventory.IDnum
           NextField% = TITLEFIELD
       END SELECT
     CASE cCardHoldersTableNum                       ' CardHolders table is 2
       SELECT CASE NextField
         CASE NAMEFIELD
           LOCATE CARDNUMFIELD, 17
           IF FirstShot THEN COLOR FOREGROUND, BACKGROUND
           PRINT TablesRec.Lendee.CardNum
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE NAMEFIELD, 18
           PRINT TablesRec.Lendee.TheName
           NextField% = STREETFIELD
         CASE STREETFIELD
           LOCATE NAMEFIELD, 18
           PRINT TablesRec.Lendee.TheName
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE STREETFIELD, 18
           PRINT TablesRec.Lendee.Street
           NextField% = CITYFIELD
         CASE CITYFIELD
           LOCATE STREETFIELD, 18
           PRINT TablesRec.Lendee.Street
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE CITYFIELD, 18
           PRINT TablesRec.Lendee.City
           NextField% = STATEFIELD
         CASE STATEFIELD
           LOCATE CITYFIELD, 18
           PRINT TablesRec.Lendee.City
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE STATEFIELD, 18
           PRINT TablesRec.Lendee.State
           NextField% = PRICEFIELD
         CASE ZIPFIELD
           LOCATE STATEFIELD, 18
           PRINT TablesRec.Lendee.State
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE ZIPFIELD, 17
           PRINT TablesRec.Lendee.Zip
           NextField% = IDFIELD
         CASE CARDNUMFIELD
           LOCATE ZIPFIELD, 17
           PRINT TablesRec.Lendee.Zip
           COLOR BACKGROUND, BRIGHT + FOREGROUND
           LOCATE CARDNUMFIELD, 17
           PRINT TablesRec.Lendee.CardNum
           NextField% = TITLEFIELD
       END SELECT
   END SELECT
   COLOR FOREGROUND, BACKGROUND
 END FUNCTION

 '***************************************************************************
 '*  The EditField function lets the user choose whether or not to actually *
 '*  change the current field (by calling ChangeRecord) or move on to the   *
 '*  next field. It also displays a message telling how to Undo edits. If   *
 '*  EditField returns TRUE, a SAVEPOINT is set at module level. If the task*
 '*  is ADDRECORD, the user is taken through the fields one at a time until *
 '*  they have all been entered.                                            *
 '*                              Parameters                                 *
 '*  Argument    Tells which field is currently being dealt with            *
 '*  TablesRec   RecStruct type variable holding current table information  *
 '*  FirstLetter If the user has started typing, the letter is passed in    *
 '*  Task        Tells what type of operation the user is performing        *
 '*  Answer      Same as Task, but passed to ChangeRecord
 '***************************************************************************
 FUNCTION EditField (Argument%, TablesRec AS RecStruct, FirstLetter$, Task%, A
   ' Show the transaction block message dealing with undoing edits:
   IF Task = EDITRECORD THEN CALL DrawIndexBox(1, Task)

   STATIC NextField
   FirstLetter$ = ""
   IF Task = EDITRECORD THEN CALL ShowMessage("Edit this field or TAB to anoth
   Argument = TITLEFIELD
   Value = PlaceCursor(Argument, TablesRec, FirstLetter$, 1, Task%)
   IF Argument THEN
     IF Task = EDITRECORD THEN CALL ShowMessage("Edit this field or TAB to ano
     COLOR FOREGROUND, BACKGROUND
     WasFieldChanged = ChangeRecord(FirstLetter$, Argument, TablesRec, Answer)

     IF Task = EDITRECORD AND WasFieldChanged <> 0 THEN
       CALL ShowMessage("Press E to Edit another field ", 0)
       EditField = TRUE            ' If True is returned, a SAVEPOINT is set
     ELSEIF Task = EDITRECORD AND WasFieldChanged = 0 THEN
       CALL ShowRecord(TablesRec)
       CALL ShowMessage("Please try again...", 0)
       EditField = FALSE     'Don't set SAVEPOINT if user escapes from edit
     ELSEIF Task = SEEKFIELD THEN
       EditField = FALSE: EXIT FUNCTION
     END IF
     IF Task = ADDRECORD THEN
       NextField = 1
       DO WHILE NextField <> 0 AND Argument <> 0
         CALL ShowMessage("Enter value for field or ESC to abandon addition ",
         SELECT CASE NextField
           CASE 1
             Argument = AUTHORFIELD
             FieldsDone = FieldsDone + 1
           CASE 2
             Argument = PUBFIELD
             FieldsDone = FieldsDone + 1
           CASE 3
             Argument = EDFIELD
             FieldsDone = FieldsDone + 1
           CASE 4
             Argument = PRICEFIELD
             FieldsDone = FieldsDone + 1
           CASE 5
             Argument = IDFIELD
             FieldsDone = FieldsDone + 1
             NextField = 0
           CASE ELSE
             CALL ShowMessage("Problem in the CASE assignments to Argument", 0
         END SELECT
         FirstLetter$ = ""
         Value = PlaceCursor(Argument, TablesRec, FirstLetter$, 1, Task%)
         IF Argument THEN
           COLOR FOREGROUND, BACKGROUND
           WasFieldChanged = ChangeRecord(FirstLetter$, Argument, TablesRec, A
           NextField = NextField + 1
           IF FieldsDone = 5 THEN EditField% = 1: EXIT FUNCTION
         END IF
       LOOP
       EditField = FALSE 'No need for SAVEPOINT with ADDRECORD
     END IF
   ELSE
   CALL ShowRecord(TablesRec)
   CALL ShowMessage("Please try again...", 0)
   SLEEP: CALL EraseMessage
   CALL DrawIndexBox(TablesRec.TableNum, 0)' Replace Edit stuff with Index stu
   EditField = FALSE     'Don't set SAVEPOINT if user escapes from edit
   END IF

 END FUNCTION

 '***************************************************************************
 '*  The GetKeyVals SUB gathers the Keys for searching on a combined index. *
 '*  It shows the fields as they are entered.                               *
 '*                                Parameters                               *
 '*  TablesRec   Contains all the information for the tables                *
 '*  Key1        Represents the Title field of BookStock table              *
 '*  Key2        Represents the Author field of BookStock table             *
 '*  Key3        Represents the IDnum field of BookStock table              *
 '*  Letter      Holds the first letter the user tries to enter at prompt   *
 '***************************************************************************
 SUB GetKeyVals (TablesRec AS RecStruct, Key1$, Key2$, Key3#, Letter$)
   WhichTable = TablesRec.TableNum
   Prompt$ = "Value to Seek: "

   CALL DrawScreen(WhichTable)
   DO
     ' Have the user ENTER the Title value to search for
     COLOR BACKGROUND, FOREGROUND
     LOCATE TITLEFIELD, 18
     PRINT "Please enter the Title to find"
     Key1$ = MakeString$(ASC(Letter$), Prompt$)
     CALL ShowIt(TablesRec, "TitleIndexBS", WhichTable, Key1$)
   LOOP UNTIL Key1$ <> ""

   Letter$ = " "    ' Set it to a blank space for typing

     ' Have the user ENTER the Author value to search for
   DO
     COLOR BACKGROUND, FOREGROUND
     LOCATE AUTHORFIELD, 18
     PRINT "Please enter the Author name to find"
     Key2$ = MakeString$(ASC(Letter$), Prompt$)
     ' Show it just shows the input user has entered, not a record from file
     CALL ShowIt(TablesRec, "AuthorIndexBS", WhichTable, Key2$)
   LOOP UNTIL Key2$ <> ""

   Letter$ = " "    ' Set it to a blank space for typing
     ' Have the user ENTER the ID number value to search for
   DO
     COLOR BACKGROUND, FOREGROUND
     LOCATE IDFIELD, 18
     PRINT "Please enter the ID number to find"
     ValueToSeek$ = MakeString$(ASC(Letter$), Prompt$)
     Key3# = CDBL(VAL(ValueToSeek$))       ' CURRENCY field
     CALL ShowIt(TablesRec, "IDIndex", WhichTable, ValueToSeek$)
 LOOP UNTIL Key3# <> 0
 END SUB

 '****************************** GetOperand FUNCTION ************************
 '* The GetOperand FUNCTION displays a choice of operators to allow user a  *
 '* choice in how a SEEKoperand search will be conducted. If the user makes *
 '* a valid choice, it is assigned to HoldOperand. An invalid choice or a   *
 '* choice of ESC results in "<>" being passed back. This permits an exit   *
 '* from the function (which is recursive). Otherwise, the user's choice is *
 '* trapped in HoldOperand when ENTER is pressed.                           *
 '* Note that this function is recursive so use the calls menu to keep      *
 '* track of the nesting depth when stepping through it. Unlike PlaceCursor *
 '* GetOperand doesn't keep track of the stack - the stack set should be OK.*
 '*                              Parameters                                 *
 '*   HoldOperand    Contains operand to check each time function calls     *
 '*                  itself; Let's user ESC from function if desired.       *
 '***************************************************************************
 FUNCTION GetOperand% (HoldOperand$)
   STATIC WhichOne     ' Keep track of which case from call to call

   ' If user has chose ESC then exit back to caller
   IF HoldOperand$ = "<>" THEN WhichOne = 0: EXIT FUNCTION

   ' if this is the first time through the function then
   ' Replace the Sort Order box with box of operand choices
   IF WhichOne = 0 THEN
     RESTORE OperandBox
     FOR Row = BOXTOP TO BOXEND
       LOCATE Row, 42
       READ Temp$
       PRINT Temp$
       IF Row = BOXEND THEN
         COLOR FOREGROUND + BRIGHT, BACKGROUND
         LOCATE Row, INDBOX + 5
         PRINT "Relationship to Key"
       END IF
     NEXT Row
     LOCATE VLINE, 44
     PRINT "Equal To     Value Entered"     ' This is default --- if user
     COLOR FOREGROUND, BACKGROUND           ' presses ENTER without tabbing,
   END IF                                   ' SeekRecord sets the operand
                                            ' to =    Note: a more flexible
                                            ' default choice might be >=

   Alert$ = "Now press TAB to select how search should be conducted"
   CALL ShowMessage(Alert$, 0)
   DO
   Answer$ = INKEY$
   LOOP WHILE Answer$ <> CHR$(TABKEY) AND Answer$ <> CHR$(ENTER) AND Answer$ <

   IF LEN(Answer$) = 1 THEN
     SELECT CASE ASC(Answer$)
       CASE TABKEY
         SELECT CASE WhichOne
           CASE 0
             COLOR FOREGROUND, BACKGROUND
             LOCATE VLINE, 44
             PRINT "Equal To"
             COLOR BRIGHT + FOREGROUND, BACKGROUND
             LOCATE RLINE, 44
             PRINT "Greater Than"
             WhichOne = WhichOne + 1
             HoldOperand$ = ">"
           CASE 1
             COLOR BRIGHT + FOREGROUND, BACKGROUND
             LOCATE VLINE, 44
             PRINT "Equal To"
             LOCATE WLINE, 44
             PRINT "or"
             WhichOne = WhichOne + 1
             HoldOperand$ = ">="
           CASE 2
             COLOR FOREGROUND, BACKGROUND
             LOCATE RLINE, 44
             PRINT "Greater Than"
             LOCATE WLINE, 44
             PRINT "or"
             COLOR BRIGHT + FOREGROUND, BACKGROUND
             LOCATE ALINE, 44
             PRINT "or"
             LOCATE ELINE, 44
             PRINT "Less Than"
             WhichOne = WhichOne + 1
             HoldOperand$ = "<="
           CASE 3
             COLOR FOREGROUND, BACKGROUND
             LOCATE VLINE, 44
             PRINT "Equal To"
             LOCATE ALINE, 44
             PRINT "or"
             WhichOne = WhichOne + 1
             HoldOperand$ = "<"
             SLEEP
           CASE 4
             COLOR FOREGROUND, BACKGROUND
             LOCATE ELINE, 44
             PRINT "Less Than"
             COLOR BRIGHT + FOREGROUND, BACKGROUND
             LOCATE VLINE, 44
             PRINT "Equal To     Value Entered"
             WhichOne = WhichOne + 1
             HoldOperand$ = "="
           CASE ELSE
         END SELECT                          ' If no choice was made, call
         IF WhichOne > 4 THEN WhichOne = 0   ' GetOperand again
         COLOR FOREGROUND, BACKGROUND
         OK = GetOperand%(HoldOperand$)
       CASE ENTER
         WhichOne = 0
         EXIT FUNCTION
     CASE ESCAPE                 ' If user chooses ESC, signal the function
       HoldOperand$ = "<>"       ' to exit and keep exiting back through
       GetOperand% = 0           ' all levels of recursion
       WhichOne = 0
     CASE ELSE                   ' If user chooses invalid key, try again
       BEEP
       CALL ShowMessage("Use TAB to select relationship to search for...", 0)
       COLOR white, BACKGROUND
       OK = GetOperand%(HoldOperand$)
   END SELECT
 ELSE
 END IF

 END FUNCTION

 '***************************************************************************
 '*  The IndexBox SUB highlights the proper index name in the Current Index *
 '*  box at the bottom right section of the screen.                         *
 '                                                                          *
 '*  TablesRec   RecStruct type variable containing all table information   *
 '*  MoveDown    Integer representing line on which index name resides      *
 '***************************************************************************
 SUB Indexbox (TablesRec AS RecStruct, MoveDown)
    Table = TablesRec.TableNum
    COLOR BRIGHT + FOREGROUND, BACKGROUND
    LOCATE 17 + MoveDown, 44
    SELECT CASE MoveDown
      CASE 0
       IF Table = cBookStockTableNum THEN PRINT "By Titles   " ELSE PRINT "By
       COLOR FOREGROUND, BACKGROUND
       LOCATE ELINE, 44
       PRINT "Default = Insertion Order"
      CASE 1
       IF Table = cBookStockTableNum THEN PRINT "By Authors   "
       COLOR FOREGROUND, BACKGROUND
       LOCATE NLINE, 44
       IF Table = cBookStockTableNum THEN PRINT "By Titles   " ELSE PRINT "By
      CASE 2
       IF Table = cBookStockTableNum THEN PRINT "By Publishers   "
       COLOR FOREGROUND, BACKGROUND
       LOCATE RLINE, 44
       IF Table = cBookStockTableNum THEN PRINT "By Authors    "
      CASE 3
       IF Table = cCardHoldersTableNum THEN
         LOCATE RLINE, 44
         PRINT "By States     "
         COLOR FOREGROUND, BACKGROUND
         LOCATE NLINE, 44
         PRINT "By Names     "
       ELSE
         COLOR FOREGROUND, BACKGROUND
         LOCATE WLINE, 44
         PRINT "By Publishers"
       END IF
      CASE 4
       IF Table = cCardHoldersTableNum THEN
         LOCATE WLINE, 44
         PRINT "By Zipcodes   "
         COLOR FOREGROUND, BACKGROUND
         LOCATE RLINE, 44
         PRINT "By States     "
       END IF
      CASE 5
       LOCATE VLINE, 44
       IF Table = cBookStockTableNum THEN
         PRINT "By ID Numbers   "
         COLOR FOREGROUND, BACKGROUND
       ELSE
         PRINT "By Card numbers   "
         COLOR FOREGROUND, BACKGROUND
         LOCATE WLINE, 44
         PRINT "By Zipcodes    "
       END IF
      CASE 6
       IF Table = cBookStockTableNum THEN
         LOCATE ALINE, 44
         PRINT "By Title + Author + ID"
         COLOR FOREGROUND, BACKGROUND
         LOCATE VLINE, 44
         PRINT "By ID Numbers"
       ELSE
         LOCATE VLINE, 44
         COLOR FOREGROUND, BACKGROUND
         PRINT "By Card numbers   "
       END IF
      COLOR FOREGROUND, BACKGROUND
      CASE 7
       LOCATE ELINE, 44
       PRINT "Default = Insertion Order"
       COLOR FOREGROUND, BACKGROUND
       IF Table = cBookStockTableNum THEN
         LOCATE ALINE, 44
         PRINT "By Title + Author + ID"
       ELSE
         LOCATE VLINE, 44
         PRINT "By Card numbers"
       END IF
     END SELECT
    IF MoveDown < 7 THEN
     MoveDown = MoveDown + 1
    ELSE
     MoveDown = 0
    END IF
 COLOR FOREGROUND, BACKGROUND
 END SUB

 '***************************************************************************
 '* The OrderCursor FUNCTION returns TRUE or FALSE for user index choice.   *
 '* Each time the user places the cursor on an Index to sort on, this       *
 '* function displays an instruction message in the field(s) corresponding  *
 '* to the Index, It then associates the highlighted index name (in the     *
 '* Sorting Order box) with the name it is known by in the program, and     *
 '* places that name in the .WhichIndex element of a structured variable of *
 '* RecStruct type.                                                         *
 '*                                   Parameters:                           *
 '* Index       Integer telling which index user has highlighted            *
 '* NextField   Manifest Constant telling big cursor field position         *
 '* Job         Manifest Constant indicating task being performed           *
 '* TablesRec   Variable of RecStruct type, whose .WhichInded element is    *
 '*             used to return the index name to be used by SETINDEX.       *
 '***************************************************************************
 FUNCTION OrderCursor (Index%, NextField%, Job%, TablesRec AS RecStruct, Lette
   OrderCursor = FALSE
   CALL Indexbox(TablesRec, Index)         ' Light up the new index
   COLOR BACKGROUND, BRIGHT + FOREGROUND   ' in Sorting Order box
   LOCATE NextField, 18
   IF Job = REORDER THEN         ' Tell the user what is expected of him

     IF TablesRec.TableNum = cBookStockTableNum THEN
       IF NextField <> PRICEFIELD AND NextField <> EDFIELD THEN
         PRINT "Press enter to resort, or TAB to move on"
       ELSE
         LOCATE NextField, 20 '19
         PRINT "Sorry, cannot sort on an unindexed field"
       END IF
     ELSE
       IF NextField <> STREETFIELD AND NextField <> CITYFIELD THEN
         PRINT "Press enter to resort, or TAB to move on"
       ELSE
         PRINT "Sorry, cannot sort on an unindexed field"
       END IF
     END IF
    END IF

         ' The following places the name of the index to sort on in the
         ' WhichIndex element of the structured variable TablesRec --- it
         ' retrieved at the module-level code

         LOCATE NextField, 18
         SELECT CASE NextField
           CASE TITLEFIELD, NAMEFIELD
             IF Job = SEEKFIELD THEN
               IF TablesRec.TableNum = cBookStockTableNum THEN
                 PRINT "Type Title to search for, or press TAB to move on"
               ELSE
                 PRINT "Type Name to search for, or press TAB to move on"
               END IF
             END IF
             IF ConfirmEntry%(Letter$) THEN
               IF TablesRec.TableNum = cBookStockTableNum THEN
                 TablesRec.WhichIndex = "TitleIndexBS"
               ELSE
                 TablesRec.WhichIndex = "NameIndexCH"
               END IF
               OrderCursor = TRUE
               EXIT FUNCTION
             ELSE
               OrderCursor = FALSE
               NextField% = AUTHORFIELD
             END IF
           CASE AUTHORFIELD, STREETFIELD
             IF Job = SEEKFIELD THEN
               IF TablesRec.TableNum = cBookStockTableNum THEN
                 PRINT "Type Author name to search for, or TAB to move on"
               ELSE
                 PRINT "Sorry, can't search on an unindexed field"
               END IF
             END IF
             IF ConfirmEntry%(Letter$) THEN
               IF TablesRec.TableNum = cBookStockTableNum THEN
                 TablesRec.WhichIndex = "AuthorIndexBS"
               END IF
               OrderCursor = TRUE
               EXIT FUNCTION
             ELSE
               OrderCursor = FALSE
               NextField% = PUBFIELD
             END IF
           CASE PUBFIELD, CITYFIELD
             IF Job = SEEKFIELD THEN
               IF TablesRec.TableNum = cBookStockTableNum THEN
                 PRINT "Type Publisher name to search for, or TAB to move on"
               ELSE
                 PRINT "Sorry, can't search on an unindexed field"
               END IF
             END IF
             IF ConfirmEntry%(Letter$) THEN
               IF TablesRec.TableNum = cBookStockTableNum THEN
                 TablesRec.WhichIndex = "PubIndexBS"
               END IF
               OrderCursor = TRUE
               EXIT FUNCTION
             ELSE
               OrderCursor = FALSE
               NextField% = EDFIELD
             END IF
           CASE EDFIELD, STATEFIELD
             IF Job = SEEKFIELD THEN
               IF TablesRec.TableNum = cCardHoldersTableNum THEN
                 PRINT "Type State (2 letters), or TAB to move on"
               ELSE
                 PRINT "Sorry, can't search on an unindexed field"
               END IF
             END IF
             IF ConfirmEntry%(Letter$) THEN
               IF TablesRec.TableNum = cCardHoldersTableNum THEN
                 TablesRec.WhichIndex = "StateIndexCH"
               END IF
               OrderCursor = TRUE
               EXIT FUNCTION
             ELSE
               OrderCursor = FALSE
               NextField% = PRICEFIELD
             END IF
           CASE PRICEFIELD, ZIPFIELD
             IF Job = SEEKFIELD THEN
               IF TablesRec.TableNum = cCardHoldersTableNum THEN
                 PRINT "Type Zipcode to search for, or TAB to move on"
               ELSE
                 LOCATE PRICEFIELD, 20
                 PRINT "Sorry, can't search on an unindexed field"
               END IF
             END IF
             IF ConfirmEntry%(Letter$) THEN
               IF TablesRec.TableNum = cCardHoldersTableNum THEN
                 TablesRec.WhichIndex = "ZipIndexCH"
               END IF
               OrderCursor = TRUE
               EXIT FUNCTION
             ELSE
               OrderCursor = FALSE
               NextField% = IDFIELD
             END IF
           CASE IDFIELD, CARDNUMFIELD
             IF Job = SEEKFIELD THEN
               IF TablesRec.TableNum = cBookStockTableNum THEN
                 PRINT "Type ID number to search for, or TAB to move on"
               ELSE
                 PRINT "Type Card number to seek, or press TAB to move on"
               END IF
             END IF
             ' Setting Letter$ to "" may be unnecessary now
             Letter$ = ""
             IF ConfirmEntry%(Letter$) THEN
               IF TablesRec.TableNum = cBookStockTableNum THEN
                 TablesRec.WhichIndex = "IDIndex"
               ELSE
                 TablesRec.WhichIndex = "CardNumIndexCH"
               END IF
               OrderCursor = TRUE
               EXIT FUNCTION
             ELSE
               OrderCursor = FALSE
               NextField% = BIGINDEX
             END IF
         END SELECT
  IF Letter$ = "eScApE" THEN OrderCursor = 3: FirstLetter$ = ""
 END FUNCTION

 '***************************************************************************
 '*  The PlaceCursor FUNCTION lets the user tab around on the displayed form*
 '*  when performing field-specific operations on the table. Since this     *
 '*  function is recursive it keeps track of available stack space. The two *
 '*  major possibilities are SEEKs/REORDERs (for which OrderCursor is then  *
 '*  called) and EDIT/ADD records (for which EdAddCursor is called. Note    *
 '*  the combined index (BigIndex) and the default index are handled as     *
 '*  special cases, since they don't correspond to a single field.Recursive *
 '*  construction lets the user cycle through the fields as long as         *
 '*  sufficient stack remains to keep calling PlaceCursor. Note that since  *
 '*  it is recursive, it may take while to step out while stepping with F8. *
 '*                                Parameters                               *
 '*  WhichField    Integer identifier specifying current field on form      *
 '*  TablesRec     Variable of type RecStruct holding all table information *
 '*  FirstLetter$  Carries user response to initial prompt shown            *
 '*  FirstTime     Boolean telling whether this is first cal or recursion   *
 '*  Task          Tells operation being performed                          *
 '***************************************************************************
 '
 FUNCTION PlaceCursor% (WhichField, TablesRec AS RecStruct, FirstLetter$, Firs
 STATIC ReturnValue, InitialLetter$, GetOut, counter, WhichOne
 WhichTable = TablesRec.TableNum
 IF ExitFlag THEN EXIT FUNCTION

 ReturnValue = WhichField
 ' Keep tabs on the stack and exit and reset it if it gets too low
 IF FRE(-2) < 400 THEN
   WhichField = 0
   PlaceCursor = 0
   GetOut = -1
   EXIT FUNCTION
 END IF

 ' Set up for each of the possible operations that use PlaceCursor
 IF Task = REORDER THEN
    COLOR FOREGROUND, BACKGROUND
    CALL ShowMessage("Press TAB to choose field to sort on, ESC to escape", 0)
    IF WhichField = TITLEFIELD THEN WhichOne = 0
 ELSEIF Task = SEEKFIELD THEN
    CALL ShowMessage("TAB to a field, then enter a value to search", 0)
 ELSEIF Task = ADDRECORD THEN
   IF FirstTime THEN FirstLetter$ = CHR$(TABKEY) ELSE FirstLetter$ = ""
 END IF

 ' The following IF... lets function handle either an entered letter or TAB
 IF FirstLetter$ <> "" THEN
     Answer$ = FirstLetter$
 ELSEIF FirstTime THEN
   IF Task = EDITRECORD THEN
     Answer$ = CHR$(TABKEY)
   END IF
 ELSE
   DO
   Answer$ = INKEY$
   LOOP WHILE Answer$ = EMPTYSTRING
 END IF

 IF LEN(Answer$) = 1 THEN

 ' Clear the fields for the appropriate messages
 IF Task <> EDITRECORD AND Task <> ADDRECORD THEN
 CALL ClearEm(TablesRec.TableNum, 1, 1, 1, 1, 1, 1)
 END IF

    SELECT CASE ASC(Answer$)
     CASE IS = TABKEY, ENTER
            SELECT CASE WhichField
             CASE TITLEFIELD, AUTHORFIELD, PUBFIELD, EDFIELD, PRICEFIELD, IDFI
               IF Task = REORDER OR Task = SEEKFIELD THEN
                 RetVal = OrderCursor(WhichOne, WhichField, Task, TablesRec, F
                 IF RetVal THEN
                   ' trap a magic value for an escape here then call the Draw
                   IF RetVal <> 3 THEN
                     WhichOne = 0: EXIT FUNCTION
                   ELSE
                     WhichOne = 0
                     WhichField = 0
                     PlaceCursor = 0
                     CALL ShowRecord(TablesRec)
                     CALL ShowMessage("You've escaped! Try again", 0)
                     CALL DrawTable(WhichTable)
                     CALL DrawHelpKeys(WhichTable)
                     CALL ShowKeys(TablesRec, FOREGROUND + BRIGHT, 0, 0)
                     EXIT FUNCTION
                   END IF
                 END IF
               ELSEIF Task = EDITRECORD OR Task = ADDRECORD THEN
                 Placed = EdAddCursor(WhichField, Task, TablesRec, FirstTime)
               END IF

             CASE BIGINDEX
                 CALL Indexbox(TablesRec, WhichOne)
                 IF WhichTable = cBookStockTableNum THEN
                   COLOR BACKGROUND, BRIGHT + FOREGROUND
                   IF Task = REORDER THEN
                     LOCATE TITLEFIELD, 18
                     PRINT "Press ENTER to sort first by Title..."
                     LOCATE AUTHORFIELD, 18
                     PRINT "... then subsort by Author..."
                     LOCATE IDFIELD, 18
                     PRINT "... then subsort again by ID "
                     SLEEP
                   ELSEIF Task = SEEKFIELD THEN
                     LOCATE TITLEFIELD, 18
                     PRINT "First, type in the Title to search for,"
                     LOCATE AUTHORFIELD, 18
                     PRINT "... then type in the Author's name"
                     LOCATE IDFIELD, 18
                     PRINT "... then type in the ID number "
                     CALL ShowMessage("Typing in a value for a combined index
                     SLEEP
                   END IF
                   COLOR FOREGROUND, BACKGROUND
                   IF ConfirmEntry%(FirstLetter$) THEN
                     TablesRec.WhichIndex = "BigIndex"
                     IF Task = SEEKFIELD THEN
                       WhichOne = 0
                       WhichField = TITLEFIELD
                     END IF
                     EXIT FUNCTION
                   END IF
                 END IF
                 CALL ClearEm(TablesRec.TableNum, 1, 1, 0, 0, 1, 0)
                 WhichField = NULLINDEX   ' TITLEFIELD

             CASE NULLINDEX
                 CALL Indexbox(TablesRec, WhichOne)
                 IF Task = SEEKFIELD THEN
                   CALL ShowMessage("Can't SEEK on the default index", 0)
                   DO
                     KeyIn$ = INKEY$
                     IF KeyIn$ <> "" THEN
                       IF ASC(KeyIn$) = ESCAPE THEN EXIT FUNCTION
                     END IF
                   LOOP WHILE KeyIn$ = ""
                   'SLEEP
                 '  EXIT FUNCTION
                 'END IF
                 ELSEIF ConfirmEntry%(FirstLetter$) THEN
                   TablesRec.WhichIndex = "NULL"
                   EXIT FUNCTION
                 END IF
                 WhichField = TITLEFIELD

             CASE ELSE
                 EraseMessage
                  CALL ShowMessage("Not a valid key --- press Space bar", 0)
                 EXIT FUNCTION
           END SELECT
         ' Placecursor calls itself for next user response
         Value = PlaceCursor(WhichField, TablesRec, FirstLetter$, 0, Task)

     CASE ESCAPE
       WhichOne = 0
       WhichField = 0
       PlaceCursor = 0
       CALL ShowRecord(TablesRec)
       CALL ShowMessage("You've escaped! Try again", 0)
       CALL DrawTable(WhichTable)
       CALL DrawHelpKeys(WhichTable)
       CALL ShowKeys(TablesRec, FOREGROUND + BRIGHT, 0, 0)
       EXIT FUNCTION
     CASE 32 TO 127                        ' Acceptable ASCII characters
      InitialLetter$ = Answer$
      FirstLetter$ = InitialLetter$
      EXIT FUNCTION
     CASE ELSE
         BEEP
         EraseMessage
          CALL ShowMessage("Not a valid key --- press Space bar", 0)
         WhichField = 0
         PlaceCursor = 0
         EXIT FUNCTION
     END SELECT
 ELSEIF Answer$ <> CHR$(9) THEN
   EraseMessage
   CALL ShowMessage("Not a valid key --- press Space bar", 0)
   WhichField = 0
   EXIT FUNCTION
 ELSE
      CALL ShowMessage("  Press TAB key or ENTER  ", 0)
 END IF

 IF GetOut THEN
   counter = counter + 1
   IF counter < 15 THEN
     WhichField = 0
     WhichOne = 0
     EXIT FUNCTION
   ELSE
     GetOut = 0
     counter = 0
  END IF
 END IF

 END FUNCTION

 '***************************************************************************
 '*  The TransposeName FUNCTION takes a  string and decideds whether it is  *
 '*  a comma-delimited, last-name-first name, a first-name-first name or a  *
 '*  single word name. In the last case, the string is returned unchanged.  *
 '*  In either of the other cases, the string is translated to the comple-  *
 '*  mentary format.                                                        *
 '*                              Parameters                                 *
 '*  TheName   A string representing a CardHolders table TheName element,   *
 '*            or a BookStock table Author Element                          *
 '***************************************************************************
 FUNCTION TransposeName$ (TheName AS STRING)
 SubStrLen = (INSTR(TheName, ","))
 IF SubStrLen = 0 THEN
   SubStrLen = INSTR(TheName, " ")
   IF SubStrLen = 0 THEN TransposeName$ = TheName: EXIT FUNCTION
 END IF
 TheName = LTRIM$(RTRIM$(TheName))
   IF INSTR(TheName, ",") THEN
     LastNameLen = INSTR(TheName, ",")
     LastName$ = LTRIM$(RTRIM$(LEFT$(TheName, LastNameLen - 1)))
     FirstName$ = LTRIM$(RTRIM$(MID$(TheName, LastNameLen + 1)))
     TransposeName$ = LTRIM$(RTRIM$(FirstName$ + " " + LastName$))
   ELSE
     FirstNameLen = INSTR(TheName, " ")
     IF FirstNameLen THEN
       FirstName$ = LTRIM$(RTRIM$(LEFT$(TheName, FirstNameLen - 1)))
       LastName$ = LTRIM$(RTRIM$(MID$(TheName, FirstNameLen + 1)))
     ELSE
       LastName$ = LTRIM$(RTRIM$(TheName))
     END IF
     TransposeName$ = LTRIM$(RTRIM$(LastName$ + ", " + FirstName$))
   END IF
 END FUNCTION

 '****************************** ValuesOK FUNCTION **************************
 '* The ValuesOK FUNCTION checks the values input by the user for various   *
 '* purposes. The checking is very minimal and checks the format of what is *
 '* entered. For example, the IDnum field needs a double value, but the form*
 '* (5 digits, followed by a decimal point, followed by 4 digits) is more   *
 '* important than the data type.                                           *
 '*                                Parameters:                              *
 '*   Big Rec      User-defined type containing all table information       *
 '*   Key1, Key2   Represent strings to check                               *
 '*   ValueToSeek  Represents the final value of a combined index           *
 '***************************************************************************
 FUNCTION ValuesOK (BigRec AS RecStruct, Key1$, Key2$, ValueToSeek$)
   IndexName$ = BigRec.WhichIndex
   ValueToSeek$ = LTRIM$(RTRIM$(ValueToSeek$))
   SELECT CASE RTRIM$(LTRIM$(IndexName$))
     CASE "TitleIndexBS", "PubIndexBS"       ' LEN <= 50
       IF LEN(Key1$) > 50 THEN ValuesOK = FALSE: EXIT FUNCTION

     CASE "AuthorIndexBS", "NameIndexCH"     ' LEN <= 36
       IF LEN(Key1$) > 36 THEN ValuesOK = FALSE: EXIT FUNCTION

     CASE "StateIndexCH"                     ' LEN = 2
       IF LEN(Key1$) > 2 THEN ValuesOK = FALSE: EXIT FUNCTION

     CASE "IDIndex", "IDIndexBO"             ' 5 digits befor d.p., 4 after
       IF LEN(ValueToSeek$) <> 10 THEN ValuesOK = FALSE: EXIT FUNCTION
       IF MID$(ValueToSeek$, 6, 1) <> "." THEN
         ValuesOK = FALSE: EXIT FUNCTION
       END IF
     CASE "CardNumIndexCH", "CardNumIndexBO" ' 5 digits, value <= LONG
       IF LEN(ValueToSeek$) <> 5 THEN ValuesOK = FALSE: EXIT FUNCTION

     CASE "ZipIndexCH"                       ' 5 digits, value <= LONG
       IF LEN(ValueToSeek$) <> 5 THEN ValuesOK = FALSE: EXIT FUNCTION

     CASE "BigIndex"                         ' Key1$ <= 50, Key2$ <= 36
       IF LEN(Key1$) > 50 THEN ValuesOK = FALSE: EXIT FUNCTION
       IF LEN(Key2$) > 36 THEN ValuesOK = FALSE: EXIT FUNCTION
       IF MID$(ValueToSeek$, 6, 1) <> "." THEN
         ValuesOK = FALSE: EXIT FUNCTION
       END IF
   END SELECT
   ValuesOK = TRUE
 END FUNCTION



 BOOKMOD3.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\BOOKMOD3.BAS

 '***************************************************************************
 '* This is module level code for BOOKMOD3.BAS, the fourth                  *
 '* module of BOOKLOOK.BAS.                                                 *
 '*                                                                         *
 '* The module contains a procedure, MakeOver, you can use to convert text  *
 '* files containing the right format and type of information for the tables*
 '* used by the BOOKLOOK program to a .MDB file. However, you need to call  *
 '* MakeOver from the Immediate Window, and in order for it to work, you    *
 '* must use the PROISAMD version of the TSR, because MakeOver needs the    *
 '* data dictionary functionality for creating indexes, etc.                *
 '* If you use the DTFMTER.QLB library functions you must include the files *
 '* DATIM.BI and FORMAT.BI at this level, using syntax as shown below.      *
 '***************************************************************************
 DEFINT A-Z
 '$INCLUDE: 'booklook.bi'

 '***************************************************************************
 '*  The BooksBorrowed SUB takes the CardNum in BooksOut associated with the*
 '*  currently displayed CardHolder, then looks up each book in BooksOut    *
 '*  assigned to that CardNum. Note that you can use SEEKoperand to find the*
 '*  first matching record, but thereafter you need to MOVENEXT and check   *
 '*  each succeeding record to see if the CardNum matches. When a match is  *
 '*  made, look up the IDnum in the BooksOut table and retrieve the title.  *
 '*  Put all the titles in the Titles array, then display with PeekWindow.  *
 '*                                   Parameters                            *
 '*  TablesRec   Structure containing information on all database tables    *
 '***************************************************************************
 SUB BooksBorrowed (TablesRec AS RecStruct)
         DIM Titles(50) AS STRING
         ' First, get the card number of the current record in Bookstock - the
         ' at the end of this procedure, restore that book
         IF LOF(cBooksOutTableNum) = 0 THEN EXIT SUB
         IF GETINDEX$(cBooksOutTableNum) <> "CardNumIndexBO" THEN
                 SETINDEX cBooksOutTableNum, "CardNumIndexBO"
         END IF
         RevName$ = TransposeName$(TablesRec.Lendee.TheName)
         SEEKEQ cBooksOutTableNum, TablesRec.Lendee.CardNum
          IF NOT EOF(cBooksOutTableNum) THEN
                 DO
                         RETRIEVE cBooksOutTableNum, TablesRec.OutBooks
                          IF TablesRec.OutBooks.CardNum = TablesRec.Lendee.Car
                                         IF GETINDEX$(cBookStockTableNum) <> "
                                                 SETINDEX cBookStockTableNum,
                                         END IF
                                         SEEKEQ cBookStockTableNum, TablesRec.
                                         IF NOT EOF(cBookStockTableNum) THEN
                                                 RETRIEVE cBookStockTableNum,
                                                 Titles(Index) = RTRIM$(Tables
                                                 ThisSize = LEN(RTRIM$(Titles(
                                                         IF ThisSize > Biggest
                                                                 Biggest = Thi
                                                         END IF
                                          Index = Index + 1
                                         END IF
                                 END IF
                 MOVENEXT cBooksOutTableNum
                 LOOP UNTIL EOF(cBooksOutTableNum)
         ELSE
                 Alert$ = RevName$ + " currently has no books checked out"
                 CALL ShowMessage(Alert$, 0)
         END IF
         IF Index <> 0 THEN
                 HeadMessage$ = " Books borrowed by " + RevName$ + " "
                 FootMessage$ = " Press a key to continue "
                 CALL PeekWindow(Titles(), HeadMessage$, FootMessage$, Biggest
                 CALL DrawTable(TablesRec.TableNum)
                 CALL ShowMessage(KEYSMESSAGE, 0)
         END IF
 END SUB

 '***************************************************************************
 '*  The BorrowBook SUB prompts the user to enter the name of the Cardholder*
 '*  who wants to borrow the book, then updates all the other tables accord-*
 '*  ingly. The name or cardnumber can be entered --- if conversion to a    *
 '*  number fails, the user entered a name. If the name isn't of the right  *
 '*  format, it is transposed to last-first, comma delimited. If no exact   *
 '*  match is found, the next best match is attempted and presented for the *
 '*  approval of the user.
 '*                                  Parameter                              *
 '*  TablesRec   RecStruct type variable holding current table information  *
 '***************************************************************************
 SUB BorrowBook (TablesRec AS RecStruct)

 DIM SaveBook AS RecStruct
 DIM PeekString(10) AS STRING

 Prompt$ = "Name or Card Number to Seek: "
 SaveBook = TablesRec                          ' Save book information
         ' Prompt user and catch keystroke
 CALL ShowMessage("Enter borrower cardnumber or name: ", 1)
 FirstChar = ASC(ReturnKey$)                   ' ReturnKey$ is a function
 IF FirstChar = ESCAPE THEN CALL ShowMessage("", 0): EXIT SUB
 Answer$ = MakeString$(FirstChar, Prompt$)
 IF FirstChar = ESCAPE THEN CALL ShowMessage("", 0): EXIT SUB
 NumToCheck& = VAL(Answer$)
 IF NumToCheck& = 0 THEN
         IF INSTR(Answer$, ",") = 0 THEN
                 StraightName$ = Answer$
                 Answer$ = TransposeName$(Answer$)
         ELSE
                 StraightName$ = TransposeName$(Answer$)
         END IF

         SETINDEX cCardHoldersTableNum, "NameIndexCH"
         SEEKEQ cCardHoldersTableNum, Answer$
         IF EOF(cCardHoldersTableNum) THEN
                 MOVEFIRST cCardHoldersTableNum
                 SEEKGE cCardHoldersTableNum, Answer$     ' If EQ fails, try G
                 IF EOF(cCardHoldersTableNum) THEN
                         Alert$ = "Sorry, couldn't find " + StraightName$ + "
                         CALL ShowMessage(Alert$, 0)
                         EXIT SUB
                 END IF
         END IF
         IF NOT EOF(cCardHoldersTableNum) THEN
                 RETRIEVE cCardHoldersTableNum, SaveBook.Lendee
                 IF TEXTCOMP(LEFT$(SaveBook.Lendee.TheName, 2), LEFT$(Answer$,
                         NumToCheck& = SaveBook.Lendee.CardNum
                 ELSE
                         Alert$ = "Sorry, couldn't match " + StraightName$ + "
                         CALL ShowMessage(Alert$, 0): ' SLEEP: EraseMessage
                         EXIT SUB
                 END IF
         END IF
 ELSE
         SETINDEX cCardHoldersTableNum, "CardNumIndexCH"
         SEEKEQ cCardHoldersTableNum, NumToCheck&
         IF EOF(cCardHoldersTableNum) THEN
                 Alert$ = "Sorry, could not match " + Answer$
                 CALL ShowMessage(Alert$, 0):  ' SLEEP: EraseMessage
                 EXIT SUB
         ELSE
                 RETRIEVE cCardHoldersTableNum, SaveBook.Lendee
                 NumToCheck& = SaveBook.Lendee.CardNum
         END IF
 END IF

 DateDue# = 32950#     ' the Date/Time library as shown on these 2 lines:
 'DateDue# = Now# + 30#
 'DateDue$ = STR$(Month&(DateDue#)) + "/" + LTRIM$(STR$(Day&(DateDue#))) + "/"

 ' Show the information on the Cardholder you found...
 DO
         PeekString(0) = " This book will be checked out to: "
         PeekString(1) = ""
         PeekString(2) = RTRIM$(SaveBook.Lendee.TheName)
         PeekString(3) = RTRIM$(SaveBook.Lendee.Street)
         PeekString(4) = RTRIM$(SaveBook.Lendee.City) + ", " + RTRIM$(SaveBook
         PeekString(5) = "Card number: " + STR$(SaveBook.Lendee.CardNum)
         PeekString(6) = ""
         PeekString(7) = "The Due Date will be " + STR$(DateDue# + 30)
         IF LEN(DateDue$) THEN PeekString(7) = "The Due Date will be " + DateD
         FOR Index = 0 TO 8
                 ThisSize = LEN(RTRIM$(PeekString(Index)))
                 IF ThisSize > Biggest THEN
                         Biggest = ThisSize
                 END IF
         NEXT Index

         HeadMessage$ = " Cardholder checking out this book "
         FootMessage$ = " Press ENTER to confirm this checkout "
         Alert$ = "Press N seek next similar match, ESC to abort checkout"
         CALL ShowMessage(Alert$, 0)
         CALL PeekWindow(PeekString(), HeadMessage$, FootMessage$, Biggest)

         ' Let the user press "N" to see the next best match, ESC to abort che
         ' anything else to confirm this as person to whom to check book out t

         Reply$ = ReturnKey$
         SELECT CASE Reply$
                 CASE CHR$(ESCAPE)
                         DoneFlag = TRUE
                 CASE "N", "n"
                         MOVENEXT cCardHoldersTableNum
                         IF EOF(cCardHoldersTableNum) THEN
                                 DoneFlag = TRUE
                         ELSE
                                 RETRIEVE cCardHoldersTableNum, SaveBook.Lende
                                 NumToCheck& = SaveBook.Lendee.CardNum
                                 IF LEFT$(SaveBook.Lendee.TheName, 2) <> LEFT$
                                         DoneFlag = TRUE
                                 END IF
                         END IF
                 CASE ELSE
                                 TablesRec.OutBooks.CardNum = NumToCheck&
                                 TablesRec.OutBooks.IDnum = SaveBook.Inventory
                                 TablesRec.OutBooks.DueDate = DateDue#
                                 DoneFlag = TRUE
                                 MOVEFIRST (cBooksOutTableNum)
                                 INSERT cBooksOutTableNum, TablesRec.OutBooks
                                 CALL ShowMessage("", 0)
         END SELECT
 LOOP UNTIL DoneFlag

 CALL DrawTable(TablesRec.TableNum)
 CALL ShowMessage(KEYSMESSAGE, 0)

 END SUB

 '**************************************************************************
 '*  The Borrowed FUNCTION simply makes sure there are records in the      *
 '*  BooksOut table. If there are none, a message is displayed             *
 '**************************************************************************
 FUNCTION Borrowed
         IF LOF(cBooksOutTableNum) = 0 THEN
                 CALL ShowMessage("Sorry, no records in the BooksOut table", 0
                 Borrowed = FALSE
         ELSE
                 Borrowed = TRUE
         END IF
 END FUNCTION

 '***************************************************************************
 '* The CatchKey function gets a keystroke and returns TRUE if it was ENTER,*
 '* otherwise it returns FALSE.                                             *
 '***************************************************************************
 FUNCTION CatchKey%
         DO
         Answer$ = INKEY$
         LOOP WHILE Answer$ = ""
         SELECT CASE ASC(Answer$)
                 CASE ENTER
                         CatchKey% = -1
                 CASE ELSE
                         CatchKey% = 0
         END SELECT
 END FUNCTION

 '***************************************************************************
 '*  The GetStatus FUNCTION looks up the status of a book in the BooksOut   *
 '*  table. If the SEEK fails it means the book isn't checked out, and that *
 '*  message is displayed. Otherwise, it is placed in DateToShow parameter. *
 '*  The final message about retrieving borrow info relates to LendeeProfile*
 '*                                   Parameters                            *
 '*  TablesRec     Structure containing the information about all the tables*
 '*  DateToShow    The due date to show in the ShowStatus SUB               *
 '***************************************************************************
 FUNCTION GetStatus (TablesRec AS RecStruct, DateToShow#)
                 IF GETINDEX$(cBooksOutTableNum) <> "IDIndexBO" THEN
                         SETINDEX cBooksOutTableNum, "IDIndexBO"
                 END IF
                 SEEKEQ cBooksOutTableNum, TablesRec.Inventory.IDnum
                 IF NOT EOF(cBooksOutTableNum) THEN
                         RETRIEVE cBooksOutTableNum, TablesRec.OutBooks
                 ELSE
                         Alert$ = "This book is not checked out"   ' the book
                         CALL ShowMessage(Alert$, 0)               ' table, so
                         DateToShow# = 0: GetStatus = FALSE
                         EXIT FUNCTION
                 END IF
                 DateToShow# = TablesRec.OutBooks.DueDate#
                 GetStatus = TRUE
 END FUNCTION

 '***************************************************************************
 '*  The LendeeProfile takes the IDnum of the currently displayed book, then*
 '*  looks that up in the BooksOut table and fetches the CardHolder record  *
 '*  that corresponds to the CardNum entry in BooksOut. Then the CardNum is *
 '*  looked up in the CardHolders table and the borrower information shown. *
 '*                                Parameters                               *
 '*  TablesRec   Contains information on all the tables in the database     *
 '***************************************************************************
 SUB LendeeProfile (TablesRec AS RecStruct)
         ' Make sure the CardHolders table actually has records
         IF LOF(cCardHoldersTableNum) = 0 THEN
                 CALL ShowMessage("Sorry, there are no cardholder records", 0)
                 EXIT SUB
         END IF
         ' Create an array to hold information from CardHolders table
         DIM LendeeInfo(10)  AS STRING
         ' Set the index if it is not the one you want
         IF GETINDEX$(cBooksOutTableNum) <> "IDIndexBO" THEN
                 SETINDEX cBooksOutTableNum, "IDIndexBO"
         END IF
         SEEKEQ cBooksOutTableNum, TablesRec.Inventory.IDnum    ' Seek the rec
         IF EOF(cBooksOutTableNum) THEN                         ' If you find
                 CALL ShowMessage("This book is not checked out", 0)  ' the bo
                 EXIT SUB                                             ' otherw
         ELSE                                                   ' If it's ther
                 RETRIEVE cBooksOutTableNum, TablesRec.OutBooks       ' fetch

                 ' If the CardNum exists, set an index in CardHolders and SEEK
                 ' CardNum. If SEEK fails, print a warning; if it succeeds, ge
                 ' information about the borrower, and display it using PeekWi

                 IF TablesRec.OutBooks.CardNum <> 0 THEN
                         IF GETINDEX$(cCardHoldersTableNum) <> "CardNumIndexCH
                                 SETINDEX cCardHoldersTableNum, "CardNumIndexC
                         END IF
                         SEEKEQ cCardHoldersTableNum, TablesRec.OutBooks.CardN
                         IF EOF(cBooksOutTableNum) THEN
                                 Alert$ = "Cardholder number associated with b
                                 CALL ShowMessage(Alert$, 0)
                                 EXIT SUB
                         ELSE
                                 RETRIEVE cCardHoldersTableNum, TablesRec.Lend
                                 LendeeInfo(0) = RTRIM$(TablesRec.Lendee.TheNa
                                 LendeeInfo(1) = ""
                                 LendeeInfo(2) = RTRIM$(TablesRec.Lendee.Stree
                                 LendeeInfo(3) = RTRIM$(TablesRec.Lendee.City)
                                 LendeeInfo(4) = RTRIM$(TablesRec.Lendee.State
                                 LendeeInfo(5) = LTRIM$(STR$(TablesRec.Lendee.
                                 LendeeInfo(7) = STR$(TablesRec.Lendee.CardNum
                                 LendeeInfo(6) = ""
                                 LendeeInfo(7) = "Card number: " + LendeeInfo(
                                 LendeeInfo(8) = ""
                                 FOR Index = 1 TO 6
                                         ThisBig = LEN(LendeeInfo(Index))
                                         IF ThisBig > BiggestYet THEN
                                                 BiggestYet = ThisBig
                                         END IF
                                 NEXT Index
                                 Alert$ = "Press V to access the record for th
                                 CALL ShowMessage(Alert$, 0)
                                 HeadMessage$ = "Borrower of this Book"
                                 FootMessage$ = "Press a key to clear box"
                                 CALL ClearEm(TablesRec.TableNum, 1, 1, 1, 1,
                                 CALL PeekWindow(LendeeInfo(), HeadMessage$, F
                                 CALL DrawTable(TablesRec.TableNum)
                                 CALL ShowMessage(KEYSMESSAGE, 0)
                         END IF
                 END IF
         END IF
 END SUB

 '***************************************************************************
 '* The MakeOver SUB lets the user input the names of properly formatted    *
 '* text files, then creates a database file of the same type as BOOKS.MDB. *
 '* There is also a prompt for the new database name. The text files must   *
 '* contain comma-delimited fields, with strings within double quote marks. *
 '* The last part of this SUB demonstrates how indexes are created. You need*
 '* to have loaded PROISAMD.EXE to run this procedure.                      *
 '*                            Parameters:                                  *
 '*   Big Rec      User-defined type containing all table information       *
 '***************************************************************************
 '
 SUB MakeOver (BigRec AS RecStruct)
         CLOSE
         Alert$ = "Type name of file containing Cardholders table data: "
         CALL ShowMessage(Alert$, 1)
         INPUT "", CardFile$
         Alert$ = "Type name of file containing BooksOut table data: "
         CALL ShowMessage(Alert$, 1)
         INPUT "", OutBooks$
         Alert$ = "Type name of file containing BookStock table data: "
         CALL ShowMessage(Alert$, 1)
         INPUT "", BookFile$
         Alert$ = "Type name of ISAM file to create: "
         CALL ShowMessage(Alert$, 1)
         INPUT "", IsamFile$
         IF UCASE$(IsamFile$) = "BOOKS.MDB" THEN KILL "BOOKS.MDB"
         CALL ShowMessage("Loading database...", 0)

         CLOSE
         ON LOCAL ERROR GOTO FileHandler
         LenFileNo% = 10
         OPEN CardFile$ FOR INPUT AS LenFileNo%
         OutFileNo% = 11
         OPEN OutBooks$ FOR INPUT AS OutFileNo%
         RecFileNo% = 12
         OPEN BookFile$ FOR INPUT AS RecFileNo%
         ON ERROR GOTO 0

         ' Open the database and the BookStock table
         OPEN IsamFile$ FOR ISAM Books "BookStock" AS cBookStockTableNum
         OPEN IsamFile$ FOR ISAM Borrowers "CardHolders" AS cCardHoldersTableN
         OPEN IsamFile$ FOR ISAM BookStatus "BooksOut" AS cBooksOutTableNum
         CALL ShowMessage(" Opened all isam tables", 0)

         SeqFile% = LenFileNo
         DO WHILE (Reader%(BigRec, SeqFile%))
          INSERT cCardHoldersTableNum, BigRec.Lendee
         LOOP
         SeqFile% = OutFileNo
         DO WHILE (Reader%(BigRec, SeqFile))
          INSERT cBooksOutTableNum, BigRec.OutBooks
         LOOP
         SeqFile = RecFileNo
         DO WHILE (Reader%(BigRec, SeqFile))
          INSERT cBookStockTableNum, BigRec.Inventory
         LOOP
         CALL ShowMessage("Finished reading in records---Indexes next", 0)
 ' These indexes are already in the BOOKS.MDB database --- the following
 ' is the syntax that was used to create them

         ON LOCAL ERROR GOTO FileHandler
         CREATEINDEX cBookStockTableNum, "TitleIndexBS", 0, "Title"
         CREATEINDEX cBookStockTableNum, "AuthorIndexBS", 0, "Author"
         CREATEINDEX cBookStockTableNum, "PubIndexBS", 0, "Publisher"
         CREATEINDEX cBookStockTableNum, "IDIndex", 1, "IDnum"     ' Note uniq
         CREATEINDEX cBookStockTableNum, "BigIndex", 0, "Title", "Author", "ID

         CREATEINDEX cBooksOutTableNum, "IDIndexBO", 0, "IDnum"
         CREATEINDEX cBooksOutTableNum, "CardNumIndexBO", 0, "CardNum"

         CREATEINDEX cCardHoldersTableNum, "NameIndexCH", 0, "TheName"
         CREATEINDEX cCardHoldersTableNum, "StateIndexCH", 0, "State"
         CREATEINDEX cCardHoldersTableNum, "ZipIndexCH", 0, "Zip"
         CREATEINDEX cCardHoldersTableNum, "CardNumIndexCH", 1, "CardNum"  ' U
         ON ERROR GOTO 0
         CALL ShowMessage(" All done with indexes...", 0)
         'CLOSE

         EXIT SUB

 FileHandler:
         IF ERR = 73 THEN
                 CALL ShowMessage("You need to Exit QBX and load PROISAMD /Ib:
         ELSEIF ERR = 10 THEN
                 Alert$ = "Finished appending the records to " + IsamFile$
                 CALL ShowMessage(Alert$, 0)
                 END
         ELSEIF ERR = 86 THEN
                 Alert$ = "Tried to add record with duplicate value on a uniqu
                 CALL ShowMessage(Alert$, 0)
                 ELSE
                 CALL ShowMessage("Can't find textfiles needed to make the dat
         END IF
         END
 END SUB

 '***************************************************************************
 '*  The PeekWindow SUB displays the elements of the OutBookNames array in  *
 '*  a window on top of the currently displayed table.                      *
 '*                                Parameters                               *
 '*  OutBookNames    Array of strings containing lines displayed in window  *
 '*  Header$         String to show at top of window                        *
 '*  Footer$         String to show at bottom of window                     *
 '*  BiggestYet      Length of the longest string to be shown               *
 '***************************************************************************
 SUB PeekWindow (OutBookNames() AS STRING, Header$, Footer$, BiggestYet%)
 HeadLen = LEN(Header$)        ' + 4
 FootLen = LEN(Footer$)        ' + 4
 IF HeadLen > FootLen THEN Bigger = HeadLen ELSE Bigger = FootLen
 IF Bigger > BiggestYet THEN BiggestYet = Bigger

 InnerBox = 9          ' InnerBox is total number of lines allowed inside box
 first = 0: last = 8
 DO

         ' Calculate header and footer placement

                 IF (HeadLen MOD 2) THEN
                         HeadStart = ((BiggestYet - HeadLen) \ 2) + 13
                 ELSE
                         HeadStart = ((BiggestYet - HeadLen) \ 2) + 12
                 END IF
                 IF (FootLen MOD 2) THEN
                         FootStart = ((BiggestYet - FootLen) \ 2) + 13
                 ELSE
                         FootStart = ((BiggestYet - FootLen) \ 2) + 12
                 END IF

                 ' Print a box and fill it with titles
                 Inset = TABLETOP + 2

                 Lines = Inset + 1
                 IF MoreBoxes = FALSE THEN
                         LOCATE Inset, 3
                         PRINT "       ╔"; STRING$(BiggestYet + 2, CHR$(205));
                 END IF
                 FOR PrintEm = first TO last
                         LOCATE Lines + NextSpace, 3
                         PRINT "       ║ "; OutBookNames(Total); SPACE$(Bigges
                         Total = Total + 1: NextSpace = NextSpace + 1
                 NEXT PrintEm
                 IF MoreBoxes = FALSE THEN                       ' Means first
                         LOCATE Lines + NextSpace, 3
                         PRINT "       ╚"; STRING$(BiggestYet + 2, CHR$(205));
                         COLOR BACKGROUND, FOREGROUND + BRIGHT
                         LOCATE Inset, HeadStart
                         PRINT Header$;                          '"╡ "; Header
                         LOCATE Lines + NextSpace, FootStart
                         PRINT Footer$                           '"╡ "; Footer
                         COLOR FOREGROUND, BACKGROUND
                 END IF
                 SLEEP
         first = first + InnerBox: last = last + InnerBox
         NextSpace = 0: HowMany = 0

         MoreBoxes = TRUE

 LOOP UNTIL LEN(RTRIM$(OutBookNames(Total))) = 0

 END SUB

 '***************************************************************************
 '*  The Reader FUNCTION reads specified text files and returns each line   *
 '*  as a separate record for the corresponding table.                      *
 '*                               Parameters                                *
 '*  BigRec    RecStruct variable containing information on tables          *
 '*  SeqFile   File number used to open the text file to be read
 '***************************************************************************
 FUNCTION Reader% (BigRec AS RecStruct, SeqFile%)
         SELECT CASE SeqFile
                 CASE 10
                         IF NOT EOF(SeqFile) THEN
                          INPUT #SeqFile, BigRec.Lendee.CardNum, BigRec.Lendee
                          Reader = -1
                         ELSE
                                 Reader = 0
                         END IF
                 CASE 11
                         IF NOT EOF(SeqFile) THEN
                          INPUT #SeqFile, BigRec.OutBooks.IDnum, BigRec.OutBoo
                          Reader = -1
                         ELSE
                          Reader = 0
                         END IF
                 CASE 12
                         IF NOT EOF(SeqFile) THEN
                                 INPUT #SeqFile, BigRec.Inventory.IDnum, BigRe
                                 Reader = -1
                          ELSE
                                 Reader = 0
                          END IF
         END SELECT
 END FUNCTION

 '***************************************************************************
 '*  The ReturnBook SUB checks the book currently being displayed back into *
 '*  the library --- that is, it eliminates the appropriate entry from the  *
 '*  BooksOut table. It checks to see if the book is overdue, and if so, it *
 '*  displays the amount of the fine to be paid.                            *
 '*                                Parameters                               *
 '*  TablesRec   RecStruct type variable holding current table information  *
 '***************************************************************************
 SUB ReturnBook (TablesRec AS RecStruct, DueDate#)

 DIM ReturnLines(10) AS STRING

 Alert$ = "Press ENTER to check current book in, N to abort checkin..."
 CALL ShowMessage(Alert$, 0)

 SETINDEX cBooksOutTableNum, "IDIndexBO"
 SEEKEQ cBooksOutTableNum, TablesRec.Inventory.IDnum
 IF NOT EOF(cBooksOutTableNum) THEN
         RETRIEVE cBooksOutTableNum, TablesRec.OutBooks
 END IF
 SETINDEX cCardHoldersTableNum, "CardNumIndexCH"
 SEEKEQ cCardHoldersTableNum, TablesRec.OutBooks.CardNum

 IF NOT EOF(cBooksOutTableNum) THEN
         IF LOF(cCardHoldersTableNum) THEN
                 RETRIEVE cCardHoldersTableNum, TablesRec.Lendee
         END IF
 END IF

 Today# = 32000    'Replace this with call to DTFMTER.QLB library routine
                                                                         'as s
 'Today# = Now#
 'ShowDate$ = STR$(Month&(Today#)) + "/" + LTRIM$(STR$(Day&(Today#))) + "/" +
 IF Today# > TablesRec.OutBooks.DueDate THEN
         Fine = Today# - TablesRec.OutBooks.DueDate
 END IF

 DateDue# = (TablesRec.OutBooks.DueDate)
 ' If you have DTFMTER.QLB loaded, use in to get date to display
 ' DateDue$ = STR$(Month&(DateDue#)) + "/" + LTRIM$(STR$(Day&(DateDue#))) + "/
 ReturnLines(0) = ""
 ReturnLines(1) = RTRIM$(TablesRec.Inventory.Title)
 ReturnLines(2) = "is checked out to card number: " + STR$(TablesRec.OutBooks.
 ReturnLines(3) = RTRIM$(TablesRec.Lendee.TheName)
 ReturnLines(4) = ""
 ReturnLines(5) = "Today's Date:     " + STR$(Today#) + " - A phoney date"
 IF LEN(ShowDate$) THEN ReturnLines(5) = "Today's Date:     " + ShowDate$
 ReturnLines(6) = "Due Date of Book: " + STR$(TablesRec.OutBooks.DueDate)
 IF LEN(DateDue$) THEN ReturnLines(6) = "Due Date of Book: " + DateDue$
 ReturnLines(7) = "Fine Payable:     $" + STR$(ABS(Fine / 100))
 ReturnLines(8) = ""
 ReturnLines(9) = ""
 FOR Index = 0 TO 10
         ThisOne = LEN(ReturnLines(Index))
         IF ThisOne > BiggestYet THEN BiggestYet = ThisOne
 NEXT Index
 Header$ = "Press ENTER to check book in..."
 Footer$ = "Press N or n to abort checkin..."
 CALL PeekWindow(ReturnLines(), Header$, Footer$, BiggestYet%)

 IF CatchKey THEN                              ' If user confirms, delete
         IF LOF(cBooksOutTableNum) <> 0 THEN         ' the entry to BooksOut t
                 DELETE cBooksOutTableNum
         END IF
 END IF
 CALL DrawTable(TablesRec.TableNum)
 CALL EraseMessage

 END SUB

 '***************************************************************************
 '* The ShowStatus SUB uses the due date associated with the book IDnum from*
 '* of the BooksOut table. This date is in serial form which is not decoded *
 '* here, but can be decoded with the date/time function library supplied   *
 '* with BASIC 7.0. The due date is displayed centered on the top line of   *
 '* the ShowMessage box.                                                    *
 '*                                Parameters                               *
 '*  Stat$       Message introducing the due date when displayed in its box *
 '*  ValueToShow The due date of the book from the BooksOut table           *
 '***************************************************************************
 SUB ShowStatus (Stat$, ValueToShow AS DOUBLE)

 COLOR FOREGROUND, BACKGROUND
 DataEndLine$ = STRING$(60, 205)       'redraw the bottom line

 StringToShow$ = Stat$       ' Figure out where to locate the text
 IF ValueToShow = 0 THEN
         LOCATE TABLEEND, 4
         PRINT DataEndLine$
         EXIT SUB
 ELSE
         ' The dates in the file are in serial form. Use the DTFMTER.QLB libra
         ' to decode serial dates for normal display. In the code below, the
         ' calls to the library are commented out.

         'TheDate$ = STR$(Month&(ValueToShow)) + "/" + LTRIM$(STR$(Day&(ValueT
         IF Stat$ = " Total records in table: " OR LEN(TheDate$) = 0 THEN
                 StringToShow$ = StringToShow$ + " " + STR$(ValueToShow)
         ELSE
                 StringToShow$ = StringToShow$ + " " + TheDate$
         END IF
         HowLong = LEN(StringToShow$)
         PlaceStatus = (73 \ 2) - (HowLong \ 2)
         StatusSpace$ = CHR$(181) + STRING$(HowLong, 32) + CHR$(198)
 END IF
 LOCATE TABLEEND, PlaceStatus
 PRINT StatusSpace$
 COLOR BACKGROUND, BRIGHT + FOREGROUND
 LOCATE TABLEEND, PlaceStatus + 1
 PRINT StringToShow$
 COLOR FOREGROUND, BACKGROUND

 END SUB



 CAL.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\CAL.BAS

 DEFINT A-Z      ' Default variable type is integer.

 ' Define a data type for the names of the months and the
 ' number of days in each:
 TYPE MonthType
         Number AS INTEGER  ' Number of days in the month
         MName AS STRING * 9   ' Name  of the month
 END TYPE

 ' Declare procedures used:
 DECLARE FUNCTION IsLeapYear% (N%)
 DECLARE FUNCTION GetInput% (Prompt$, Row%, LowVal%, HighVal%)

 DECLARE SUB PrintCalendar (Year%, Month%)
 DECLARE SUB ComputeMonth (Year%, Month%, StartDay%, TotalDays%)

 DIM MonthData(1 TO 12)   AS MonthType

 ' Initialize month definitions from DATA statements below:
 FOR I = 1 TO 12
         READ MonthData(I).MName, MonthData(I).Number
 NEXT

 ' Main loop, repeat for as many months as desired:
 DO
         CLS

         ' Get year and month as input:
         Year = GetInput("Year (1899 to 2099): ", 1, 1899, 2099)
         Month = GetInput("Month (1 to 12): ", 2, 1, 12)

         ' Print the calendar:
         PrintCalendar Year, Month
 ' Another Date?
         LOCATE 13, 1      ' Locate in 13th row, 1st column.
         PRINT "New Date? ";  ' Keep cursor on same line.
         LOCATE , , 1, 0, 13  ' Turn cursor on and make it one
                         ' character high.
         Resp$ = INPUT$(1) ' Wait for a key press.
         PRINT Resp$    ' Print  the key  pressed.

 LOOP WHILE UCASE$(Resp$) = "Y"
 END

 ' Data for the months of a year:
 DATA January, 31, February, 28,  March, 31
 DATA April, 30,   May, 31, June, 30, July, 31, August, 31
 DATA September,   30, October, 31, November, 30, December, 31

 ' ====================== COMPUTEMONTH =====================
 '  Computes the first day and the total days in a month
 ' =========================================================
 '
 SUB ComputeMonth (Year, Month, StartDay, TotalDays) STATIC
         SHARED MonthData() AS MonthType

         CONST LEAP = 366 MOD 7
         CONST NORMAL = 365 MOD 7

         ' Calculate total number of days (NumDays) since 1/1/1899:

         ' Start with whole years:
         NumDays = 0
         FOR I = 1899 TO Year - 1
                 IF IsLeapYear(I) THEN              ' If leap year,
                         NumDays = NumDays + LEAP   ' add 366 MOD 7.
                 ELSE                               ' If normal year,
                         NumDays = NumDays + NORMAL ' add 365 MOD 7.
                 END IF
         NEXT

         ' Next, add in days from whole months:
         FOR I = 1 TO Month - 1
                 NumDays = NumDays + MonthData(I).Number
         NEXT

         ' Set the number of days in the requested month:
         TotalDays = MonthData(Month).Number

         ' Compensate if requested year is a leap year:
         IF IsLeapYear(Year) THEN

                 ' If after February, add one to total days:
                 IF Month > 2 THEN
                         NumDays = NumDays + 1

                 ' If February, add one to the month's days:
                 ELSEIF Month = 2 THEN
                         TotalDays = TotalDays + 1
                 END IF
         END IF

         ' 1/1/1899 was a Sunday, so calculating "NumDays MOD 7"
         ' gives the day of week (Sunday = 0, Monday = 1, Tuesday
         ' = 2, and so on) for the first day of the input month:
         StartDay = NumDays MOD 7
 END SUB

 ' ======================== GETINPUT =======================
 '  Prompts for input, then tests for a valid range
 ' =========================================================
 '
 FUNCTION GetInput (Prompt$, Row, LowVal, HighVal) STATIC

         ' Locate prompt at specified row, turn cursor on and
         ' make it one character high:
         LOCATE Row, 1, 1, 0, 13
         PRINT Prompt$;

         ' Save column position:
         Column = POS(0)

         ' Input value until it's within range:
         DO
                 LOCATE Row, Column   ' Locate cursor at end of prompt.
                 PRINT SPACE$(10)     ' Erase anything already there.
                 LOCATE Row, Column   ' Relocate cursor at end of prompt.
                 INPUT "", Value      ' Input value with no prompt.
         LOOP WHILE (Value < LowVal OR Value > HighVal)

         ' Return valid input as value of function:
         GetInput = Value

 END FUNCTION

 ' ====================== ISLEAPYEAR =======================
 '   Determines if a year is a leap year or not
 ' =========================================================
 '
 FUNCTION IsLeapYear (N) STATIC

         ' If the year is evenly divisible by 4 and not divisible
         ' by 100, or if the year is evenly divisible by 400,
         ' then it's a leap year:
         IsLeapYear = (N MOD 4 = 0 AND N MOD 100 <> 0) OR (N MOD 400 = 0)
 END FUNCTION

 ' ===================== PRINTCALENDAR =====================
 '   Prints a formatted calendar given the year and month
 ' =========================================================
 '
 SUB PrintCalendar (Year, Month) STATIC
 SHARED MonthData() AS MonthType

         ' Compute starting day (Su M Tu ...)
         ' and total days for the month:
         ComputeMonth Year, Month, StartDay, TotalDays
         CLS
         Header$ = RTRIM$(MonthData(Month).MName) + "," + STR$(Year)

         ' Calculate location for centering month and year:
         LeftMargin = (35 - LEN(Header$)) \ 2
 ' Print header:
         PRINT TAB(LeftMargin); Header$
         PRINT
         PRINT "Su    M   Tu    W   Th    F   Sa"
         PRINT

         ' Recalculate and print tab
         ' to the first day of the month (Su M Tu ...):
         LeftMargin = 5 * StartDay + 1
         PRINT TAB(LeftMargin);

         ' Print out the days of the month:
         FOR I = 1 TO TotalDays
                 PRINT USING "##_   "; I;

                 ' Advance to the next line
                 ' when the cursor is past column 32:
                 IF POS(0) > 32 THEN PRINT
         NEXT

 END SUB



 CHECK.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\CHECK.BAS

 DIM Amount(1 TO 100) AS CURRENCY, Balance AS CURRENCY
 CONST FALSE = 0, TRUE = NOT FALSE
 CLS
 ' Get account's starting balance:
 INPUT "Type starting balance, then press <ENTER>: ", Balance
 ' Get transactions. Continue accepting input
 ' until the input is zero for a transaction,
 ' or until 100 transactions have been entered:
 FOR TransacNum% = 1 TO 100
    PRINT TransacNum%;
    PRINT ") Enter transaction amount (0 to end): ";
    INPUT "", Amount(TransacNum%)
    IF Amount(TransacNum%) = 0 THEN
       TransacNum% = TransacNum% - 1
       EXIT FOR
    END IF
 NEXT

 ' Sort transactions in ascending order,
 ' using a "bubble sort":
 Limit% = TransacNum%
 DO
    Swaps% = FALSE
    FOR I% = 1 TO (Limit% - 1)
       ' If two adjacent elements are out of order,
       ' switch those elements:
       IF Amount(I%) < Amount(I% + 1) THEN
          SWAP Amount(I%), Amount(I% + 1)
          Swaps% = I%
       END IF
    NEXT I%
   ' Sort on next pass only to where last switch was made:
   Limit% = Swaps%

 ' Sort until no elements are exchanged:
 LOOP WHILE Swaps%
 ' Print the sorted transaction array. If a transaction
 ' is greater than zero, print it as a "CREDIT"; if a
 ' transaction is less than zero, print it as a "DEBIT":
 FOR I% = 1 TO TransacNum%
    IF Amount(I%) > 0 THEN
       PRINT USING "CREDIT: $$#####.##"; Amount(I%)
    ELSEIF Amount(I%) < 0 THEN
       PRINT USING "DEBIT: $$#####.##"; Amount(I%)
    END IF
    ' Update balance:
    Balance = Balance + Amount(I%)
 NEXT I%
 ' Print the final balance:
 PRINT
 PRINT "--------------------------"
 PRINT USING "Final Balance: $$######.##"; Balance
 END



 CHRTASM.ASM
 CD-ROM Disc Path:   \SAMPCODE\BASIC\CHRTASM.ASM

 .MODEL medium
 ;********************************************************
 ;CHRTASM.ASM - assembly routines for the BASIC chart toolbox
 ;
 ;  Copyright (C) 1989 Microsoft Corporation, All Rights Reserved
 ;
 ;   DefaultFont - provides the segment:offset address for
 ;                  the default font
 ;
 ;********************************************************

 .FARDATA
 _IBM8_def label byte

       db   000h,000h,07Eh,00Ch,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,008h,000h,030h,000h
       db   060h,000h,007h,000h,000h,000h,000h,000h
       db   000h,000h,000h,090h,001h,000h,008h,000h
       db   008h,000h,000h,008h,000h,008h,000h,000h
       db   0FFh,02Eh,020h,0FFh,000h,000h,000h,000h
       db   000h,07Ah,004h,000h,000h,000h,000h,000h
       db   000h,07Eh,004h,000h,000h,000h,008h,000h
       db   07Eh,004h,008h,000h,086h,004h,008h,000h
       db   08Eh,004h,008h,000h,096h,004h,008h,000h
       db   09Eh,004h,008h,000h,0A6h,004h,008h,000h
       db   0AEh,004h,008h,000h,0B6h,004h,008h,000h
       db   0BEh,004h,008h,000h,0C6h,004h,008h,000h
       db   0CEh,004h,008h,000h,0D6h,004h,008h,000h
       db   0DEh,004h,008h,000h,0E6h,004h,008h,000h
       db   0EEh,004h,008h,000h,0F6h,004h,008h,000h
       db   0FEh,004h,008h,000h,006h,005h,008h,000h
       db   00Eh,005h,008h,000h,016h,005h,008h,000h
       db   01Eh,005h,008h,000h,026h,005h,008h,000h
       db   02Eh,005h,008h,000h,036h,005h,008h,000h
       db   03Eh,005h,008h,000h,046h,005h,008h,000h
       db   04Eh,005h,008h,000h,056h,005h,008h,000h
       db   05Eh,005h,008h,000h,066h,005h,008h,000h
       db   06Eh,005h,008h,000h,076h,005h,008h,000h
       db   07Eh,005h,008h,000h,086h,005h,008h,000h
       db   08Eh,005h,008h,000h,096h,005h,008h,000h
       db   09Eh,005h,008h,000h,0A6h,005h,008h,000h
       db   0AEh,005h,008h,000h,0B6h,005h,008h,000h
       db   0BEh,005h,008h,000h,0C6h,005h,008h,000h
       db   0CEh,005h,008h,000h,0D6h,005h,008h,000h
       db   0DEh,005h,008h,000h,0E6h,005h,008h,000h
       db   0EEh,005h,008h,000h,0F6h,005h,008h,000h
       db   0FEh,005h,008h,000h,006h,006h,008h,000h
       db   00Eh,006h,008h,000h,016h,006h,008h,000h
       db   01Eh,006h,008h,000h,026h,006h,008h,000h
       db   02Eh,006h,008h,000h,036h,006h,008h,000h
       db   03Eh,006h,008h,000h,046h,006h,008h,000h
       db   04Eh,006h,008h,000h,056h,006h,008h,000h
       db   05Eh,006h,008h,000h,066h,006h,008h,000h
       db   06Eh,006h,008h,000h,076h,006h,008h,000h
       db   07Eh,006h,008h,000h,086h,006h,008h,000h
       db   08Eh,006h,008h,000h,096h,006h,008h,000h
       db   09Eh,006h,008h,000h,0A6h,006h,008h,000h
       db   0AEh,006h,008h,000h,0B6h,006h,008h,000h
       db   0BEh,006h,008h,000h,0C6h,006h,008h,000h
       db   0CEh,006h,008h,000h,0D6h,006h,008h,000h
       db   0DEh,006h,008h,000h,0E6h,006h,008h,000h
       db   0EEh,006h,008h,000h,0F6h,006h,008h,000h
       db   0FEh,006h,008h,000h,006h,007h,008h,000h
       db   00Eh,007h,008h,000h,016h,007h,008h,000h
       db   01Eh,007h,008h,000h,026h,007h,008h,000h
       db   02Eh,007h,008h,000h,036h,007h,008h,000h
       db   03Eh,007h,008h,000h,046h,007h,008h,000h
       db   04Eh,007h,008h,000h,056h,007h,008h,000h
       db   05Eh,007h,008h,000h,066h,007h,008h,000h
       db   06Eh,007h,008h,000h,076h,007h,008h,000h
       db   07Eh,007h,008h,000h,086h,007h,008h,000h
       db   08Eh,007h,008h,000h,096h,007h,008h,000h
       db   09Eh,007h,008h,000h,0A6h,007h,008h,000h
       db   0AEh,007h,008h,000h,0B6h,007h,008h,000h
       db   0BEh,007h,008h,000h,0C6h,007h,008h,000h
       db   0CEh,007h,008h,000h,0D6h,007h,008h,000h
       db   0DEh,007h,008h,000h,0E6h,007h,008h,000h
       db   0EEh,007h,008h,000h,0F6h,007h,008h,000h
       db   0FEh,007h,008h,000h,006h,008h,008h,000h
       db   00Eh,008h,008h,000h,016h,008h,008h,000h
       db   01Eh,008h,008h,000h,026h,008h,008h,000h
       db   02Eh,008h,008h,000h,036h,008h,008h,000h
       db   03Eh,008h,008h,000h,046h,008h,008h,000h
       db   04Eh,008h,008h,000h,056h,008h,008h,000h
       db   05Eh,008h,008h,000h,066h,008h,008h,000h
       db   06Eh,008h,008h,000h,076h,008h,008h,000h
       db   07Eh,008h,008h,000h,086h,008h,008h,000h
       db   08Eh,008h,008h,000h,096h,008h,008h,000h
       db   09Eh,008h,008h,000h,0A6h,008h,008h,000h
       db   0AEh,008h,008h,000h,0B6h,008h,008h,000h
       db   0BEh,008h,008h,000h,0C6h,008h,008h,000h
       db   0CEh,008h,008h,000h,0D6h,008h,008h,000h
       db   0DEh,008h,008h,000h,0E6h,008h,008h,000h
       db   0EEh,008h,008h,000h,0F6h,008h,008h,000h
       db   0FEh,008h,008h,000h,006h,009h,008h,000h
       db   00Eh,009h,008h,000h,016h,009h,008h,000h
       db   01Eh,009h,008h,000h,026h,009h,008h,000h
       db   02Eh,009h,008h,000h,036h,009h,008h,000h
       db   03Eh,009h,008h,000h,046h,009h,008h,000h
       db   04Eh,009h,008h,000h,056h,009h,008h,000h
       db   05Eh,009h,008h,000h,066h,009h,008h,000h
       db   06Eh,009h,008h,000h,076h,009h,008h,000h
       db   07Eh,009h,008h,000h,086h,009h,008h,000h
       db   08Eh,009h,008h,000h,096h,009h,008h,000h
       db   09Eh,009h,008h,000h,0A6h,009h,008h,000h
       db   0AEh,009h,008h,000h,0B6h,009h,008h,000h
       db   0BEh,009h,008h,000h,0C6h,009h,008h,000h
       db   0CEh,009h,008h,000h,0D6h,009h,008h,000h
       db   0DEh,009h,008h,000h,0E6h,009h,008h,000h
       db   0EEh,009h,008h,000h,0F6h,009h,008h,000h
       db   0FEh,009h,008h,000h,006h,00Ah,008h,000h
       db   00Eh,00Ah,008h,000h,016h,00Ah,008h,000h
       db   01Eh,00Ah,008h,000h,026h,00Ah,008h,000h
       db   02Eh,00Ah,008h,000h,036h,00Ah,008h,000h
       db   03Eh,00Ah,008h,000h,046h,00Ah,008h,000h
       db   04Eh,00Ah,008h,000h,056h,00Ah,008h,000h
       db   05Eh,00Ah,008h,000h,066h,00Ah,008h,000h
       db   06Eh,00Ah,008h,000h,076h,00Ah,008h,000h
       db   07Eh,00Ah,008h,000h,086h,00Ah,008h,000h
       db   08Eh,00Ah,008h,000h,096h,00Ah,008h,000h
       db   09Eh,00Ah,008h,000h,0A6h,00Ah,008h,000h
       db   0AEh,00Ah,008h,000h,0B6h,00Ah,008h,000h
       db   0BEh,00Ah,008h,000h,0C6h,00Ah,008h,000h
       db   0CEh,00Ah,008h,000h,0D6h,00Ah,008h,000h
       db   0DEh,00Ah,008h,000h,0E6h,00Ah,008h,000h
       db   0EEh,00Ah,008h,000h,0F6h,00Ah,008h,000h
       db   0FEh,00Ah,008h,000h,006h,00Bh,008h,000h
       db   00Eh,00Bh,008h,000h,016h,00Bh,008h,000h
       db   01Eh,00Bh,008h,000h,026h,00Bh,008h,000h
       db   02Eh,00Bh,008h,000h,036h,00Bh,008h,000h
       db   03Eh,00Bh,008h,000h,046h,00Bh,008h,000h
       db   04Eh,00Bh,008h,000h,056h,00Bh,008h,000h
       db   05Eh,00Bh,008h,000h,066h,00Bh,008h,000h
       db   06Eh,00Bh,008h,000h,076h,00Bh,008h,000h
       db   07Eh,00Bh,008h,000h,086h,00Bh,008h,000h
       db   08Eh,00Bh,008h,000h,096h,00Bh,008h,000h
       db   09Eh,00Bh,008h,000h,0A6h,00Bh,008h,000h
       db   0AEh,00Bh,008h,000h,0B6h,00Bh,008h,000h
       db   0BEh,00Bh,008h,000h,0C6h,00Bh,008h,000h
       db   0CEh,00Bh,008h,000h,0D6h,00Bh,008h,000h
       db   0DEh,00Bh,008h,000h,0E6h,00Bh,008h,000h
       db   0EEh,00Bh,008h,000h,0F6h,00Bh,008h,000h
       db   0FEh,00Bh,008h,000h,006h,00Ch,008h,000h
       db   00Eh,00Ch,008h,000h,016h,00Ch,008h,000h
       db   01Eh,00Ch,008h,000h,026h,00Ch,008h,000h
       db   02Eh,00Ch,008h,000h,036h,00Ch,008h,000h
       db   03Eh,00Ch,008h,000h,046h,00Ch,008h,000h
       db   04Eh,00Ch,008h,000h,056h,00Ch,008h,000h
       db   05Eh,00Ch,008h,000h,066h,00Ch,008h,000h
       db   06Eh,00Ch,008h,000h,076h,00Ch,008h,000h
       db   07Eh,005h,049h,042h,04Dh,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,07Eh,081h
       db   0A5h,081h,0BDh,099h,081h,07Eh,07Eh,0FFh
       db   0DBh,0FFh,0C3h,0E7h,0FFh,07Eh,06Ch,0FEh
       db   0FEh,0FEh,07Ch,038h,010h,000h,010h,038h
       db   07Ch,0FEh,07Ch,038h,010h,000h,038h,07Ch
       db   038h,0FEh,0FEh,07Ch,038h,07Ch,010h,010h
       db   038h,07Ch,0FEh,07Ch,038h,07Ch,010h,010h
       db   038h,07Ch,0FEh,07Ch,038h,07Ch,0FFh,0FFh
       db   0E7h,0C3h,0C3h,0E7h,0FFh,0FFh,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,07Fh,063h
       db   07Fh,063h,063h,067h,0E6h,0C0h,099h,05Ah
       db   03Ch,0E7h,0E7h,03Ch,05Ah,099h,080h,0E0h
       db   0F8h,0FEh,0F8h,0E0h,080h,000h,002h,00Eh
       db   03Eh,0FEh,03Eh,00Eh,002h,000h,018h,03Ch
       db   07Eh,018h,018h,07Eh,03Ch,018h,066h,066h
       db   066h,066h,066h,000h,066h,000h,07Fh,0DBh
       db   0DBh,07Bh,01Bh,01Bh,01Bh,000h,03Eh,063h
       db   038h,06Ch,06Ch,038h,0CCh,078h,000h,000h
       db   000h,000h,07Eh,07Eh,07Eh,000h,018h,03Ch
       db   07Eh,018h,07Eh,03Ch,018h,0FFh,018h,03Ch
       db   07Eh,018h,018h,018h,018h,000h,018h,018h
       db   018h,018h,07Eh,03Ch,018h,000h,000h,018h
       db   00Ch,0FEh,00Ch,018h,000h,000h,000h,030h
       db   060h,0FEh,060h,030h,000h,000h,000h,030h
       db   060h,0FEh,060h,030h,000h,000h,000h,030h
       db   060h,0FEh,060h,030h,000h,000h,000h,030h
       db   060h,0FEh,060h,030h,000h,000h,000h,030h
       db   060h,0FEh,060h,030h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h,030h,078h
       db   078h,030h,030h,000h,030h,000h,06Ch,06Ch
       db   06Ch,000h,000h,000h,000h,000h,06Ch,06Ch
       db   0FEh,06Ch,0FEh,06Ch,06Ch,000h,030h,07Ch
       db   0C0h,078h,00Ch,0F8h,030h,000h,000h,0C6h
       db   0CCh,018h,030h,066h,0C6h,000h,038h,06Ch
       db   038h,076h,0DCh,0CCh,076h,000h,060h,060h
       db   0C0h,000h,000h,000h,000h,000h,018h,030h
       db   060h,060h,060h,030h,018h,000h,060h,030h
       db   018h,018h,018h,030h,060h,000h,000h,066h
       db   03Ch,0FFh,03Ch,066h,000h,000h,000h,030h
       db   030h,0FCh,030h,030h,000h,000h,000h,000h
       db   000h,000h,000h,030h,030h,060h,000h,000h
       db   000h,0FCh,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,030h,030h,000h,006h,00Ch
       db   018h,030h,060h,0C0h,080h,000h,07Ch,0C6h
       db   0CEh,0DEh,0F6h,0E6h,07Ch,000h,030h,070h
       db   030h,030h,030h,030h,0FCh,000h,078h,0CCh
       db   00Ch,038h,060h,0CCh,0FCh,000h,078h,0CCh
       db   00Ch,038h,00Ch,0CCh,078h,000h,01Ch,03Ch
       db   06Ch,0CCh,0FEh,00Ch,01Eh,000h,0FCh,0C0h
       db   0F8h,00Ch,00Ch,0CCh,078h,000h,038h,060h
       db   0C0h,0F8h,0CCh,0CCh,078h,000h,0FCh,0CCh
       db   00Ch,018h,030h,030h,030h,000h,078h,0CCh
       db   0CCh,078h,0CCh,0CCh,078h,000h,078h,0CCh
       db   0CCh,07Ch,00Ch,018h,070h,000h,000h,030h
       db   030h,000h,000h,030h,030h,000h,000h,030h
       db   030h,000h,000h,030h,030h,060h,018h,030h
       db   060h,0C0h,060h,030h,018h,000h,000h,000h
       db   0FCh,000h,000h,0FCh,000h,000h,060h,030h
       db   018h,00Ch,018h,030h,060h,000h,078h,0CCh
       db   00Ch,018h,030h,000h,030h,000h,07Ch,0C6h
       db   0DEh,0DEh,0DEh,0C0h,078h,000h,030h,078h
       db   0CCh,0CCh,0FCh,0CCh,0CCh,000h,0FCh,066h
       db   066h,07Ch,066h,066h,0FCh,000h,03Ch,066h
       db   0C0h,0C0h,0C0h,066h,03Ch,000h,0F8h,06Ch
       db   066h,066h,066h,06Ch,0F8h,000h,0FEh,062h
       db   068h,078h,068h,062h,0FEh,000h,0FEh,062h
       db   068h,078h,068h,060h,0F0h,000h,03Ch,066h
       db   0C0h,0C0h,0CEh,066h,03Eh,000h,0CCh,0CCh
       db   0CCh,0FCh,0CCh,0CCh,0CCh,000h,078h,030h
       db   030h,030h,030h,030h,078h,000h,01Eh,00Ch
       db   00Ch,00Ch,0CCh,0CCh,078h,000h,0E6h,066h
       db   06Ch,078h,06Ch,066h,0E6h,000h,0F0h,060h
       db   060h,060h,062h,066h,0FEh,000h,0C6h,0EEh
       db   0FEh,0FEh,0D6h,0C6h,0C6h,000h,0C6h,0E6h
       db   0F6h,0DEh,0CEh,0C6h,0C6h,000h,038h,06Ch
       db   0C6h,0C6h,0C6h,06Ch,038h,000h,0FCh,066h
       db   066h,07Ch,060h,060h,0F0h,000h,078h,0CCh
       db   0CCh,0CCh,0DCh,078h,01Ch,000h,0FCh,066h
       db   066h,07Ch,06Ch,066h,0E6h,000h,078h,0CCh
       db   0E0h,070h,01Ch,0CCh,078h,000h,0FCh,0B4h
       db   030h,030h,030h,030h,078h,000h,0CCh,0CCh
       db   0CCh,0CCh,0CCh,0CCh,0FCh,000h,0CCh,0CCh
       db   0CCh,0CCh,0CCh,078h,030h,000h,0C6h,0C6h
       db   0C6h,0D6h,0FEh,0EEh,0C6h,000h,0C6h,0C6h
       db   06Ch,038h,038h,06Ch,0C6h,000h,0CCh,0CCh
       db   0CCh,078h,030h,030h,078h,000h,0FEh,0C6h
       db   08Ch,018h,032h,066h,0FEh,000h,078h,060h
       db   060h,060h,060h,060h,078h,000h,0C0h,060h
       db   030h,018h,00Ch,006h,002h,000h,078h,018h
       db   018h,018h,018h,018h,078h,000h,010h,038h
       db   06Ch,0C6h,000h,000h,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,0FFh,030h,030h
       db   018h,000h,000h,000h,000h,000h,000h,000h
       db   078h,00Ch,07Ch,0CCh,076h,000h,0E0h,060h
       db   060h,07Ch,066h,066h,0DCh,000h,000h,000h
       db   078h,0CCh,0C0h,0CCh,078h,000h,01Ch,00Ch
       db   00Ch,07Ch,0CCh,0CCh,076h,000h,000h,000h
       db   078h,0CCh,0FCh,0C0h,078h,000h,038h,06Ch
       db   060h,0F0h,060h,060h,0F0h,000h,000h,000h
       db   076h,0CCh,0CCh,07Ch,00Ch,0F8h,0E0h,060h
       db   06Ch,076h,066h,066h,0E6h,000h,030h,000h
       db   070h,030h,030h,030h,078h,000h,00Ch,000h
       db   00Ch,00Ch,00Ch,0CCh,0CCh,078h,0E0h,060h
       db   066h,06Ch,078h,06Ch,0E6h,000h,070h,030h
       db   030h,030h,030h,030h,078h,000h,000h,000h
       db   0CCh,0FEh,0FEh,0D6h,0C6h,000h,000h,000h
       db   0F8h,0CCh,0CCh,0CCh,0CCh,000h,000h,000h
       db   078h,0CCh,0CCh,0CCh,078h,000h,000h,000h
       db   0DCh,066h,066h,07Ch,060h,0F0h,000h,000h
       db   076h,0CCh,0CCh,07Ch,00Ch,01Eh,000h,000h
       db   0DCh,076h,066h,060h,0F0h,000h,000h,000h
       db   07Ch,0C0h,078h,00Ch,0F8h,000h,010h,030h
       db   07Ch,030h,030h,034h,018h,000h,000h,000h
       db   0CCh,0CCh,0CCh,0CCh,076h,000h,000h,000h
       db   0CCh,0CCh,0CCh,078h,030h,000h,000h,000h
       db   0C6h,0D6h,0FEh,0FEh,06Ch,000h,000h,000h
       db   0C6h,06Ch,038h,06Ch,0C6h,000h,000h,000h
       db   0CCh,0CCh,0CCh,07Ch,00Ch,0F8h,000h,000h
       db   0FCh,098h,030h,064h,0FCh,000h,01Ch,030h
       db   030h,0E0h,030h,030h,01Ch,000h,018h,018h
       db   018h,000h,018h,018h,018h,000h,0E0h,030h
       db   030h,01Ch,030h,030h,0E0h,000h,076h,0DCh
       db   000h,000h,000h,000h,000h,000h,000h,010h
       db   038h,06Ch,0C6h,0C6h,0FEh,000h,078h,0CCh
       db   0C0h,0CCh,078h,018h,00Ch,078h,000h,0CCh
       db   000h,0CCh,0CCh,0CCh,07Eh,000h,01Ch,000h
       db   078h,0CCh,0FCh,0C0h,078h,000h,07Eh,0C3h
       db   03Ch,006h,03Eh,066h,03Fh,000h,0CCh,000h
       db   078h,00Ch,07Ch,0CCh,07Eh,000h,0E0h,000h
       db   078h,00Ch,07Ch,0CCh,07Eh,000h,030h,030h
       db   078h,00Ch,07Ch,0CCh,07Eh,000h,000h,000h
       db   078h,0C0h,0C0h,078h,00Ch,038h,07Eh,0C3h
       db   03Ch,066h,07Eh,060h,03Ch,000h,0CCh,000h
       db   078h,0CCh,0FCh,0C0h,078h,000h,0E0h,000h
       db   078h,0CCh,0FCh,0C0h,078h,000h,0CCh,000h
       db   070h,030h,030h,030h,078h,000h,07Ch,0C6h
       db   038h,018h,018h,018h,03Ch,000h,0E0h,000h
       db   070h,030h,030h,030h,078h,000h,0C6h,038h
       db   06Ch,0C6h,0FEh,0C6h,0C6h,000h,030h,030h
       db   000h,078h,0CCh,0FCh,0CCh,000h,01Ch,000h
       db   0FCh,060h,078h,060h,0FCh,000h,000h,000h
       db   07Fh,00Ch,07Fh,0CCh,07Fh,000h,03Eh,06Ch
       db   0CCh,0FEh,0CCh,0CCh,0CEh,000h,078h,0CCh
       db   000h,078h,0CCh,0CCh,078h,000h,000h,0CCh
       db   000h,078h,0CCh,0CCh,078h,000h,000h,0E0h
       db   000h,078h,0CCh,0CCh,078h,000h,078h,0CCh
       db   000h,0CCh,0CCh,0CCh,07Eh,000h,000h,0E0h
       db   000h,0CCh,0CCh,0CCh,07Eh,000h,000h,0CCh
       db   000h,0CCh,0CCh,07Ch,00Ch,0F8h,0C3h,018h
       db   03Ch,066h,066h,03Ch,018h,000h,0CCh,000h
       db   0CCh,0CCh,0CCh,0CCh,078h,000h,018h,018h
       db   07Eh,0C0h,0C0h,07Eh,018h,018h,038h,06Ch
       db   064h,0F0h,060h,0E6h,0FCh,000h,0CCh,0CCh
       db   078h,0FCh,030h,0FCh,030h,030h,0F8h,0CCh
       db   0CCh,0FAh,0C6h,0CFh,0C6h,0C7h,00Eh,01Bh
       db   018h,03Ch,018h,018h,0D8h,070h,01Ch,000h
       db   078h,00Ch,07Ch,0CCh,07Eh,000h,038h,000h
       db   070h,030h,030h,030h,078h,000h,000h,01Ch
       db   000h,078h,0CCh,0CCh,078h,000h,000h,01Ch
       db   000h,0CCh,0CCh,0CCh,07Eh,000h,000h,0F8h
       db   000h,0F8h,0CCh,0CCh,0CCh,000h,0FCh,000h
       db   0CCh,0ECh,0FCh,0DCh,0CCh,000h,03Ch,06Ch
       db   06Ch,03Eh,000h,07Eh,000h,000h,038h,06Ch
       db   06Ch,038h,000h,07Ch,000h,000h,030h,000h
       db   030h,060h,0C0h,0CCh,078h,000h,000h,000h
       db   000h,0FCh,0C0h,0C0h,000h,000h,000h,000h
       db   000h,0FCh,00Ch,00Ch,000h,000h,0C3h,0C6h
       db   0CCh,0DEh,033h,066h,0CCh,00Fh,0C3h,0C6h
       db   0CCh,0DBh,037h,06Fh,0CFh,003h,018h,018h
       db   000h,018h,018h,018h,018h,000h,000h,033h
       db   066h,0CCh,066h,033h,000h,000h,000h,0CCh
       db   066h,033h,066h,0CCh,000h,000h,022h,088h
       db   022h,088h,022h,088h,022h,088h,055h,0AAh
       db   055h,0AAh,055h,0AAh,055h,0AAh,0DBh,077h
       db   0DBh,0EEh,0DBh,077h,0DBh,0EEh,018h,018h
       db   018h,018h,018h,018h,018h,018h,018h,018h
       db   018h,018h,0F8h,018h,018h,018h,018h,018h
       db   0F8h,018h,0F8h,018h,018h,018h,036h,036h
       db   036h,036h,0F6h,036h,036h,036h,000h,000h
       db   000h,000h,0FEh,036h,036h,036h,000h,000h
       db   0F8h,018h,0F8h,018h,018h,018h,036h,036h
       db   0F6h,006h,0F6h,036h,036h,036h,036h,036h
       db   036h,036h,036h,036h,036h,036h,000h,000h
       db   0FEh,006h,0F6h,036h,036h,036h,036h,036h
       db   0F6h,006h,0FEh,000h,000h,000h,036h,036h
       db   036h,036h,0FEh,000h,000h,000h,018h,018h
       db   0F8h,018h,0F8h,000h,000h,000h,000h,000h
       db   000h,000h,0F8h,018h,018h,018h,018h,018h
       db   018h,018h,01Fh,000h,000h,000h,018h,018h
       db   018h,018h,0FFh,000h,000h,000h,000h,000h
       db   000h,000h,0FFh,018h,018h,018h,018h,018h
       db   018h,018h,01Fh,018h,018h,018h,000h,000h
       db   000h,000h,0FFh,000h,000h,000h,018h,018h
       db   018h,018h,0FFh,018h,018h,018h,018h,018h
       db   01Fh,018h,01Fh,018h,018h,018h,036h,036h
       db   036h,036h,037h,036h,036h,036h,036h,036h
       db   037h,030h,03Fh,000h,000h,000h,000h,000h
       db   03Fh,030h,037h,036h,036h,036h,036h,036h
       db   0F7h,000h,0FFh,000h,000h,000h,000h,000h
       db   0FFh,000h,0F7h,036h,036h,036h,036h,036h
       db   037h,030h,037h,036h,036h,036h,000h,000h
       db   0FFh,000h,0FFh,000h,000h,000h,036h,036h
       db   0F7h,000h,0F7h,036h,036h,036h,018h,018h
       db   0FFh,000h,0FFh,000h,000h,000h,036h,036h
       db   036h,036h,0FFh,000h,000h,000h,000h,000h
       db   0FFh,000h,0FFh,018h,018h,018h,000h,000h
       db   000h,000h,0FFh,036h,036h,036h,036h,036h
       db   036h,036h,03Fh,000h,000h,000h,018h,018h
       db   01Fh,018h,01Fh,000h,000h,000h,000h,000h
       db   01Fh,018h,01Fh,018h,018h,018h,000h,000h
       db   000h,000h,03Fh,036h,036h,036h,036h,036h
       db   036h,036h,0FFh,036h,036h,036h,018h,018h
       db   0FFh,018h,0FFh,018h,018h,018h,018h,018h
       db   018h,018h,0F8h,000h,000h,000h,000h,000h
       db   000h,000h,01Fh,018h,018h,018h,0FFh,0FFh
       db   0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,000h,000h
       db   000h,000h,0FFh,0FFh,0FFh,0FFh,0F0h,0F0h
       db   0F0h,0F0h,0F0h,0F0h,0F0h,0F0h,00Fh,00Fh
       db   00Fh,00Fh,00Fh,00Fh,00Fh,00Fh,0FFh,0FFh
       db   0FFh,0FFh,000h,000h,000h,000h,000h,000h
       db   076h,0DCh,0C8h,0DCh,076h,000h,000h,078h
       db   0CCh,0F8h,0CCh,0F8h,0C0h,0C0h,000h,0FCh
       db   0CCh,0C0h,0C0h,0C0h,0C0h,000h,000h,0FEh
       db   06Ch,06Ch,06Ch,06Ch,06Ch,000h,0FCh,0CCh
       db   060h,030h,060h,0CCh,0FCh,000h,000h,000h
       db   07Eh,0D8h,0D8h,0D8h,070h,000h,000h,066h
       db   066h,066h,066h,07Ch,060h,0C0h,000h,076h
       db   0DCh,018h,018h,018h,018h,000h,0FCh,030h
       db   078h,0CCh,0CCh,078h,030h,0FCh,038h,06Ch
       db   0C6h,0FEh,0C6h,06Ch,038h,000h,038h,06Ch
       db   0C6h,0C6h,06Ch,06Ch,0EEh,000h,01Ch,030h
       db   018h,07Ch,0CCh,0CCh,078h,000h,000h,000h
       db   07Eh,0DBh,0DBh,07Eh,000h,000h,006h,00Ch
       db   07Eh,0DBh,0DBh,07Eh,060h,0C0h,038h,060h
       db   0C0h,0F8h,0C0h,060h,038h,000h,078h,0CCh
       db   0CCh,0CCh,0CCh,0CCh,0CCh,000h,000h,0FCh
       db   000h,0FCh,000h,0FCh,000h,000h,030h,030h
       db   0FCh,030h,030h,000h,0FCh,000h,060h,030h
       db   018h,030h,060h,000h,0FCh,000h,018h,030h
       db   060h,030h,018h,000h,0FCh,000h,00Eh,01Bh
       db   01Bh,018h,018h,018h,018h,018h,018h,018h
       db   018h,018h,018h,0D8h,0D8h,070h,030h,030h
       db   000h,0FCh,000h,030h,030h,000h,000h,076h
       db   0DCh,000h,076h,0DCh,000h,000h,038h,06Ch
       db   06Ch,038h,000h,000h,000h,000h,000h,000h
       db   000h,018h,018h,000h,000h,000h,000h,000h
       db   000h,000h,018h,000h,000h,000h,00Fh,00Ch
       db   00Ch,00Ch,0ECh,06Ch,03Ch,01Ch,078h,06Ch
       db   06Ch,06Ch,06Ch,000h,000h,000h,070h,018h
       db   030h,060h,078h,000h,000h,000h,000h,000h
       db   03Ch,03Ch,03Ch,03Ch,000h,000h,000h,000h
       db   000h,000h,000h,000h,000h,000h

 ;=====End of Font

 .CODE

 ;********************************************************
 ;DefaultFont - Returns the Segment:Offset address of the
 ;               default font
 ;
 ; DefaultFont Segment%, Offset%

 PUBLIC DefaultFont
 DefaultFont PROC
    push  bp
    mov   bp,sp

    les         bx,[bp+10]                ;put address of first arg in es:si
    mov         es:[bx],SEG _IBM8_def        ;move segment address to first ar

    les         bx,[bp+6]                ;repeat above for offset address of f
    mov         word ptr es:[bx],OFFSET _IBM8_def

    pop   bp
    ret   8
 DefaultFont ENDP

       END


 CHRTB.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\CHRTB.BAS

 '*** CHRTB.BAS - Chart Routines for the Presentation Graphics Toolbox in
 '           Microsoft BASIC 7.0, Professional Development System
 '              Copyright (C) 1987-1989, Microsoft Corporation
 '
 '  NOTE:  This sample source code toolbox is intended to demonstrate some
 '  of the extended capabilities of Microsoft BASIC 7.0 Professional Developme
 '  system that can help to leverage the professional developer's time more
 '  effectively.  While you are free to use, modify, or distribute the routine
 '  in this module in any way you find useful, it should be noted that these a
 '  examples only and should not be relied upon as a fully-tested "add-on"
 '  library.
 '
 '  PURPOSE: This file contains the BASIC source code for the Presentation
 '           Graphics Toolbox Chart Routines.
 '
 '  To create a library and QuickLib containing the charting routines found
 '  in this file, follow these steps:
 '       BC /X/FS chrtb.bas
 '       LIB chrtb.lib + chrtb + chrtasm + qbx.lib;
 '       LINK /Q chrtb.lib, chrtb.qlb,,qbxqlb.lib;
 '  If you are going to use this CHRTB.QLB QuickLib in conjunction with
 '  the font source code (FONTB.BAS) or the UI toobox source code
 '  (GENERAL.BAS, WINDOW.BAS, MENU.BAS and MOUSE.BAS), you need to
 '  include the assembly code routines referenced in these files.  For the
 '  font routines, create CHRTB.LIB as follows before you create the
 '  QuickLib:
 '       LIB chrtb.lib + chrtb + chrtasm + fontasm + qbx.lib;
 '  For the UI toolbox routines, create the library as follows:
 '       LIB chrtb.lib + chrtb + chrtasm + uiasm + qbx.lib;
 '**************************************************************************

 ' Constants:

 CONST cTicSize = .02            ' Percent of axis length to use for tic lengt
 CONST cMaxChars = 255           ' Maximum ASCII value allowed for character
 CONST cBarWid = .8              ' Percent of category width to use for bar
 CONST cPiVal = 3.141592         ' A value for PI
 CONST cFalse = 0                ' Logical false
 CONST cTrue = NOT cFalse        ' Logical true

 ' CHRTB.BI contains all of the TYPE definitions and SUB declarations
 ' that are accessible to the library user as well as CONST definitions for
 ' some routine parameters and error messages:

 '$INCLUDE: 'CHRTB.BI'

 ' FONTB.BI contains all of the TYPE definitions and SUB declarations
 ' required for graphics text:

 '$INCLUDE: 'FONTB.BI'

 ' Below are TYPE definitions local to this module:

 ' TYPE for recording information on title spacing:
 TYPE TitleLayout
         Top         AS INTEGER        ' Space above first title
         TitleOne    AS INTEGER        ' Height of first title
         Middle      AS INTEGER        ' Space between first and second titles
         TitleTwo    AS INTEGER        ' Height of second title
         Bottom      AS INTEGER        ' Space below second title
         TotalSize   AS INTEGER        ' Sum of all the above
 END TYPE

 ' TYPE for recording information on the legend layout:
 TYPE LegendLayout
         NumCol      AS INTEGER        ' Number of columns in legend
         NumRow      AS INTEGER        ' Number of rows in legend
         SymbolSize  AS INTEGER        ' Height of symbol
         LabelOffset AS INTEGER        ' Space between start of symbol and lab
         RowSpacing  AS INTEGER        ' Space between tops of rows
         ColSpacing  AS INTEGER        ' Spacing between beginnings of columns
         HorizBorder AS INTEGER        ' Top and bottom border
         VertBorder  AS INTEGER        ' Left and right border
 END TYPE

 ' TYPE for a group of global parameters:
 TYPE GlobalParams
         SysFlag     AS INTEGER        ' cYes means Analyze call is from syste
         Initialized AS INTEGER        ' cYes means clInitChart has been calle

         PaletteScrn AS INTEGER        ' Screen mode for which palette is set
         PaletteBits AS INTEGER        ' Bits per pixel for current screen mod
         PaletteSet  AS INTEGER        ' cYes means palette has been initializ
         White       AS INTEGER        ' White attribute in current screen mod

         Aspect      AS SINGLE         ' Current screen aspect
         MaxXPix     AS INTEGER        ' Screen size along X axis
         MaxYPix     AS INTEGER        ' Screen size along Y axis
         MaxColor    AS INTEGER        ' Maximum color number for current scre

         ChartWid    AS INTEGER        ' Width of chart window
         ChartHgt    AS INTEGER        ' Height of chart window
         CwX1        AS INTEGER        ' Left side of chart window
         CwY1        AS INTEGER        ' Top edge of chart window
         CwX2        AS INTEGER        ' Right side of chart window
         CwY2        AS INTEGER        ' Bottom edge of chart window

         XStagger    AS INTEGER        ' Boolean, true if category labels over
         ValLenX     AS INTEGER        ' Maximum length of value labels on X-a
         ValLenY     AS INTEGER        ' Maximum length of value labels on Y-a

         NVals       AS INTEGER        ' Number of data values in data series
         NSeries     AS INTEGER        ' Number of series of data
         MSeries     AS INTEGER        ' If multiple-series chart then cYes, e

         XMode       AS INTEGER        ' Axis mode of x axis
         YMode       AS INTEGER        ' Axis mode of y axis
 END TYPE

 ' FUNCTION and SUB declarations for procedures local to this module:

 DECLARE FUNCTION clBuildBitP$ (Bits%, C%, InP$)
 DECLARE FUNCTION clBuildPlaneP$ (Bits%, C%, InP$)
 DECLARE FUNCTION clColorMaskL% (Bits%, Colr%)
 DECLARE FUNCTION clGetStyle% (StyleNum%)
 DECLARE FUNCTION clMaxVal (A, B)
 DECLARE FUNCTION clMap2Pal% (N%)
 DECLARE FUNCTION clMap2Attrib% (N%)
 DECLARE FUNCTION clMaxStrLen% (Txt$(), First%, Last%)
 DECLARE FUNCTION clVal2Str$ (X, Places%, Format%)

 DECLARE SUB clAdjustScale (Axis AS AxisType)
 DECLARE SUB clAnalyzeC (Cat$(), N%, SLabels$(), First%, Last%)
 DECLARE SUB clAnalyzeS (N%, SLabels$(), First%, Last%)
 DECLARE SUB clBuildPalette (ScrnMode%, Bits%)
 DECLARE SUB clChkInit ()
 DECLARE SUB clChkFonts ()
 DECLARE SUB clChkForErrors (Env AS ChartEnvironment, TypeMin%, TypeMax%, N%,
 DECLARE SUB clChkChartWindow (Env AS ChartEnvironment)
 DECLARE SUB clChkPalettes (C%(), s%(), P$(), Char%(), B%())
 DECLARE SUB clClearError ()
 DECLARE SUB clColorMaskH (Bits%, Colr%, CMask%())
 DECLARE SUB clDrawAxes (Cat$())
 DECLARE SUB clDrawDataWindow ()
 DECLARE SUB clDrawChartWindow ()
 DECLARE SUB clDrawTitles ()
 DECLARE SUB clDrawLegend (SeriesLabel$(), First AS INTEGER, Last AS INTEGER)
 DECLARE SUB clDrawBarData ()
 DECLARE SUB clDrawColumnData ()
 DECLARE SUB clDrawLineData ()
 DECLARE SUB clDrawPieData (value(), Expl%(), N%)
 DECLARE SUB clDrawScatterData ()
 DECLARE SUB clFilter (A AS AxisType, AxisMode%, D1(), D2(), N%)
 DECLARE SUB clFilterMS (A AS AxisType, AxisMode%, D1(), D2(), N%, First%, Las
 DECLARE SUB clFlagSystem ()
 DECLARE SUB clFormatTics (A AS AxisType)
 DECLARE SUB clHPrint (X%, Y%, Txt$)
 DECLARE SUB clInitChart ()
 DECLARE SUB clInitStdStruc ()
 DECLARE SUB clLabelXTics (Axis AS AxisType, Cat$(), TicX, TicTotX%, TicY, YBo
 DECLARE SUB clLabelYTics (Axis AS AxisType, Cat$(), TicX, TicY, TicTotY%)
 DECLARE SUB clLayoutTitle (TL AS ANY, T1 AS ANY, T2 AS ANY)
 DECLARE SUB clPrintTitle (TitleVar AS TitleType, Y%)
 DECLARE SUB clRenderBar (X1, Y1, X2, Y2, C%)
 DECLARE SUB clRenderWindow (W AS RegionType)
 DECLARE SUB clScaleAxis (A AS AxisType, AxisMode%, D1())
 DECLARE SUB clSelectChartWindow ()
 DECLARE SUB clSelectRelWindow (W AS RegionType)
 DECLARE SUB clSetAxisModes ()
 DECLARE SUB clSetChartFont (N AS INTEGER)
 DECLARE SUB clSetError (ErrNo AS INTEGER)
 DECLARE SUB clSetCharColor (N%)
 DECLARE SUB clSetGlobalParams ()
 DECLARE SUB clSizeDataWindow (Cat$())
 DECLARE SUB clLayoutLegend (SeriesLabel$(), First%, Last%)
 DECLARE SUB clSpaceTics ()
 DECLARE SUB clSpaceTicsA (A AS AxisType, AxisMode%, AxisLen%, TicWid%)
 DECLARE SUB clTitleXAxis (A AS AxisType, X1%, X2%, YBoundry%)
 DECLARE SUB clTitleYAxis (A AS AxisType, Y1%, Y2%)
 DECLARE SUB clUnFlagSystem ()
 DECLARE SUB clVPrint (X%, Y%, Txt$)


 ' Variable definitions local to this module:

 DIM PaletteC%(0 TO cPalLen)            ' List of colors     for drawing data
 DIM PaletteS%(0 TO cPalLen)            ' List of styles     for drawing data
 DIM PaletteP$(0 TO cPalLen)            ' List of patterns   for drawing data
 DIM PaletteCh%(0 TO cPalLen)           ' List of plot chars for drawing data
 DIM PaletteB%(0 TO cPalLen)            ' List of patterns   for borders

 DIM StdChars%(0 TO cPalLen)            ' Holds default plot characters

 DIM DAxis         AS AxisType          ' Default axis settings
 DIM DWindow       AS RegionType        ' Default window settings
 DIM DLegend       AS LegendType        ' Default legend settings
 DIM DTitle        AS TitleType         ' Default title settings

 DIM XTitleLayout  AS TitleLayout       ' X-axis layout information
 DIM YTitleLayout  AS TitleLayout       ' Y-axis layout information
 DIM TTitleLayout  AS TitleLayout       ' Main/Sub layout information

 DIM LLayout       AS LegendLayout      ' Legend layout information

 DIM GFI           AS FontInfo          ' Global font information
 DIM GE            AS ChartEnvironment  ' An internal global chart environment
 DIM GP            AS GlobalParams      ' Holds a number of global parameters



 '$DYNAMIC
 DIM V1(1, 1), V2(1, 1)                 ' Internal dynamic data arrays.
 '$STATIC

 '============================================================
 '==============      Main Level Code     ====================
 '============================================================

 ' This error trap is set in the ChartScreen routine and will
 ' be evoked if an invalid screen mode is used:
 ScreenErr:
         clSetError cBadScreen
         RESUME NEXT

 ' This error trap should catch all errors that arise in using
 ' the charting library that are not expected:
 UnexpectedErr:
         clSetError cCLUnexpectedOff + ERR
         RESUME NEXT

 '=== AnalyzeChart - Sets up scales and data window sizes
 '
 '  Arguments:
 '     Env        - A ChartEnvironment variable
 '
 '     Cat$(1)    - One-dimensional array of category labels
 '
 '     Value(1)   - One-dimensional array of values to chart
 '
 '     N%         - The number of data values in data series
 '
 '  Return Values:
 '     Scale and Data-Window values are changed as appropriate.
 '
 '=================================================================
 SUB AnalyzeChart (Env AS ChartEnvironment, Cat$(), value(), N AS INTEGER)

 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED V1()
 REDIM V1(1 TO N%, 1 TO 1)
 DIM Dum$(1 TO 1)

         ' Check initialization and fonts:
         clClearError
         clChkInit
         clChkFonts
         IF ChartErr >= 100 THEN EXIT SUB

         ' Set a global flag to indicate that this isn't a multiple-series cha
         GP.MSeries = cNo

         ' Check for obvious parameter and ChartEnvironment errors:
         clChkForErrors Env, 1, 3, N, 0, 0
         IF ChartErr > 100 THEN EXIT SUB

         ' Make a copy of the user's ChartEnvironment variable to the library'
         ' global environment variable:
         GE = Env

         ' Set the correct axis modes for the type of chart specified in the
         ' chart environment:
         clSetAxisModes

         ' Transfer the input data to the dynamic working data array.  Do this
         ' for each axis because, depending on the chart type, either one may
         ' the value axis.  The Filter routine automatically ignores the call
         ' the axis is a category axis:
         clFilter GE.XAxis, GP.XMode, value(), V1(), N
         clFilter GE.YAxis, GP.YMode, value(), V1(), N

         ' Analyze the data for scale-maximum and -minimum and set the scale-
         ' factor, etc. depending on the options set in the chart environment:
         clAnalyzeC Cat$(), N, Dum$(), 1, 1

         ' Copy the global chart environment back to the user's ChartEnvironme
         ' variable so that the settings that were calculated by the library a
         ' accessible.  Then, if this routine wasn't called by the library its
         ' in the course of drawing a bar, column or line chart, deallocate th
         ' working data array:
         Env = GE
         IF GP.SysFlag = cNo THEN ERASE V1

 END SUB

 '=== AnalyzeChartMS - Analyzes multiple-series data for scale/window size.
 '
 '  Arguments:
 '     Env             - ChartEnvironment variable
 '
 '     Cat$(1)         - One-dimensional array of category labels
 '
 '     Value(2)        - Two-dimensional array of values to chart.  First
 '                       dimension (rows) represents different values within
 '                       a series.  Second dimension (columns) represents
 '                       different series.
 '
 '     N%              - Number of values (beginning with 1) to chart per
 '                       series.
 '
 '     First%          - First series to analyze
 '
 '     Last%           - Last series to analyze
 '
 '     SeriesLabel$(1) - Labels for the different series
 '
 '  Return Values:
 '     Various settings in the Env variable are altered in accordance with
 '     the analysis.
 '
 '=================================================================
 SUB AnalyzeChartMS (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, N AS

 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED V1()
 REDIM V1(1 TO N, 1 TO Last - First + 1)

         ' Check initialization and fonts:
         clClearError
         clChkInit
         clChkFonts
         IF ChartErr >= 100 THEN EXIT SUB

         ' Set a global flag to indicate that this is a multiple-series chart:
         GP.MSeries = cYes

         ' Check for obvious parameter and ChartEnvironment errors:
         clChkForErrors Env, 1, 3, N, 0, 0
         IF ChartErr > 100 THEN EXIT SUB

         ' Make a copy of the user's ChartEnvironment variable to the library'
         ' global environment variable:
         GE = Env

         ' Set the correct axis modes for the type of chart specified in the
         ' chart environment:
         clSetAxisModes

         ' Transfer the input data to the dynamic working data array.  Do this
         ' for each axis because, depending on the chart type, either one may
         ' the value axis.  The Filter routine automatically ignores the call
         ' the axis is a category axis:
         clFilterMS GE.XAxis, GP.XMode, value(), V1(), N, First, Last
         clFilterMS GE.YAxis, GP.YMode, value(), V1(), N, First, Last

         ' Analyze the data for scale maximums and minimums and set the scale
         ' factor, etc. depending on the options set in the chart environment:
         clAnalyzeC Cat$(), N, SeriesLabel$(), First, Last

         ' Copy the global chart environment back to the user's ChartEnvironme
         ' variable so that the settings that were calculated by the library a
         ' accessible.  Then, if this routine wasn't called by the library its
         ' in the course of drawing a bar, column or line chart, deallocate th
         ' working data array:
         Env = GE
         IF GP.SysFlag = cNo THEN ERASE V1

 END SUB

 '=== AnalyzePie - Analyzes data for a pie chart
 '
 '  Arguments:
 '     Env      - A ChartEnvironment variable
 '
 '     Cat$()   - One-dimensional array of category names
 '
 '     Value()  - One-dimensional array of values to chart
 '
 '     Expl()   - One dimensional array of flags indicating whether slices
 '                are to be "exploded" (0 means no, 1 means yes).
 '                Ignored if Env.ChartStyle <> 1.
 '
 '     N        - The number of values to chart
 '
 '  Return Values:
 '     None.
 '
 '=================================================================
 SUB AnalyzePie (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, Expl() AS
 SHARED GE AS ChartEnvironment
 SHARED GP AS GlobalParams
 SHARED TTitleLayout AS TitleLayout
 SHARED XTitleLayout AS TitleLayout
 SHARED YTitleLayout AS TitleLayout
 SHARED V1()
 DIM EmptyTitle AS TitleType

         ' Check initialization and fonts:
         clClearError
         clChkInit
         clChkFonts
         IF ChartErr >= 100 THEN EXIT SUB

         ' This is a multiple series chart (a pie chart is treated as a
         ' multiple series chart with each series having one value):
         GP.MSeries = cYes
         GP.NSeries = N

         ' Check for obvious parameter and ChartEnvironment errors:
         clChkForErrors Env, cPie, cPie, 2, 1, N
         IF ChartErr > 100 THEN EXIT SUB

         ' Make a copy of the user's ChartEnvironment variable to the library'
         ' global environment variable:
         GE = Env

         ' Set the correct axis modes for the type of chart specified in the
         ' chart environment:
         clSetAxisModes

         ' Set global parameters and layout main title:
         clSetGlobalParams

         ' Layout titles (ignore X and Y axis titles):
         clLayoutTitle TTitleLayout, GE.MainTitle, GE.SubTitle
         EmptyTitle.Title = ""
         clLayoutTitle XTitleLayout, EmptyTitle, EmptyTitle
         clLayoutTitle YTitleLayout, EmptyTitle, EmptyTitle

         ' Calculate the size for LegendWindow and DataWindow:
         clLayoutLegend Cat$(), 1, N
         IF ChartErr > 100 THEN EXIT SUB
         clSizeDataWindow Cat$()
         IF ChartErr > 100 THEN EXIT SUB

         ' Copy the global chart environment back to the user's ChartEnvironme
         ' variable so that the settings that were calculated by the library a
         ' accessible.  Then, if this routine wasn't called by the library its
         ' in the course of drawing a pie chart, deallocate the working data a
         Env = GE

 END SUB

 '=== AnalyzeScatter - Sets up scales and data-window sizes for scatter chart
 '
 '  Arguments:
 '     Env        - A ChartEnvironment variable
 '
 '     ValX(1)    - One-dimensional array of values for X axis
 '
 '     ValY(1)    - One-dimensional array of values for Y axis
 '
 '     N%         - The number of data values in data series
 '
 '  Return Values:
 '     Scale and data-window values are changed as appropriate.
 '
 '=================================================================
 SUB AnalyzeScatter (Env AS ChartEnvironment, ValX() AS SINGLE, ValY() AS SING

 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED V1(), V2()
 REDIM V1(1 TO N, 1 TO 1), V2(1 TO N, 1 TO 1)
 DIM Dum$(1 TO 1)

         ' Check initialization and fonts:
         clClearError
         clChkInit
         clChkFonts
         IF ChartErr >= 100 THEN EXIT SUB

         ' Set a global flag to indicate that this isn't a multiple-series cha
         GP.MSeries = cNo

         ' Check for obvious parameter and ChartEnvironment errors:
         clChkForErrors Env, 4, 4, N%, 0, 0
         IF ChartErr > 100 THEN EXIT SUB

         ' Make a copy of the user's ChartEnvironment variable to the library'
         ' global environment variable:
         GE = Env

         ' Set the correct axis modes for the type of chart specified in the
         ' chart environment:
         clSetAxisModes

         ' Transfer the input data to the dynamic working data arrays (one
         ' for each axis):
         clFilter GE.XAxis, GP.XMode, ValX(), V1(), N
         clFilter GE.YAxis, GP.YMode, ValY(), V2(), N

         ' Analyze the data for scale-maximum and -minimum and set the scale-
         ' factor, etc. depending on the options set in the chart environment:
         clAnalyzeS N, Dum$(), 1, 1

         ' Copy the global chart environment back to the user's ChartEnvironme
         ' variable so that the settings that were calculated by the library a
         ' accessible.  Then, if this routine wasn't called by the library its
         ' in the course of drawing a scatter chart, deallocate the working
         ' data arrays:
         Env = GE
         IF GP.SysFlag = cNo THEN ERASE V1, V2

 END SUB

 '=== AnalyzeScatterMS - Analyzes multiple-series data for scale/window size
 '
 '  Arguments:
 '     Env             - A ChartEnvironment variable
 '
 '     ValX(2)         - Two-dimensional array of values for X axis.  First
 '                       dimension (rows) represents different values within
 '                       a series.  Second dimension (columns) represents
 '                       different series.
 '
 '     ValY(2)         - Two-dimensional array of values for Y axis.  Above
 '                       comments apply
 '
 '     N%              - Number of values (beginning with 1) to chart per
 '                       series
 '
 '     First%          - First series to analyze
 '
 '     Last%           - Last series to analyze
 '
 '     SeriesLabel$(1) - Labels for the different series
 '
 '  Return Values:
 '     Various settings in the Env variable are altered in accordance with
 '     the analysis.
 '
 '=================================================================
 SUB AnalyzeScatterMS (Env AS ChartEnvironment, ValX() AS SINGLE, ValY() AS SI

 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED V1(), V2()
 REDIM V1(1 TO N, 1 TO Last - First + 1), V2(1 TO N, 1 TO Last - First + 1)
 DIM Dum$(1 TO 1)

         ' Check initialization and fonts:
         clClearError
         clChkInit
         clChkFonts
         IF ChartErr >= 100 THEN EXIT SUB

         ' Set a global flag to indicate that this is a multiple-series chart:
         GP.MSeries = cYes

         ' Check for obvious parameter and ChartEnvironment errors:
         clChkForErrors Env, 4, 4, N%, 0, 0
         IF ChartErr > 100 THEN EXIT SUB

         ' Make a copy of the user's ChartEnvironment variable to the library'
         ' global environment variable:
         GE = Env

         ' Set the correct axis modes for the type of chart specified in the
         ' chart environment:
         clSetAxisModes

         ' Transfer the input data to the dynamic working data arrays (one
         ' for each axis):
         clFilterMS GE.XAxis, GP.XMode, ValX(), V1(), N, First, Last
         clFilterMS GE.YAxis, GP.YMode, ValY(), V2(), N, First, Last

         ' Analyze the data for scale-maximum and -minimum and set the scale-
         ' factor, etc. depending on the options set in the chart environment:
         clAnalyzeS N, SeriesLabel$(), First%, Last%

         ' Copy the global chart environment back to the user's ChartEnvironme
         ' variable so that the settings that were calculated by the library a
         ' accessible.  Then, if this routine wasn't called by the library its
         ' in the course of drawing a scatter chart, deallocate the working
         ' data arrays:
         Env = GE
         IF GP.SysFlag = cNo THEN ERASE V1, V2

 END SUB

 '=== Chart - Draws a single-series category/value chart
 '
 '  Arguments:
 '     Env        - A ChartEnvironment variable
 '
 '     Cat$(1)    - One-dimensional array of category labels
 '
 '     Value(1)   - One-dimensional array of values to plot
 '
 '     N          - The number of data values in data series
 '
 '  Return Values:
 '     Some elements of the Env variable are altered by plotting routines
 '
 '  Remarks:
 '     This routine takes all of the parameters set in the Env variable
 '     and draws a single-series chart of type Bar, Column, or Line
 '     depending on the chart type specified in the Env variable.
 '
 '=================================================================
 SUB Chart (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, N AS INTEGER)

 SHARED V1()

         ' Analyze data for scale and window settings:
         clFlagSystem
         AnalyzeChart Env, Cat$(), value(), N
         clUnFlagSystem
         IF ChartErr < 100 THEN

                 ' Draw the different elements of the chart:
                 clDrawChartWindow
                 clDrawTitles
                 clDrawDataWindow
                 clDrawAxes Cat$()

                 ' Call appropriate Draw...Data routine for chart type:
                 SELECT CASE Env.ChartType
                         CASE 1: clDrawBarData
                         CASE 2: clDrawColumnData
                         CASE 3: clDrawLineData
                 END SELECT

         END IF

         ' Deallocate the data array:
         ERASE V1

 END SUB

 '=== ChartMS - Draws a multiple-series category/value chart
 '
 '  Arguments:
 '     Env               - A ChartEnvironment variable
 '
 '     Cat$(1)           - A one-dimensional array of category names for the
 '                         different data values
 '
 '     Value(2)          - A two-dimensional array of values--one column for
 '                         each series of data
 '
 '     N%                - The number of data points in each series of data
 '
 '     First%            - The first series to be plotted
 '
 '     Last%             - The last series to be plotted
 '
 '     SeriesLabel$(1)   - Labels used for each series in the legend
 '
 '  Return Values:
 '     Some elements of the Env variable are altered by plotting routines
 '
 '  Remarks:
 '     This routine takes all of the parameters set in the Env variable
 '     and draws a multiple-series chart of type Bar, Column, or Line
 '     depending on the chart type specified in the Env variable.
 '
 '=================================================================
 SUB ChartMS (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, N AS INTEGER

 SHARED V1()

         ' Analyze data for scale settings:
         clFlagSystem
         AnalyzeChartMS Env, Cat$(), value(), N, First, Last, SeriesLabel$()
         clUnFlagSystem
         IF ChartErr < 100 THEN

                 ' Draw the different elements of the chart:
                 clDrawChartWindow
                 clDrawTitles
                 clDrawDataWindow
                 clDrawAxes Cat$()

                 ' Call appropriate Draw...DataMS routine for chart type:
                 SELECT CASE Env.ChartType
                         CASE 1: clDrawBarData
                         CASE 2: clDrawColumnData
                         CASE 3: clDrawLineData
                 END SELECT

                 ' Lastly, add the legend:
                 clDrawLegend SeriesLabel$(), First, Last

         END IF

         ' Deallocate the data array:
         ERASE V1

 END SUB

 '=== ChartPie - Draws a pie chart
 '
 '  Arguments:
 '     Env      - A ChartEnvironment variable
 '
 '     Cat$()   - One-dimensional array of category names
 '
 '     Value()  - One-dimensional array of values to chart
 '
 '     Expl%()  - One-dimensional array of flags indicating whether slices
 '                are to be "exploded" or not (0 means no, 1 means yes),
 '                ignored if ChartStyle <> 1
 '
 '     N%       - The number of values to chart
 '
 '  Return Values:
 '     No return values
 '
 '=================================================================
 SUB ChartPie (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, Expl() AS I
 SHARED GP AS GlobalParams
         ' Set the global system flag to tell the AnalyzePie routine that it
         ' is being called by the system and not the user:
         clFlagSystem

         ' Calculate the size of the Data- and Legend-window:
         AnalyzePie Env, Cat$(), value(), Expl(), N

         ' Remove the system flag:
         clUnFlagSystem

         ' If there were no errors during analysis draw the chart:
         IF ChartErr < 100 THEN

                 ' Draw the different chart elements:
                 clDrawChartWindow
                 clDrawTitles
                 clDrawDataWindow
                 clDrawPieData value(), Expl(), N
                 IF ChartErr <> 0 THEN EXIT SUB
                 clDrawLegend Cat$(), 1, N

         END IF

 END SUB

 '=== ChartScatter - Draws a single-series scatter chart
 '
 '  Arguments:
 '     Env      - A ChartEnvironment variable
 '
 '     ValX(1)  - One-dimensional array of values for X axis
 '
 '     ValY(1)  - One-dimensional array of values for Y axis
 '
 '     N%       - The number of values to chart
 '
 '
 '  Return Values:
 '     Some elements of Env variable may be changed by drawing routines
 '
 '  Remarks:
 '     ChartScatter should be called when a chart with two value axes is
 '     desired
 '
 '=================================================================
 SUB ChartScatter (Env AS ChartEnvironment, ValX() AS SINGLE, ValY() AS SINGLE
 DIM Dum$(1 TO 1)
 SHARED V1(), V2()

         ' Set the global system flag to tell the AnalyzeScatter routine that
         ' is being called by the system and not the user:
         clFlagSystem

         ' Calculate the scale maximums and minimums and scale factor. Also
         ' calculate the sizes for the Data- and Legend-windows:
         AnalyzeScatter Env, ValX(), ValY(), N

         ' Remove the system flag:
         clUnFlagSystem

         ' If there were no errors during analysis draw the chart:
         IF ChartErr < 100 THEN

                 ' Draw the different elements of the chart:
                 clDrawChartWindow
                 clDrawTitles
                 clDrawDataWindow
                 clDrawAxes Dum$()
                 clDrawScatterData

         END IF

         ' Deallocate the dynamic working data arrays:
         ERASE V1, V2

 END SUB

 '=== ChartScatterMS - Draws a multiple-series scatter chart
 '
 '  Arguments:
 '     Env            - A ChartEnvironment variable
 '
 '     ValX(2)        - Two-dimensional array of values for X axis
 '
 '     ValY(2)        - Two-dimensional array of values for Y axis
 '
 '     N%             - The number of values in each series
 '
 '     First%         - First series to chart (first column)
 '
 '     Last%          - Last series to chart (last column)
 '
 '     SeriesLabel$() - Label used for each series in legend
 '
 '
 '  Return Values:
 '     Some elements in Env variable may be changed by drawing routines
 '
 '  Remarks:
 '     A scatter chart uses two value axes so it must have values for both
 '     the X and Y axes (ValX(), ValY()).  The first dimension denotes
 '     the different values within a series.  The second dimension specifies
 '     different data series (e.g. ValX(4,3) would represent the fourth value
 '     in the third series of data).
 '
 '=================================================================
 SUB ChartScatterMS (Env AS ChartEnvironment, ValX() AS SINGLE, ValY() AS SING
 DIM Dum$(1 TO 1)
 SHARED V1(), V2()

         ' Set the global system flag to tell the AnalyzeScatterMS routine tha
         ' is being called by the system and not the user:
         clFlagSystem

         ' Calculate the scale maximums and minimums and scale factor. Also
         ' calculate the sizes for the Data- and Legend-windows:
         AnalyzeScatterMS Env, ValX(), ValY(), N, First, Last, SeriesLabel$()

         ' Remove the system flag:
         clUnFlagSystem

         ' If there were no errors during analysis draw the chart:
         IF ChartErr < 100 THEN

                 ' Draw the different elements of the chart:
                 clDrawChartWindow
                 clDrawTitles
                 clDrawDataWindow
                 clDrawAxes Dum$()
                 clDrawScatterData
                 clDrawLegend SeriesLabel$(), First, Last

         END IF

         ' Deallocate the dynamic working data arrays:
         ERASE V1, V2

 END SUB

 '=== ChartScreen - Sets the SCREEN mode and default palettes
 '
 '  Arguments:
 '     N%    - A valid BASIC graphic mode, or mode 0
 '
 '  Return Values:
 '     All palettes may be altered
 '
 '=================================================================
 SUB ChartScreen (N AS INTEGER)
 SHARED GP AS GlobalParams

         ' Check initialization and fonts:
         clClearError
         clChkInit

         ' Set up branch to error processor and attempt to set the specified
         ' screen mode and draw to it:
         ON ERROR GOTO ScreenErr
         SCREEN N
         IF N <> 0 THEN PRESET (0, 0)
         ON ERROR GOTO UnexpectedErr

         ' If the above PRESET failed, then the TestScreen error processor wil
         ' have set the ChartErr error variable to a nonzero value.  If the la
         ' call to ChartScreen used the same mode, GP.PaletteScrn will equal N
         ' there is no need to rebuild palettes.  In either case there is no n
         ' to do anything else, so exit:
         IF ChartErr <> 0 OR (GP.PaletteScrn = N AND GP.PaletteSet) THEN EXIT

         ' This is a new screen mode so use the SELECT CASE statement below
         ' to handle it.  It sets the number of bits per pixel for a screen
         ' mode so that the palettes can be built properly:
         SELECT CASE N

                 ' Screen mode 0 is not a graphics mode and is included mainly
                 ' completeness.  The actual screen mode has been set above, s
                 CASE 0:
                         EXIT SUB

                 CASE 1:  Bits% = 2
                 CASE 2:  Bits% = 1
                 CASE 3:  Bits% = 1
                 CASE 4:  Bits% = 1
                 CASE 7:  Bits% = 4
                 CASE 8:  Bits% = 4
                 CASE 9:
                                         ' For screen mode 9, assume a 256K EG
                                         ' a color to 63.  If that fails, assu
                                         ' (the number of bit planes is four f
                                         ' 64K):
                                         Bits% = 4
                                         ON ERROR GOTO ScreenErr
                                         clClearError
                                         COLOR 15
                                         IF ChartErr <> 0 THEN Bits% = 2
                                         clClearError
                                         ON ERROR GOTO UnexpectedErr

                 CASE 10: Bits% = 2
                 CASE 11: Bits% = 1
                 CASE 12: Bits% = 4
                 CASE 13: Bits% = 8

                 ' If none of the above match then a valid screen mode was spe
                 ' however the mode is un-supported so set error and exit:
                 CASE ELSE: clSetError cBadScreen
                                           EXIT SUB
         END SELECT

         ' The screen aspect is 4/3 * MaxY/MaxX:
         VIEW
         WINDOW (0, 0)-(1, 1)
         GP.MaxXPix% = PMAP(1, 0) + 1
         GP.MaxYPix% = PMAP(0, 1) + 1
         GP.Aspect = 1.33333 * (GP.MaxYPix% - 1) / (GP.MaxXPix% - 1)
         WINDOW

         ' The number of colors available:
         GP.MaxColor = 2 ^ Bits% - 1

         ' Specify which color to use for white:
         SELECT CASE N
                 CASE 13: GP.White = 15
                 CASE ELSE: GP.White = GP.MaxColor
         END SELECT

         ' Build palette for this screen mode:
         clBuildPalette N, Bits%

 END SUB

 '=== clAdjustScale - Calculates scaling factor for an axis and adjusts max-mi
 '                  as appropriate for scale factor and log base if log axis:
 '
 '  Arguments:
 '     Axis  -  AxisType variable describing axis to be scaled.
 '
 '  Return Values:
 '     May set the ScaleFactor and ScaleTitle elements and alter
 '     ScaleMin and ScaleMax elements of the Axis variable.
 '
 '=================================================================
 SUB clAdjustScale (Axis AS AxisType)

         ' Don't try to scale a log axis:
         IF Axis.RangeType = cLog THEN

                 Axis.ScaleFactor = 1
                 Axis.ScaleTitle.Title = "Log" + STR$(Axis.LogBase)

         ' For a linear axis, choose a scale factor up to Trillions depending
         ' on the size of the axis limits:
         ELSE

                 ' Choose the largest ABS from Max and Min for the axis:
                 IF ABS(Axis.ScaleMax) > ABS(Axis.ScaleMin) THEN
                         Max = ABS(Axis.ScaleMax)
                 ELSE
                         Max = ABS(Axis.ScaleMin)
                 END IF

                 ' Find out power of three by which to scale:
                 Power% = INT((LOG(Max) / LOG(10)) / 3)

                 ' And, choose the correct title to go with it:
                 SELECT CASE Power%
                         CASE -4:     Axis.ScaleTitle.Title = "Trillionths"
                         CASE -3:     Axis.ScaleTitle.Title = "Billionths"
                         CASE -2:     Axis.ScaleTitle.Title = "Millionths"
                         CASE -1:     Axis.ScaleTitle.Title = "Thousandths"
                         CASE 0:     Axis.ScaleTitle.Title = ""
                         CASE 1:     Axis.ScaleTitle.Title = "Thousands"
                         CASE 2:     Axis.ScaleTitle.Title = "Millions"
                         CASE 3:     Axis.ScaleTitle.Title = "Billions"
                         CASE 4:     Axis.ScaleTitle.Title = "Trillions"
                         CASE ELSE:  Axis.ScaleTitle.Title = "10^" + LTRIM$(ST
                 END SELECT

                 ' Calculate the actual scale factor:
                 Axis.ScaleFactor = 10 ^ (3 * Power%)

                 ' Finally, scale Max and Min by ScaleFactor:
                 Axis.ScaleMin = Axis.ScaleMin / Axis.ScaleFactor
                 Axis.ScaleMax = Axis.ScaleMax / Axis.ScaleFactor

         END IF

 END SUB

 '=== clAnalyzeC - Does analysis of category/value data
 '
 '  Arguments:
 '     Cat$(1)     -  List of category names
 '
 '     N%          -  Number of data values per series
 '
 '     SLabels$    -  Labels for the different data series
 '
 '     First%      -  First series to chart
 '
 '     Last%       -  Last series to chart
 '
 '  Return Values:
 '     Some values in GE are altered.
 '
 '=================================================================
 SUB clAnalyzeC (Cat$(), N%, SLabels$(), First%, Last%)
 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED TTitleLayout AS TitleLayout
 SHARED XTitleLayout AS TitleLayout
 SHARED YTitleLayout AS TitleLayout
 SHARED V1()

         ' Save the number of values and the number of series in the chart in
         ' the global parameter variables:
         GP.NVals = N%
         GP.NSeries = Last% - First% + 1

         ' Analyze data for scale-maximim and -minimum and scale-factor:
         clScaleAxis GE.XAxis, GP.XMode, V1()
         IF ChartErr > 100 THEN EXIT SUB

         clScaleAxis GE.YAxis, GP.YMode, V1()
         IF ChartErr > 100 THEN EXIT SUB

         ' Format tic labels (needed for sizing routines) and set global
         ' parameters (again used by sizing and other routines):
         clFormatTics GE.XAxis
         clFormatTics GE.YAxis
         clSetGlobalParams

         ' Layout Titles
         clLayoutTitle TTitleLayout, GE.MainTitle, GE.SubTitle
         clLayoutTitle YTitleLayout, GE.YAxis.AxisTitle, GE.YAxis.ScaleTitle
         clLayoutTitle XTitleLayout, GE.XAxis.AxisTitle, GE.XAxis.ScaleTitle

         ' If this is a multiple-series chart, calculate the legend size:
         IF GP.MSeries = cYes THEN clLayoutLegend SLabels$(), First%, Last%
         IF ChartErr > 100 THEN EXIT SUB

         ' Calculate the data-window size:
         clSizeDataWindow Cat$()
         IF ChartErr > 100 THEN EXIT SUB

         ' Finally, figure out the distance between tic marks:
         clSpaceTics

 END SUB

 '=== clAnalyzeS - Does actual analysis of scatter data
 '
 '  Arguments:
 '     N%          -  Number of values per data series
 '
 '     SLabels$(1) -  Labels for the data series
 '
 '     First%      -  First series to analyze
 '
 '     Last%       -  Last series to analyze
 '
 '  Return Values:
 '     Values in GE are altered.
 '
 '=================================================================
 SUB clAnalyzeS (N%, SLabels$(), First%, Last%)
 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED TTitleLayout AS TitleLayout
 SHARED XTitleLayout AS TitleLayout
 SHARED YTitleLayout AS TitleLayout
 SHARED V1(), V2()
 DIM Dum$(1 TO 1)

         ' Save the number of values and the number of series in the chart in
         ' the global parameter variables:
         GP.NVals = N%
         GP.NSeries = Last% - First% + 1

         ' Analyze data for scale-maximim and -minimum and scale-factor:
         clScaleAxis GE.XAxis, GP.XMode, V1()
         IF ChartErr > 100 THEN EXIT SUB

         clScaleAxis GE.YAxis, GP.YMode, V2()
         IF ChartErr > 100 THEN EXIT SUB

         ' Format tic labels (needed for sizing routines) and set global
         ' parameters (again used by sizing and other routines):
         clFormatTics GE.XAxis
         clFormatTics GE.YAxis
         clSetGlobalParams

         ' Layout Titles
         clLayoutTitle TTitleLayout, GE.MainTitle, GE.SubTitle
         clLayoutTitle YTitleLayout, GE.YAxis.AxisTitle, GE.YAxis.ScaleTitle
         clLayoutTitle XTitleLayout, GE.XAxis.AxisTitle, GE.XAxis.ScaleTitle

         ' If this is a multiple-series chart, calculate the legend size:
         IF GP.MSeries = cYes THEN clLayoutLegend SLabels$(), First%, Last%
         IF ChartErr > 100 THEN EXIT SUB

         ' Calculate the data window size:
         clSizeDataWindow Dum$()
         IF ChartErr > 100 THEN EXIT SUB

         ' Finally, figure out the distance between tic marks:
         clSpaceTics

 END SUB

 '=== clBuildBitP$ - Builds a pattern tile for a one bit-plane screen mode
 '
 '  Arguments:
 '     Bits%    =  Number of bits per pixel in this screen mode
 '
 '     C%       =  The color used to make the pattern.
 '
 '     InP$     =  Reference pattern
 '
 '  Return Values:
 '     Returns the specified pattern in specified color.
 '
 '  Remarks:
 '     In screen modes where a pixel on the screen is represented by 1 or
 '     more bits that are adjacent in memory, a byte of memory represents
 '     one or more pixels depending on the number of bits per pixel the
 '     mode uses (e.g. screen mode 1 uses 2 bits per pixel so each byte
 '     contains 4 pixels).  To make a pattern tile in a specific color
 '     you first decide which pixels should be on and which ones off.
 '     Then, you set the corresponding two-bit pixels in the tile bytes
 '     to the value of the color you want the pattern to be.  This routine
 '     does this semi-automatically.  First it inputs a reference pattern that
 '     contains the pattern defined in the highest color available for a
 '     screen mode (all bits in a pixel set to one).  Then a color mask byte
 '     is prepared with each pixel set to the color that was specified as
 '     input to the routine.  When these two components (reference pattern
 '     and color mask) are combined using a logical "AND" any pixel in the
 '     reference pattern that was black (all zero) will remain black and any
 '     pixel that was white will be of the input color.  The nice feature of
 '     this scheme is that you can use one pattern set for any color
 '     available for the screen mode.
 '
 '     Example: Screen mode 1; 2 bits per pixel; to build a pattern
 '              with pixels alternating on and off in color 2:
 '
 '     Reference pattern:   11 00 11 00    (8 bits = 1 byte)
 '     Color mask:          10 10 10 10    (each pixel set to color 2)
 '                         -------------
 '     Result of "AND"      10 00 10 00    (pattern in color 2)
 '
 '=================================================================
 FUNCTION clBuildBitP$ (Bits%, C%, InP$)

         ' First get color mask to match this color and pixel size (bits per p
         CMask% = clColorMaskL%(Bits%, C%)

         ' Initialize the output pattern to empty then combine the color
         ' mask with each byte in the input tile using a logical "AND":
         OutP$ = ""
         FOR i% = 1 TO LEN(InP$)
                 NxtCH% = CMask% AND ASC(MID$(InP$, i%, 1))
                 OutP$ = OutP$ + CHR$(NxtCH%)
         NEXT i%

         ' Return the completed pattern:
         clBuildBitP$ = OutP$

 END FUNCTION

 '=== clBuildPalette - Builds the five chart palettes
 '
 '  Arguments:
 '     N           -  Screen mode for which to build palettes
 '
 '  Return Values:
 '     Values in chart palettes set to standard ones for this mode
 '
 '  Remarks:
 '     The following code sets up the palettes that are referenced when the
 '     different chart elements are drawn.  See the charting library
 '     documentation for a complete description of how these palettes are
 '     used in drawing different portions of a chart.
 '
 '=================================================================
 SUB clBuildPalette (ScrnMode AS INTEGER, Bits AS INTEGER)
 SHARED PaletteC%(), PaletteS%(), PaletteP$(), PaletteCh%(), PaletteB%()
 SHARED StdChars%()
 SHARED GP AS GlobalParams

         ' Flag palette set and record the screen mode:
         GP.PaletteSet = cYes
         GP.PaletteScrn = ScrnMode
         GP.PaletteBits = Bits

         ' The first palettes to set are the character palette and the border
         ' style palette:
         PaletteCh%(0) = 0
         PaletteB%(0) = &HFFFF
         FOR i% = 1 TO cPalLen
                 PaletteCh%(i%) = StdChars%(i%)
                 PaletteB%(i%) = clGetStyle(i%)
         NEXT i%

         ' The next palette to set is the color palette, which is made up of
         ' a list of 10 (maybe repeating) colors.  Begin by setting the first
         ' two colors.  The first color (position 0) is always black and the
         ' second color is always white (or whatever the maximum color number
         ' is mapped to in the graphics-card palette).  Cycle through setting
         ' other colors.  They will be entered in order starting with color 1
         ' until the maximum number of colors is reached or the palette is fil
         ' (size governed by the cPalLen CONST).  If the maximum color is reac
         ' before the palette is filled then repeat the cycle again excluding
         ' color 0, and so on, until the color palette is filled:

         PaletteC%(0) = 0        ' Black
         PaletteC%(1) = GP.White ' White

         FOR i% = 2 TO cPalLen
                 MappedI% = ((i% - 2) MOD GP.MaxColor) + 1
                 PaletteC%(i%) = MappedI%
         NEXT i%

         ' Setting the line styles is almost the inverse of setting the colors
         ' in that each color within a cycle has the same line style.  When a
         ' new cycle of colors begins, though, the line style changes to
         ' differentiate the new cycle from previous ones.  The line style
         ' begins as &HFFFF or a solid line:

         ' The pattern component of the palette contains fill patterns for use
         ' filling bars and pie slices.  Fill patterns are "bit" oriented wher
         ' line styles are "pixel" oriented.  What this means is that a fill
         ' pattern of CHR$(&HFF) will be white regardless of what the current
         ' color is.  If you know that each pixel on the screen is represented
         ' 2 bits in RAM and you want a solid fill with color 2, the correspon
         ' definition would be CHR$(&HAA) (in binary 10 10 10 10 -- notice, fo
         ' pixels of two bits each set to 2).  The following code automaticall
         ' takes a fill pattern defined in terms of pixels, and by masking it
         ' with the current color generates the same fill pattern in the
         ' specified color.  Start with solid black (color 0):

         PaletteS%(0) = &HFFFF
         PaletteP$(0) = CHR$(0)

         FOR i% = 1 TO cPalLen

                 ' The cycle number starts at one and is incremented each time
                 ' the maximum number of colors for the current screen mode is
                 Cycle% = ((i% - 1) \ GP.MaxColor) + 1

                 ' Set the style palette from the standard styles (which have
                 ' previously been placed in the border palette):
                 PaletteS%(i%) = PaletteB%(Cycle%)

                 ' Get the default pattern and put it into the palette:
                 SELECT CASE ScrnMode

                         ' One bit plane modes:
                         CASE 1, 2, 11, 13: RefPattern$ = GetPattern$(Bits, Cy

                         ' Multiple bit plane modes:
                         CASE ELSE: RefPattern$ = GetPattern$(1, Cycle%)

                 END SELECT
                 PaletteP$(i%) = MakeChartPattern$(RefPattern$, PaletteC%(i%),

         NEXT i%

 END SUB

 '=== clBuildPlaneP$ - Builds a pattern tile for multiple bit-plane screen mod
 '
 '  Arguments:
 '     Bits%    =  Number of planes in this screen mode
 '
 '     C%       =  The color used to make the pattern
 '
 '     InP$     =  Reference pattern
 '
 '  Return Values:
 '     Returns the specified pattern in specified color
 '
 '  Remarks:
 '     PAINT tiles are different for screen modes that use 2 or more
 '     bit-planes than for the modes that use only one (see remarks for
 '     clBuildBitP$()).  When bit-planes are used each pixel requires only
 '     one bit per byte, but, there needs to be one byte for each bit-
 '     plane.  The process for building a pattern from a reference pattern
 '     and color mask are logically the same as in the one bit-plane modes
 '     the only difference is that a color mask requires several bytes
 '     (one for each bit-plane) rather than one.
 '
 '  Example: Screen mode 9 with 2 bit planes; pattern with alternating
 '           pixels on and off; color 2:
 '
 '           Reference pattern:   1 0 1 0 1 0 1 0
 '           Color mask:          0 0 0 0 0 0 0 0   (plane 1)
 '                                1 1 1 1 1 1 1 1   (plane 2)
 '                               -----------------
 '           Result of "AND"      0 0 0 0 0 0 0 0   (plane 1)
 '                                1 0 1 0 1 0 1 0   (plane 2)
 '
 '
 '=================================================================
 FUNCTION clBuildPlaneP$ (Bits%, C%, InP$)
 DIM CMask%(1 TO 4)

         ' First get color mask to match this color and pixel size (bits per p
         clColorMaskH Bits%, C%, CMask%()

         ' Initialize the output pattern to empty then combine the color
         ' mask with each byte in the input tile using a logical "AND":
         OutP$ = ""
         FOR TileByte% = 1 TO LEN(InP$)
                 RefTile% = ASC(MID$(InP$, TileByte%, 1))

                 ' Combine each bit-plane in the color mask with the pattern b
                 FOR Plane% = 1 TO Bits%
                         OutP$ = OutP$ + CHR$(RefTile% AND CMask%(Plane%))
                 NEXT Plane%
         NEXT TileByte%

         ' Return the completed pattern:
         clBuildPlaneP$ = OutP$

 END FUNCTION

 '=== clChkChartWindow - Makes sure the chart window is valid
 '
 '  Arguments:
 '     Env   -  A ChartEnvironment variable
 '
 '  Return Values:
 '     Changes global parameters for chart window
 '
 '  Remarks:
 '     This routine forces the chart window to be valid.  If the input
 '     values are invalid a full screen is chosen.  The valid chart window
 '     is stored in the global parameter set and used by other charting
 '     routines.  The last valid screen set by ChartScreen is used as
 '     reference.
 '
 '=================================================================
 SUB clChkChartWindow (Env AS ChartEnvironment)
 SHARED GP AS GlobalParams

         ' Make sure X1 < X2:
         IF Env.ChartWindow.X1 < Env.ChartWindow.X2 THEN
                 GP.CwX1 = Env.ChartWindow.X1
                 GP.CwX2 = Env.ChartWindow.X2
         ELSE
                 GP.CwX1 = Env.ChartWindow.X2
                 GP.CwX2 = Env.ChartWindow.X1
         END IF

         ' Make sure Y1 < Y2:
         IF Env.ChartWindow.Y1 < Env.ChartWindow.Y2 THEN
                 GP.CwY1 = Env.ChartWindow.Y1
                 GP.CwY2 = Env.ChartWindow.Y2
         ELSE
                 GP.CwY1 = Env.ChartWindow.Y2
                 GP.CwY2 = Env.ChartWindow.Y1
         END IF

         ' If the X coordinates of the chart window are invalid,
         ' set them to full screen:
         IF GP.CwX1 < 0 OR GP.CwX2 >= GP.MaxXPix OR GP.CwX1 = GP.CwX2 THEN
                 GP.CwX1 = 0
                 GP.CwX2 = GP.MaxXPix - 1
         END IF

         ' If the Y coordinates of the chart window are invalid,
         ' set them to full screen:
         IF GP.CwY1 < 0 OR GP.CwY2 >= GP.MaxYPix OR GP.CwY1 = GP.CwY2 THEN
                 GP.CwY1 = 0
                 GP.CwY2 = GP.MaxYPix - 1
         END IF

         ' Set chart height and width for use later:
         GP.ChartWid = GP.CwX2 - GP.CwX1 + 1
         GP.ChartHgt = GP.CwY2 - GP.CwY1 + 1

         ' Put the valid coordinates in Env:
         Env.ChartWindow.X1 = GP.CwX1
         Env.ChartWindow.Y1 = GP.CwY1
         Env.ChartWindow.X2 = GP.CwX2
         Env.ChartWindow.Y2 = GP.CwY2

 END SUB

 '=== clChkFonts - Checks that there is at least one loaded font
 '
 '  Arguments:
 '     none
 '
 '  Return Values:
 '     Chart error set if no room for a font
 '
 '=================================================================
 SUB clChkFonts

         ' See if a font is loaded:
         GetTotalFonts Reg%, Load%

         ' If not then find out the maximum number of fonts allowed and if
         ' there's room, then load the default font:
         IF Load% <= 0 THEN
                 GetMaxFonts MReg%, MLoad%
                 IF Reg% < MReg% AND Load% < MLoad% THEN
                         DefaultFont Segment%, Offset%
                         FontNum% = RegisterMemFont(Segment%, Offset%)
                         FontNum% = LoadFont("N" + STR$(Load% + 1))

                 ' If there's no room, then set an error:
                 ELSE
                         clSetError cNoFontSpace
                 END IF
         END IF
 END SUB

 '=== CheckForErrors - Checks for and tries to fix a variety of errors
 '
 '  Arguments:
 '     Env      -  ChartEnvironment variable
 '
 '     TypeMin% -  Minimum allowable ChartType
 '
 '     TypeMax% -  Maximum allowable ChartType
 '
 '     N%       -  Number of data values per series
 '
 '     First%   -  Column of data representing first series
 '
 '     Last%    -  Column of data representing last series
 '
 '  Return Values:
 '     This routine is the main one that checks for errors of input in
 '     the ChartEnvironment variable and routine parameters.
 '
 '=================================================================
 SUB clChkForErrors (Env AS ChartEnvironment, TypeMin%, TypeMax%, N%, First%,

         ' Clear any previous error:
         clClearError

         ' Check for correct chart type:
         IF Env.ChartType < TypeMin% OR Env.ChartType > TypeMax% THEN
                 clSetError cBadType
                 EXIT SUB
         END IF

         ' Check for valid chart style:
         IF Env.ChartStyle < 1 OR Env.ChartStyle > 2 THEN
                 clSetError cBadStyle
                 Env.ChartStyle = 1
         END IF

         ' The following things are not relevant for pie charts:
         IF Env.ChartType <> cPie THEN

                 ' Check LogBase for the X axis (default to 10):
                 IF Env.XAxis.RangeType = cLog AND Env.XAxis.LogBase <= 0 THEN
                         clSetError cBadLogBase
                         Env.XAxis.LogBase = 10
                 END IF

                 ' Check LogBase for the Y axis (default to 10):
                 IF Env.YAxis.RangeType = cLog AND Env.YAxis.LogBase <= 0 THEN
                         clSetError cBadLogBase
                         Env.YAxis.LogBase = 10
                 END IF

                 ' Check X axis ScaleFactor:
                 IF Env.XAxis.AutoScale <> cYes AND Env.XAxis.ScaleFactor = 0
                         clSetError cBadScaleFactor
                         Env.XAxis.ScaleFactor = 1
                 END IF

                 ' Check Y axis ScaleFactor:
                 IF Env.YAxis.AutoScale <> cYes AND Env.YAxis.ScaleFactor = 0
                         clSetError cBadScaleFactor
                         Env.YAxis.ScaleFactor = 1
                 END IF
         END IF

         ' Make sure N > 0:
         IF N% <= 0 THEN
                 clSetError cTooSmallN
                 EXIT SUB
         END IF

         ' Check that First series <= Last one:
         IF First% > Last% THEN
                 clSetError cTooFewSeries
                 EXIT SUB
         END IF

         ' Force ChartWindow to be valid:
         clChkChartWindow Env

 END SUB

 '=== clChkInit - Check that chartlib has been initialized
 '
 '  Arguments:
 '     none
 '
 '  Return Values:
 '     none
 '
 '=================================================================
 SUB clChkInit
 SHARED GP AS GlobalParams

         IF NOT GP.Initialized THEN clInitChart

 END SUB

 '=== clChkPalettes - Makes sure that palettes are dimensioned correctly
 '
 '  Arguments:
 '     C%()     -  Color palette array
 '
 '     S%()     -  Style palette array
 '
 '     P$()     -  Pattern palette array
 '
 '     Char%()  -  Plot character palette array
 '
 '     B%()     -  Border pattern palette array
 '
 '  Return Values:
 '     Chart error may be set to cBadPalette
 '
 '=================================================================
 SUB clChkPalettes (C() AS INTEGER, s() AS INTEGER, P$(), Char() AS INTEGER, B

         ' Check each palette array to be sure it is dimensioned from 0
         ' to cPalLen:
         FOR i% = 1 TO 5
                 SELECT CASE i%
                         CASE 1:  L% = LBOUND(C, 1): U% = UBOUND(C, 1)
                         CASE 2:  L% = LBOUND(s, 1): U% = UBOUND(s, 1)
                         CASE 3:  L% = LBOUND(P$, 1): U% = UBOUND(P$, 1)
                         CASE 4:  L% = LBOUND(Char, 1): U% = UBOUND(Char, 1)
                         CASE 5:  L% = LBOUND(B, 1): U% = UBOUND(B, 1)
                 END SELECT

                 ' If incorrectly dimensioned then set error:
                 IF (L% <> 0) OR (U% <> cPalLen) THEN
                         clSetError cBadPalette
                         EXIT SUB
                 END IF
         NEXT i%

 END SUB

 '=== clClearError - Clears ChartErr, the ChartLib error variable
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     Sets ChartErr to 0
 '
 '=================================================================
 SUB clClearError

         ChartErr = 0

 END SUB

 '=== clColorMaskH% - Function to generate a byte with each pixel set to
 '                  some color - for high-res modes (7,8,9,10)
 '
 '  Arguments:
 '     Bits%    -  Number of bits per pixel in current screen mode
 '
 '     Colr%    -  Color to make the mask
 '
 '     CMask%() -  One dimensional array to place mask values in
 '
 '  Return Values:
 '     Screen modes 7, 8, 9 and 10 use bit planes.  Rather than using
 '     adjacent bits in one byte to determine a color, they use bits
 '     "stacked" on top of each other in different bytes.  This routine
 '     generates one byte of a particular color by setting the different
 '     levels of the stack to &H00 and &HFF to represent eight pixels
 '     of a particular color.
 '
 '=================================================================
 SUB clColorMaskH (Bits%, Colr%, CMask%())

         ' Copy the color to a local variable:
         RefColor% = Colr%

         ' Bits% is the number of bit planes, set a mask for each one:
         FOR i% = 1 TO Bits%

                 ' Check rightmost bit in color, if it is set to 1 then this p
                 ' "on" (it equals &HFF):
                 IF RefColor% MOD 2 <> 0 THEN
                         CMask%(i%) = &HFF

                 ' If the bit is 0, the plane is off (it equals &H0):
                 ELSE
                         CMask%(i%) = &H0
                 END IF

                 ' Shift the reference color right by one bit:
                 RefColor% = RefColor% \ 2
         NEXT i%

 END SUB

 '=== clColorMaskL% - Function to generate a byte with each pixel set to
 '                 some color.
 '
 '  Arguments:
 '     Bits%    -  Number of bits per pixel in current screen mode
 '
 '     Colr%    -  Color to make the mask
 '
 '  Return Values:
 '     Returns integer with low byte that contains definitions for
 '     pixels of specified color.
 '
 '=================================================================
 FUNCTION clColorMaskL% (Bits%, Colr%)

         ' Initialize the mask to zero:
         M% = 0

         ' Multiplying a number by (2 ^ Bits%) will shift it left by "Bits%" b
         LShift% = 2 ^ Bits%

         ' Create a byte in which each pixel (of "Bits%" bits) is set to
         ' Colr%.  This is done by setting the mask to "Colr%" then shifting
         ' it left by "Bits%" and repeating until the byte is full:
         FOR i% = 0 TO 7 \ Bits%
                 M% = M% * LShift% + Colr%
         NEXT i%

         ' Return the mask as the value of the function:
         clColorMaskL% = M% MOD 256

 END FUNCTION

 '=== clDrawAxes - Draws the axes for a chart
 '
 '  Arguments:
 '     Cat$(1)  -  One-dimensional array or category names for use in
 '                 labeling the category axis (ignored if category
 '                 axis not used)
 '
 '  Return Values:
 '     No return values
 '
 '=================================================================
 SUB clDrawAxes (Cat$())
 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED GFI AS FontInfo
 SHARED PaletteC%(), PaletteB%()

         ' Use temporary variables to refer to axis limits:
         X1 = GE.XAxis.ScaleMin
         X2 = GE.XAxis.ScaleMax
         Y1 = GE.YAxis.ScaleMin
         Y2 = GE.YAxis.ScaleMax

         ' To draw the tic/grid lines it is necessary to know where the line
         ' starts and ends.  If tic marks are specified (by setting
         ' the "labeled" flag in the axis definition) then the
         ' tic lines start "ticwidth" below or to the left of the X and
         ' Y axis respectively.  If grid lines are specified then the
         ' tic/grid line ends at ScaleMax for the respective axis.  The
         ' case statements below calculate where the tic/grid lines start
         ' based on the above criteria.

         ' Check for tic marks first (X Axis):
         SELECT CASE GE.XAxis.Labeled
                 CASE cNo:  XTicMinY = Y1
                 CASE ELSE
                         XTicMinY = Y1 - cTicSize * (Y2 - Y1)
                         IF GP.XStagger = cYes THEN
                                 clSetChartFont GE.XAxis.TicFont
                                 XTicDropY = GFI.PixHeight * (Y2 - Y1) / (GE.D
                         ELSE
                                 XTicDropY = 0
                         END IF
         END SELECT

         ' (Y Axis):
         SELECT CASE GE.YAxis.Labeled
                 CASE cNo:  YTicMinX = X1
                 CASE ELSE: YTicMinX = X1 - cTicSize * (X2 - X1)
         END SELECT

         ' Now for the other end of the tic/grid lines check for
         ' the grid flag (X axis):
         SELECT CASE GE.XAxis.grid
                 CASE cNo:  XTicMaxY = Y1
                 CASE ELSE: XTicMaxY = Y2
         END SELECT

         ' (Y Axis):
         SELECT CASE GE.YAxis.grid
                 CASE cNo:  YTicMaxX = X1
                 CASE ELSE: YTicMaxX = X2
         END SELECT

         ' Now that the beginning and end of the tic/grid lines has been
         ' calculated, it is necessary to figure out where they fall along the
         ' axes.  This depends on the type of axis: category or value.  On a
         ' category axis the tic/grid lines should fall in the middle of each
         ' bar set.  This is calculated by adding 1/2 of TicInterval to
         ' the beginning of the axis.  On a value axis the tic/grid line
         ' falls at the beginning of the axis.  It is also necessary to know
         ' the total number of tics per axis.  The following CASE statements
         ' calculate this.  Once the first tic/grid location on an axis is
         ' calculated the others can be calculated as they are drawn by adding
         ' TicInterval each time to the position of the previous tic mark:

         ' Location of the first (leftmost) tic/grid line on the X axis:
         TicTotX% = CINT((X2 - X1) / GE.XAxis.TicInterval)
         SELECT CASE GP.XMode
                 CASE cCategory: TicX = X1 + GE.XAxis.TicInterval / 2
                 CASE ELSE
                         TicX = X1
                         TicTotX% = TicTotX% + 1
         END SELECT

         ' Location of the first (top) tic/grid line on the Y axis:
         TicTotY% = CINT((Y2 - Y1) / GE.YAxis.TicInterval)
         SELECT CASE GP.YMode
                 CASE cCategory: TicY = Y1 + GE.YAxis.TicInterval / 2
                 CASE ELSE
                         TicY = Y1
                         TicTotY% = TicTotY% + 1
         END SELECT

         ' Now it's time to draw the axes; first the X then the Y axis.
         ' There's a small complexity that has to be dealt with first, though.
         ' The tic/grid lines are specified in "world" coordinates since that
         ' is easier to calculate but the current VIEW (the DataWindow) would
         ' clip them since tic marks (and also labels) lie outside of that
         ' region.  The solution is to extrapolate the DataWindow "world" to t
         ' ChartWindow region and set our VIEW to the ChartWindow.  This will
         ' clip labels if they are too long and try to go outside the Chart
         ' Window but still allow use of world coordinates for specifying
         ' locations.  To extrapolate the world coordinates to the ChartWindow
         ' PMAP can be used.  This works since PMAP can take pixel coordinates
         ' outside of the current VIEW and map them to the appropriate world
         ' coordinates.  The DataWindow coordinates (calculated in the routine
         ' clSizeDataWindow) are expressed relative to the ChartWindow so
         ' it can be somewhat complicated trying to understand what to use wit
         ' PMAP.  If you draw a picture of it things will appear more straight
         ' forward.

         ' To make sure that bars and columns aren't drawn over the axis lines
         ' temporarily move the left DataWindow border left by one and the bot
         ' border down by one pixel:
         GE.DataWindow.X1 = GE.DataWindow.X1 - 1
         GE.DataWindow.Y2 = GE.DataWindow.Y2 + 1

         ' Select the DataWindow view and assign the "world" to it:
         clSelectRelWindow GE.DataWindow
         WINDOW (X1, Y1)-(X2, Y2)
         GTextWindow X1, Y1, X2, Y2, cFalse

         ' Next, use PMAP to extrapolate to ChartWindow:
         WorldX1 = PMAP(-GE.DataWindow.X1, 2)
         WorldX2 = PMAP(GP.ChartWid - 1 - GE.DataWindow.X1, 2)

         WorldY1 = PMAP(GP.ChartHgt - 1 - GE.DataWindow.Y1, 3)
         WorldY2 = PMAP(-GE.DataWindow.Y1, 3)

         ' Reset the DataWindow borders back to their original settings:
         GE.DataWindow.X1 = GE.DataWindow.X1 + 1
         GE.DataWindow.Y2 = GE.DataWindow.Y2 - 1

         ' Finally, select the ChartWindow VIEW and apply the extrapolated
         ' window to it:
         clSelectChartWindow
         WINDOW (WorldX1, WorldY1)-(WorldX2, WorldY2)
         GTextWindow WorldX1, WorldY1, WorldX2, WorldY2, cFalse

          ' Draw the X and Y axes (one pixel to left and bottom of window):
         CX% = PaletteC%(clMap2Pal%(GE.XAxis.AxisColor))  ' Color of X axis
         CY% = PaletteC%(clMap2Pal%(GE.YAxis.AxisColor))  ' Color of Y axis

         SX% = PaletteB%(clMap2Pal%(GE.XAxis.GridStyle)) ' Line styles; X grid
         SY% = PaletteB%(clMap2Pal%(GE.YAxis.GridStyle)) ' Line styles; Y grid

         LINE (X1, Y1)-(X2, Y1), CX%
         LINE (X1, Y1)-(X1, Y2), CY%

         ' X-Axis...Draw styled grid line then solid tic mark:
         TicLoc = TicX
         Stagger% = cFalse
         FOR i% = 1 TO TicTotX%
                 LINE (TicLoc, Y1)-(TicLoc, XTicMaxY), CY%, , SX%
                 IF Stagger% THEN
                         LINE (TicLoc, XTicMinY - XTicDropY)-(TicLoc, Y1), CX%
                         Stagger% = cFalse
                 ELSE
                         LINE (TicLoc, XTicMinY)-(TicLoc, Y1), CX%
                         Stagger% = cTrue
                 END IF
                 TicLoc = TicLoc + GE.XAxis.TicInterval
         NEXT i%

         ' Y-Axis...Draw styled grid line then solid tic mark:
         TicLoc = TicY
         FOR i% = 1 TO TicTotY%
                 LINE (X1, TicLoc)-(YTicMaxX, TicLoc), CX%, , SY%
                 LINE (YTicMinX, TicLoc)-(X1, TicLoc), CY%
                 TicLoc = TicLoc + GE.YAxis.TicInterval
         NEXT i%

         ' Label X tic marks and print titles:
         clLabelXTics GE.XAxis, Cat$(), TicX, TicTotX%, XTicMinY, YBoundry%
         clTitleXAxis GE.XAxis, GE.DataWindow.X1, GE.DataWindow.X2, YBoundry%

         ' Label Y tic marks and print titles:
         clLabelYTics GE.YAxis, Cat$(), YTicMinX, TicY, TicTotY%
         clTitleYAxis GE.YAxis, GE.DataWindow.Y1, GE.DataWindow.Y2

 END SUB

 '=== clDrawBarData - Draws data portion of multi-series bar chart
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clDrawBarData
 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED PaletteC%()
 SHARED V1()

         ' Set the VIEW to the DataWindow:
         clSelectRelWindow GE.DataWindow

         ' Set the WINDOW to match:
         WINDOW (GE.XAxis.ScaleMin, GE.YAxis.ScaleMin)-(GE.XAxis.ScaleMax, GE.
         GTextWindow GE.XAxis.ScaleMin, GE.YAxis.ScaleMin, GE.XAxis.ScaleMax,

         ' If this is a linear axis then determine where the bars should grow
         IF GE.XAxis.RangeType = cLinear THEN

                 ' If the scale minimum and maximum are on opposite sides of z
                 ' set the bar starting point to zero:
                 IF GE.XAxis.ScaleMin < 0 AND GE.XAxis.ScaleMax > 0 THEN
                         BarMin = 0

                 ' If the axis range is all negative the the bars should grow
                 ' the right to the left so make the bar starting point the sc
                 ' maximum:
                 ELSEIF GE.XAxis.ScaleMin < 0 THEN
                         BarMin = GE.XAxis.ScaleMax

                 ' The axis range is all positive so the bar starting point is
                 ' scale minimum:
                 ELSE
                         BarMin = GE.XAxis.ScaleMin
                 END IF

         ' The bar starting point for log axes should always be the scale mini
         ' since only positive numbers are represented on a log axis (even tho
         ' the log of small numbers is negative):
         ELSE
                 BarMin = GE.XAxis.ScaleMin
         END IF

         ' Calculate the width of a bar.  Divide by the number of
         ' series if it's a plain (not stacked) chart:
         BarWid = GE.YAxis.TicInterval * cBarWid
         IF GE.ChartStyle = cPlain THEN BarWid = BarWid / GP.NSeries

         ' Calculate the beginning Y value of first bar then loop drawing
         ' all the bars:
         SpaceWid = GE.YAxis.TicInterval * (1 - cBarWid)
         StartLoc = GE.YAxis.ScaleMax - SpaceWid / 2

         FOR i% = 1 TO GP.NVals

                 ' Reset sum variables for positive and negative stacked bars:
                 RSumPos = 0
                 RSumNeg = 0

                 ' Reset the bar starting points:
                 BarStartPos = BarMin
                 BarStartNeg = BarMin

                 ' Reset starting Y location of this bar set:
                 BarLoc = StartLoc

                 ' Now, chart the different series for this category:
                 FOR J% = 1 TO GP.NSeries

                         ' Get the value to chart from the data array:
                         V = V1(i%, J%)

                         ' If the value isn't a missing one then try to chart
                         IF V <> cMissingValue THEN

                                 ' If the X-axis has the AutoScale flag set th
                                 ' the value by the axis' ScaleFactor variable
                                 IF GE.XAxis.AutoScale = cYes THEN V = V / GE.

                                 ' If this is a plain chart then calculate the
                                 ' and draw it:
                                 IF GE.ChartStyle = cPlain THEN

                                         BarLoc = StartLoc - (J% - 1) * BarWid
                                         clRenderBar BarMin, BarLoc, V, BarLoc

                                 ' If the bars should be stacked then draw eit
                                 ' negative portion of a bar depending on whet
                                 ' is positive or negative:
                                 ELSE

                                         ' If the value is positive:
                                         IF V > 0 THEN

                                                 ' Add the value to the curren
                                                 ' the bar from the top of the
                                                 RSumPos = RSumPos + V
                                                 clRenderBar BarStartPos, BarL
                                                 BarStartPos = RSumPos

                                         ' If the value is negative:
                                         ELSE

                                                 ' Add the value to the curren
                                                 ' the bar from the bottom of
                                                 RSumNeg = RSumNeg + V
                                                 clRenderBar BarStartNeg, BarL
                                                 BarStartNeg = RSumNeg

                                         END IF
                                 END IF
                         END IF

                 NEXT J%

                 ' Update the bar cluster's starting location:
                 StartLoc = StartLoc - GE.YAxis.TicInterval

         NEXT i%

         ' If BarMin isn't the axis minimum then draw a reference line:
         IF BarMin <> GE.XAxis.ScaleMin THEN
                 LINE (BarMin, GE.YAxis.ScaleMin)-(BarMin, GE.YAxis.ScaleMax),
         END IF

 END SUB

 '=== clDrawChartWindow - Draws the Chart window
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     None
 '
 '  Remarks:
 '     This routine erases any previous viewport
 '
 '=================================================================
 SUB clDrawChartWindow
 SHARED GE AS ChartEnvironment

         ' Define viewport then render window:
         clSelectChartWindow
         clRenderWindow GE.ChartWindow

 END SUB

 '=== clDrawColumnData - Draws data portion of MS Column chart
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clDrawColumnData
 SHARED GP AS GlobalParams, GE AS ChartEnvironment
 SHARED PaletteC%(), V1()

         ' First, set the VIEW to DataWindow:
         clSelectRelWindow GE.DataWindow

         ' Set the WINDOW to match:
         WINDOW (GE.XAxis.ScaleMin, GE.YAxis.ScaleMin)-(GE.XAxis.ScaleMax, GE.
         GTextWindow GE.XAxis.ScaleMin, GE.YAxis.ScaleMin, GE.XAxis.ScaleMax,

         ' If this is a linear axis then determine where the bars should grow
         IF GE.YAxis.RangeType = cLinear THEN

                 ' Draw 0 reference line if the scale minimum and maximum are
                 ' opposite sides of zero.  Also set the bar starting point to
                 ' so that bars grow from the zero line:
                 IF GE.YAxis.ScaleMin < 0 AND GE.YAxis.ScaleMax > 0 THEN
                         BarMin = 0

                 ' If the axis range is all negative the the bars should grow
                 ' the right to the left so make the bar starting point the sc
                 ' maximum:
                 ELSEIF GE.YAxis.ScaleMin < 0 THEN
                         BarMin = GE.YAxis.ScaleMax

                 ' The axis range is all positive so the bar starting point is
                 ' scale minimum:
                 ELSE
                         BarMin = GE.YAxis.ScaleMin
                 END IF

         ' The bar starting point for log axes should always be the scale mini
         ' since only positive numbers are represented on a log axis (even tho
         ' the log of small numbers is negative):
         ELSE
                 BarMin = GE.YAxis.ScaleMin
         END IF

         ' Calculate the width of a bar.  Divide by the number of
         ' series if it's a plain (not stacked) chart:
         BarWid = GE.XAxis.TicInterval * cBarWid
         IF GE.ChartStyle = cPlain THEN BarWid = BarWid / GP.NSeries

         ' calculate the beginning X value of first bar and loop, drawing all
         ' the bars:
         SpaceWid = GE.XAxis.TicInterval * (1 - cBarWid)
         StartLoc = GE.XAxis.ScaleMin + SpaceWid / 2

         FOR i% = 1 TO GP.NVals

                 ' Reset sum variables for positive and negative stacked bars:
                 RSumPos = 0
                 RSumNeg = 0

                 BarStartPos = BarMin
                 BarStartNeg = BarMin

                 ' Reset starting Y location of this bar set:
                 BarLoc = StartLoc

                 ' Now, go across the rows charting the different series for
                 ' this category:
                 FOR J% = 1 TO GP.NSeries

                         ' Get the value to chart from the data array:
                         V = V1(i%, J%)

                         ' If the value isn't a missing one then try to chart
                         IF V <> cMissingValue THEN

                                 ' If the Y-axis has the AutoScale flag set th
                                 ' the value by the axis' ScaleFactor variable
                                 IF GE.YAxis.AutoScale = cYes THEN V = V / GE.

                                 ' If this is a plain chart then calculate the
                                 ' and draw it:
                                 IF GE.ChartStyle = cPlain THEN

                                         BarLoc = StartLoc + (J% - 1) * BarWid
                                         clRenderBar BarLoc, BarMin, BarLoc +

                                 ' If the bars should be stacked then draw eit
                                 ' negative portion of a bar depending on whet
                                 ' is positive or negative:
                                 ELSE

                                         ' If the value is positive:
                                         IF V > 0 THEN

                                                 ' Add the value to the curren
                                                 ' the bar from the top of the
                                                 RSumPos = RSumPos + V
                                                 clRenderBar BarLoc, BarStartP
                                                 BarStartPos = RSumPos

                                         ' If the value is negative:
                                         ELSE

                                                 ' Add the value to the curren
                                                 ' the bar from the bottom of
                                                 RSumNeg = RSumNeg + V
                                                 clRenderBar BarLoc, BarStartN
                                                 BarStartNeg = RSumNeg

                                         END IF
                                 END IF
                         END IF

                 NEXT J%

                 ' Update the bar cluster's starting location:
                 StartLoc = StartLoc + GE.XAxis.TicInterval

         NEXT i%

         ' If BarMin isn't the axis minimum then draw a reference line:
         IF BarMin <> GE.YAxis.ScaleMin THEN
                 LINE (GE.XAxis.ScaleMin, BarMin)-(GE.XAxis.ScaleMax, BarMin),
         END IF

 END SUB

 '=== clDrawDataWindow - Draws the Data window
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     None
 '
 '  Remarks:
 '     This routine erases any previous viewport or window specification.
 '
 '=================================================================
 SUB clDrawDataWindow
 SHARED GE AS ChartEnvironment

         ' Define viewport then render window:
         clSelectRelWindow GE.DataWindow
         clRenderWindow GE.DataWindow

 END SUB

 '=== clDrawLegend - Draws a legend
 '
 '  Arguments:
 '     SeriesLabel$(1)   - Array of labels for the legend
 '
 '     First%            - Label number corresponding to first series
 '
 '     Last%             - Label number corresponding to last series
 '
 '  Return Values:
 '     None.
 '
 '=================================================================
 SUB clDrawLegend (SeriesLabel$(), First AS INTEGER, Last AS INTEGER)

 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED PaletteC%(), PaletteP$(), PaletteCh%()
 SHARED GFI AS FontInfo
 SHARED LLayout AS LegendLayout

         ' If legend flag is No then exit:
         IF GE.Legend.Legend = cNo THEN EXIT SUB

         ' Select and render the legend window:
         clSelectRelWindow GE.Legend.LegendWindow
         clRenderWindow GE.Legend.LegendWindow
         WINDOW
         GTextWindow 0, 0, 0, 0, cFalse

         ' Start with the first label, set the Y position of the first line
         ' of labels and loop through all the rows in the legend:
         clSetChartFont GE.Legend.TextFont
         LabelNum% = First
         YPos% = LLayout.HorizBorder
         FOR i% = 1 TO LLayout.NumRow

                 ' Set position of beginning of row:
                 XPos% = LLayout.VertBorder

                 FOR J% = 1 TO LLayout.NumCol

                         ' Map the label number to a valid palette reference:
                         MJ% = clMap2Pal%(LabelNum% - First + 1)

                         ' Depending on ChartType draw either a filled box or
                         ' plot character used for plotting:
                         XStep% = LLayout.SymbolSize / GP.Aspect
                         SELECT CASE GE.ChartType

                                 CASE cBar, cColumn, cPie:
                                         LINE (XPos%, YPos%)-STEP(XStep%, LLay
                                         LINE (XPos%, YPos%)-STEP(XStep%, LLay
                                         PAINT (XPos% + 1, YPos% + 1), Palette
                                         LINE (XPos%, YPos%)-STEP(XStep%, LLay

                                 CASE cLine, cScatter:
                                         clSetCharColor MJ%
                                         PlotChr$ = CHR$(PaletteCh%(MJ%))
                                         clHPrint XPos% + XStep% - GFI.AvgWidt

                         END SELECT

                         ' Print the label for this entry in the legend:
                         clSetCharColor GE.Legend.TextColor
                         clHPrint XPos% + LLayout.LabelOffset, YPos% - GFI.Lea

                         ' Increment the label count and check count has finis
                         LabelNum% = LabelNum% + 1
                         IF LabelNum% > Last THEN EXIT SUB

                         ' Move over to the next column:
                         XPos% = XPos% + LLayout.ColSpacing

                 NEXT J%

                 ' Move position to the next row:
                 YPos% = YPos% + LLayout.RowSpacing

         NEXT i%

 END SUB

 '=== clDrawLineData - Draws data portion line chart
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clDrawLineData
 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED PaletteC%(), PaletteS%(), PaletteCh%()
 SHARED GFI AS FontInfo
 SHARED V1()

         ' First, set the appropriate font and make text horizontal:
         clSetChartFont GE.DataFont
         SetGTextDir 0

         ' Then, set the view to DataWindow:
         clSelectRelWindow GE.DataWindow

         ' Set the window to match:
         WINDOW (GE.XAxis.ScaleMin, GE.YAxis.ScaleMin)-(GE.XAxis.ScaleMax, GE.
         GTextWindow GE.XAxis.ScaleMin, GE.YAxis.ScaleMin, GE.XAxis.ScaleMax,

         ' Loop through the series:
         FOR J% = 1 TO GP.NSeries

                 ' Map the series number into a valid palette reference:
                 MJ% = clMap2Pal%(J%)

                 ' Calculate starting X location of first point and set
                 ' last value to missing (since this is the first value in the
                 ' series the last value wasn't there):
                 StartLoc = GE.XAxis.ScaleMin + GE.XAxis.TicInterval / 2
                 LastMissing% = cYes

                 FOR i% = 1 TO GP.NVals

                         ' Get a value from the data array:
                         V = V1(i%, J%)

                         ' If the value is missing, set the LastMissing flag t
                         ' go to the next value:
                         IF V = cMissingValue THEN
                                 LastMissing% = cYes

                         ' If the value is not missing then try to chart it:
                         ELSE

                                 ' Scale the value (and convert it to a log if
                                 ' Log axis):
                                 IF GE.YAxis.AutoScale = cYes THEN V = V / GE.

                                 ' If the style dictates lines and the last po
                                 ' missing then draw a line between the last p
                                 IF GE.ChartStyle = cLines AND LastMissing% <>
                                         LINE -(StartLoc, V), PaletteC%(MJ%),
                                 END IF

                                 ' Position and print character:
                                 CX% = PMAP(StartLoc, 0) - GetGTextLen(CHR$(Pa
                                 CY% = PMAP(V, 1) - GFI.Ascent / 2
                                 clSetCharColor MJ%
                                 clHPrint CX%, CY%, CHR$(PaletteCh%(MJ%))

                                 PSET (StartLoc, V), POINT(StartLoc, V)

                                 LastMissing% = cNo
                         END IF

                         ' Move to next category position:
                         StartLoc = StartLoc + GE.XAxis.TicInterval
                 NEXT i%
         NEXT J%

 END SUB

 '=== clDrawPieData - Draws data part of a pie chart
 '
 '  Arguments:
 '     Value(1)    -  One-dimensional array of data values
 '
 '     Expl(1)     -  One-dimensional array of explode flags (1=explode, 0=no)
 '
 '     N%          -  The number of data values to plot
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clDrawPieData (value() AS SINGLE, Expl() AS INTEGER, N AS INTEGER)
 SHARED GE AS ChartEnvironment
 SHARED GP AS GlobalParams
 SHARED GFI AS FontInfo
 SHARED PaletteC%(), PaletteP$()

         ' Set the font to use for percent labels:
         clSetChartFont GE.DataFont

         ' Set up some reference variables:
         Pi2 = 2 * cPiVal                  ' 2*PI for radians conversions
         MinAngle = Pi2 / 120              ' Smallest wedge to try to paint
         A1 = -.0000001                    ' Starting and ending angle (set
         A2 = A1                           ' to very small negative to get


         ' Size the pie.
         ' Choose the point in the middle of the data window for the pie cente
         WINDOW (0, 0)-(1, 1)
         X = PMAP(.5, 0)                  ' Distance: left to center
         Y = PMAP(.5, 1)                  ' Distance: bottom to center
         WINDOW                           ' Now, use physical coordinates (pix
         GTextWindow 0, 0, 0, 0, cFalse

         ' Adjust radii for percent labels if required:
         clSetChartFont GE.DataFont
         IF GE.ChartStyle = cPercent THEN
                 RadiusX = (X - 6 * GFI.AvgWidth) * GP.Aspect
                 RadiusY = Y - 2 * GFI.PixHeight
         ELSE
                 RadiusX = X * GP.Aspect
                 RadiusY = Y
         END IF

         ' Pick the smallest radius (adjusted for screen aspect) then reduce
         ' it by 10% so the pie isn't too close to the window border:
         IF RadiusX < RadiusY THEN
                 Radius = RadiusX
         ELSE
                 Radius = RadiusY
         END IF
         Radius = (.9 * Radius) / GP.Aspect

         ' If radius is too small then error:
         IF Radius <= 0 THEN
                 clSetError cBadDataWindow
                 EXIT SUB
         END IF

         ' Find the sum of the data values (use double precision Sum variable
         ' protect against overflow if summing large data values):
         Sum# = 0
         FOR i% = 1 TO GP.NSeries
                 IF value(i%) > 0 THEN Sum# = Sum# + value(i%)
         NEXT i%

         ' Loop through drawing and painting the wedges:
         FOR i% = 1 TO N

                 ' Map I% to a valid palette reference:
                 MappedI% = clMap2Pal(i%)

                 ' Draw wedges for positive values only:
                 IF value(i%) > 0 THEN

                         ' Calculate wedge percent and wedge ending angle:
                         Percent = value(i%) / Sum#
                         A2 = A1 - Percent * Pi2

                         ' This locates the angle through the center of the pi
                         ' calculates X and Y components of the vector headed
                         ' direction:
                         Bisect = (A1 + A2) / 2
                         BisectX = Radius * COS(Bisect)
                         BisectY = Radius * SIN(Bisect) * GP.Aspect

                         ' If the piece is exploded then offset it 1/10th of a
                         ' along the bisecting angle calculated above:
                         IF Expl(i%) <> 0 THEN
                                 CX = X + .1 * BisectX
                                 CY = Y + .1 * BisectY
                         ELSE
                                 CX = X
                                 CY = Y
                         END IF

                         ' If the angle is large enough, paint the wedge (if w
                         ' smaller angles are painted, the "paint" will someti
                         IF (A1 - A2) > MinAngle THEN
                                 PX = CX + .8 * BisectX
                                 PY = CY + .8 * BisectY

                                 ' Outline the wedge in color 1 and paint it b
                                 CIRCLE (CX, CY), Radius, 1, A1, A2, GP.Aspect
                                 PAINT (PX, PY), 0, 1
                                 ' Paint with the appropriate pattern:
                                 PAINT (PX, PY), PaletteP$(MappedI%), 1
                         END IF
                         ' draw the wedge in the correct color:
                         CIRCLE (CX, CY), Radius, PaletteC%(MappedI%), A1, A2,

                         ' Label pie wedge with percent if appropriate:
                         IF GE.ChartStyle = cPercent THEN
                                 Label$ = clVal2Str$(Percent * 100, 1, 1) + "%
                                 LabelX% = CX + BisectX + (GFI.AvgWidth * COS(
                                 LabelY% = CY + BisectY + (GFI.AvgWidth * SIN(

                                 ' Adjust label location for the quadrant:
                                 Quadrant% = FIX((ABS(Bisect / Pi2)) * 4)
                                 IF Quadrant% = 0 OR Quadrant% = 1 THEN
                                         LabelY% = LabelY% - GFI.Ascent
                                 END IF
                                 IF Quadrant% = 1 OR Quadrant% = 2 THEN
                                         LabelX% = LabelX% - GetGTextLen(Label
                                 END IF

                                 clSetCharColor GE.Legend.TextColor
                                 clHPrint LabelX%, LabelY%, Label$
                         END IF
                 END IF

                 ' Set the beginning of next wedge to the end of this one:
                 A1 = A2

         NEXT i%

 END SUB

 '=== clDrawScatterData - Draws data portion of Scatter chart
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clDrawScatterData
 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED PaletteC%(), PaletteS%(), PaletteCh%()
 SHARED GFI AS FontInfo
 SHARED V1(), V2()

         ' Select the chart font and make text output horizontal:
         clSetChartFont GE.DataFont
         SetGTextDir 0

         ' Now, loop through all the points charting them:
         FOR Series% = 1 TO GP.NSeries

                 ' Set LastMissing flag to Yes for first point in series:
                 LastMissing% = cYes
                 MS% = clMap2Pal%(Series%)

                 ' Loop through all the points, charting them:
                 FOR DataPoint% = 1 TO GP.NVals

                         ' Get the X-value and Y-values from the data arrays:
                         VX = V1(DataPoint%, Series%)
                         VY = V2(DataPoint%, Series%)

                         ' If either of the values to chart is missing set Las
                         ' flag to Yes to indicate a missing point and go to t
                         IF VX = cMissingValue OR VY = cMissingValue THEN
                                 LastMissing% = cYes

                         ELSE

                                 ' Otherwise, scale the X and Y values if Auto
                                 ' their respective axes:
                                 IF GE.XAxis.AutoScale = cYes THEN VX = VX / G
                                 IF GE.YAxis.AutoScale = cYes THEN VY = VY / G

                                 ' If this is a lined chart and the last point
                                 ' then draw a line from last point to the cur
                                 IF GE.ChartStyle = cLines AND LastMissing% <>
                                         LINE -(VX, VY), PaletteC%(MS%), , Pal
                                 END IF

                                 ' In any case draw the plot character.  Start
                                 ' screen coordinates of the character relativ
                                 ' just charted:
                                 CX% = PMAP(VX, 0) - GetGTextLen(CHR$(PaletteC
                                 CY% = PMAP(VY, 1) - GFI.Ascent / 2

                                 ' Now, set the character color and print it:
                                 clSetCharColor MS%
                                 clHPrint CX%, CY%, CHR$(PaletteCh%(MS%))

                                 ' Finally, reset the graphics cursor, since p
                                 ' character changed it:
                                 PSET (VX, VY), POINT(VX, VY)

                                 LastMissing% = cNo
                         END IF

                 NEXT DataPoint%
         NEXT Series%
 END SUB

 '=== clDrawTitles - Draws the main and subtitles on a chart
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clDrawTitles
 SHARED GE AS ChartEnvironment
 SHARED TTitleLayout AS TitleLayout

         ' Bottom of main title line is 1-1/2 character heights from the
         ' top of the chart window:
         YPos% = TTitleLayout.Top
         clPrintTitle GE.MainTitle, YPos%

         ' Add 1.5 * character height to y position for subtitle line position
         YPos% = YPos% + TTitleLayout.TitleOne + TTitleLayout.Middle
         clPrintTitle GE.SubTitle, YPos%

 END SUB

 '=== clFilter - Filters input data into dynamic working data array
 '
 '  Arguments:
 '     Axis     -  An AxisType variable
 '
 '     AxisMode%-  Mode for this axis
 '
 '     D1(1)    -  One-dimensional array of input data
 '
 '     D2(2)    -  Two-dimensional array for filtered data
 '
 '     N%       -  The number of values to transfer
 '
 '  Return Values:
 '     Alters values in D2()
 '
 '=================================================================
 SUB clFilter (Axis AS AxisType, AxisMode%, D1(), D2(), N%)

         ' If the axis is a category one then exit:
         IF AxisMode% = cCategory THEN EXIT SUB

         ' Transfer the data from the input data array to the working data
         ' array:
         FOR i% = 1 TO N%
                 D2(i%, 1) = D1(i%)
         NEXT i%

         ' Call FilterMS to go through the data again scaling it and taking
         ' logs depending on the settings for this axis:
         clFilterMS Axis, AxisMode%, D2(), D2(), N%, 1, 1

 END SUB

 '=== clFilterMS - Filters two-dimensional input data into the dynamic working
 '               data array
 '
 '  Arguments:
 '     Axis     -  An AxisType variable
 '
 '     AxisMode%-  Axis mode for the axis
 '
 '     D1(2)    -  Two-dimensional array of input data
 '
 '     D2(2)    -  Two-dimensional array for filtered data
 '
 '     N%       -  The number of values to transfer
 '
 '     First%   -  First data series to filter
 '
 '     Last%    -  Last data series to filter
 '
 '  Return Values:
 '     Alters values in D2()
 '
 '=================================================================
 SUB clFilterMS (Axis AS AxisType, AxisMode%, D1(), D2(), N%, First%, Last%)

         ' If the axis is a category axis then exit:
         IF AxisMode% = cCategory THEN EXIT SUB

         ' If this isn't an autoscale axis, use the scale factor from the
         ' environment.  If it is an autoscale axis don't scale at all now
         ' it will be done when the data is drawn on the screen:
         IF Axis.AutoScale = cNo THEN
                 ScaleFactor = Axis.ScaleFactor
         ELSE
                 ScaleFactor = 1
         END IF

         ' If this a log axis calculate the log base:
         IF AxisMode% = cLog THEN LogRef = LOG(Axis.LogBase)

         ' Loop through the data series:
         FOR J% = First% TO Last%

                 ' Loop through the values within the series:
                 FOR i% = 1 TO N%

                         ' Get a data value and if it isn't missing, then scal
                         V = D1(i%, J%)
                         IF V <> cMissingValue THEN V = V / ScaleFactor

                         ' If the axis is a log axis, then if the value is gre
                         ' it is safe to take it's log.  Otherwise, set the da
                         ' missing:
                         IF Axis.RangeType = cLog THEN
                                  IF V > 0 THEN
                                         V = LOG(V) / LogRef
                                 ELSE
                                         V = cMissingValue
                                 END IF
                         END IF

                         ' Place the value in the output data array:
                         D2(i%, J% - First% + 1) = V

                 NEXT i%

         NEXT J%

 END SUB

 '=== clFlagSystem - Sets GP.SysFlag to cYes
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     Alters the value of GP.SysFlag
 '
 '=================================================================
 SUB clFlagSystem
 SHARED GP AS GlobalParams

         GP.SysFlag = cYes

 END SUB

 '=== clFormatTics - Figures out tic label format and TicDecimals.
 '
 '  Arguments:
 '     Axis     -  AxisType variable for which to format tics.
 '
 '  Return Values:
 '     The TicFormat and Decimals elements may be changed for an axis
 '     if AutoTic is cYes.
 '
 '=================================================================
 SUB clFormatTics (Axis AS AxisType)

         ' If AutoScale isn't Yes then exit
         IF Axis.AutoScale <> cYes THEN EXIT SUB

         ' If the size of the largest value is bigger than seven decimal
         ' places then set TicFormat to exponential.  Otherwise, set it
         ' to normal:
         IF ABS(Axis.ScaleMin) >= 10 ^ 8 OR ABS(Axis.ScaleMax) >= 10 ^ 8 THEN
                 Axis.TicFormat = cExpFormat
         ELSE
                 Axis.TicFormat = cNormFormat
         END IF

         ' Pick the largest of the scale max and min (in absolute value) and
         ' use that to decide how many decimals to use when displaying the tic
         ' labels:
         Range = ABS(Axis.ScaleMax)
         IF ABS(Axis.ScaleMin) > Range THEN Range = ABS(Axis.ScaleMin)
         IF Range < 10 THEN
                 TicResolution = -INT(-ABS(LOG(Range) / LOG(10!))) + 1
                 IF TicResolution > 9 THEN TicResolution = 9
                 Axis.TicDecimals = TicResolution
         ELSE
                 Axis.TicDecimals = 0
         END IF

 END SUB

 '=== clGetStyle - Returns a predefined line-style definition
 '
 '  Arguments:
 '     StyleNum%   -  A number identifying the entry to return
 '
 '  Return Values:
 '     Returns the line-style for the specified style number
 '
 '=================================================================
 FUNCTION clGetStyle% (StyleNum%)

         SELECT CASE StyleNum%
                 CASE 1: Style% = &HFFFF
                 CASE 2: Style% = &HF0F0
                 CASE 3: Style% = &HF060
                 CASE 4: Style% = &HCCCC
                 CASE 5: Style% = &HC8C8
                 CASE 6: Style% = &HEEEE
                 CASE 7: Style% = &HEAEA
                 CASE 8: Style% = &HF6DE
                 CASE 9: Style% = &HF6F6
                 CASE 10: Style% = &HF56A
                 CASE 11: Style% = &HCECE
                 CASE 12: Style% = &HA8A8
                 CASE 13: Style% = &HAAAA
                 CASE 14: Style% = &HE4E4
                 CASE 15: Style% = &HC88C
         END SELECT
         clGetStyle% = Style%

 END FUNCTION

 '=== clHPrint - Prints text Horizontally on the screen
 '
 '  Arguments:
 '     X     -  X position for the lower left of the first character to be
 '              printed (in absolute screen coordinates)
 '
 '     Y     -  Y position for the lower left of the first character to be
 '              printed (in absolute screen coordinates)
 '
 '     Txt$  -  Text to print
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clHPrint (X%, Y%, Txt$)

         ' Map the input coordinates relative to the current viewport:
         X = PMAP(X%, 2)
         Y = PMAP(Y%, 3)

         ' Output the text horizontally:
         SetGTextDir 0
         TextLen% = OutGText(X, Y, Txt$)

 END SUB

 '=== clInitChart - Initializes the charting library.
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     None
 '
 '  Remarks:
 '     This routine initializes some default data structures and is
 '     called automatically by charting routines if the variable
 '     GP.Initialized is cNo (or zero).
 '
 '=================================================================
 SUB clInitChart
 SHARED StdChars%(), GP AS GlobalParams

         ' Clear any previous errors
         clClearError

         ON ERROR GOTO UnexpectedErr

         ' Initialize PaletteSet to no so palettes will be initialized properl
         ' when ChartScreen is called:
         GP.PaletteSet = cNo

         ' Set up the list of plotting characters:
         PlotChars$ = "*ox=+/:&#@%![$^"
         StdChars%(0) = 0
         FOR i% = 1 TO cPalLen
                 StdChars%(i%) = ASC(MID$(PlotChars$, i%, 1))
         NEXT i%

         ' Initialize standard structures for title, axis, window and legend:
         clInitStdStruc

         GP.Initialized = cYes

 END SUB

 '=== clInitStdStruc - Initializes structures for standard titles, axes, etc.
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clInitStdStruc
 SHARED DAxis AS AxisType, DWindow AS RegionType
 SHARED DLegend AS LegendType, DTitle AS TitleType

 ' Set up default components of the default chart
 ' environment; start with default title:

 ' Default title definition:
 DTitle.Title = ""                ' Title text is blank
 DTitle.TitleFont = 1             ' Title font is first one
 DTitle.TitleColor = 1            ' Title color is white
 DTitle.Justify = cCenter         ' Center justified

 ' Default axis definition:
 DAxis.grid = cNo                 ' No grid
 DAxis.GridStyle = 1              ' Solid lines for grid
 DAxis.AxisTitle = DTitle         ' Use above to initialize axis title
 DAxis.AxisColor = 1              ' Axis color is white
 DAxis.Labeled = cYes             ' Label and tic axis
 DAxis.RangeType = cLinear        ' Linear axis
 DAxis.LogBase = 10               ' Logs to base 10
 DAxis.AutoScale = cYes           ' Automatically scale numbers if needed
 DAxis.ScaleTitle = DTitle        ' Scale title
 DAxis.TicFont = 1                ' Tic font is first one
 DAxis.TicDecimals = 0            ' No decimals

 ' Default window definition:
 DWindow.Background = 0           ' Black background
 DWindow.Border = cNo             ' Window will have no border
 DWindow.BorderColor = 1          ' Make the borders white
 DWindow.BorderStyle = 1          ' Solid-line borders

 ' Default legend definition:
 DLegend.Legend = cYes            ' Draw a legend if multi-series chart
 DLegend.Place = cRight           ' On the right side
 DLegend.TextColor = 1            ' Legend text is white on black
 DLegend.TextFont = 1             ' Legend text font is first one
 DLegend.AutoSize = cYes          ' Figure out size automatically
 DLegend.LegendWindow = DWindow   ' Use the default window specification

 END SUB

 '=== clLabelXTics - Labels tic marks for X axis
 '
 '  Arguments:
 '     Axis     -  An AxisType variable containing axis specification
 '
 '     Cat$(1)  -  One-dimensional array of category labels.  Ignored
 '                 if axis not category axis
 '
 '     TicX     -  X coordinate of first tic mark
 '
 '     TicY     -  Y coordinate of tic tip (portion away from axis)
 '
 '     YBoundry% -  Y coordinate of bottom of tic labels
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clLabelXTics (Axis AS AxisType, Cat$(), TicX, TicTotX%, TicY, YBoundry%)
 SHARED GFI AS FontInfo
 SHARED GP AS GlobalParams
 SHARED GE AS ChartEnvironment

         ' If this axis isn't supposed to be labeled then exit:
         IF Axis.Labeled <> cYes THEN EXIT SUB

         ' Set the appropriate color, font, and orientation for tic labels:
         clSetCharColor Axis.AxisColor
         clSetChartFont Axis.TicFont
         SetGTextDir 0

         ' The Y coordinate of the labels will be a constant .5 character
         ' heights below the end of the tic marks (TicY):
         Y% = PMAP(TicY, 1) + (GFI.Ascent - GFI.Leading) / 2
         IF GP.XStagger = cYes THEN
                 YDrop% = (3 * GFI.Ascent - GFI.Leading) / 2
         ELSE
                 YDrop% = 0
         END IF
         YBoundry% = Y% + YDrop% + GFI.PixHeight

         ' Loop through and write labels
         TX = TicX
         CatNum% = 1
         Stagger% = cFalse
         FOR i% = 1 TO TicTotX%

                 ' The label depends on axis mode (category, value):
                 SELECT CASE GP.XMode
                         CASE cCategory: Txt$ = Cat$(CatNum%)
                         CASE ELSE:      Txt$ = clVal2Str$(TX, Axis.TicDecimal
                 END SELECT
                 TxtLen% = GetGTextLen(Txt$)
                 IF GP.XMode = cCategory THEN
                         MaxLen% = 2 * (GE.DataWindow.X2 - GE.DataWindow.X1) /
                         IF MaxLen% < 0 THEN MaxLen% = 0
                         DO UNTIL TxtLen% <= MaxLen%
                                 Txt$ = LEFT$(Txt$, LEN(Txt$) - 1)
                                 TxtLen% = GetGTextLen(Txt$)
                         LOOP
                 END IF

                 ' Center the label under the tic mark and print it:
                 X% = PMAP(TX, 0) - (TxtLen%) / 2

                 IF Stagger% THEN
                         clHPrint X%, Y% + YDrop%, Txt$
                         Stagger% = cFalse
                 ELSE
                         clHPrint X%, Y%, Txt$
                         Stagger% = cTrue
                 END IF

                 ' Move to the next tic mark:
                 TX = TX + Axis.TicInterval
                 CatNum% = CatNum% + 1
         NEXT i%

 END SUB

 '=== clLabelYTics - Labels tic marks and draws Y axis title
 '
 '  Arguments:
 '     Axis     -  An AxisType variable containing axis specification
 '
 '     Cat$(1)  -  One-dimensional array of category labels.  Ignored
 '                 if axis not category axis
 '
 '     TicX     -  X coordinate of first tic's tip (away from axis)
 '
 '     TicY     -  Y coordinate of first tic
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clLabelYTics (Axis AS AxisType, Cat$(), TicX, TicY, TicTotY%)
 SHARED GFI AS FontInfo
 SHARED GP AS GlobalParams

         ' If axis isn't supposed to be labeled then exit:
         IF Axis.Labeled <> cYes THEN EXIT SUB

         ' Set the appropriate color, font, and orientation for tic labels:
         clSetCharColor Axis.AxisColor
         clSetChartFont Axis.TicFont
         SetGTextDir 0

         ' Loop through and write labels
         TY = TicY
         CatNum% = 1
         FOR i% = 1 TO TicTotY%

                 ' The label depends on axis mode (category, value):
                 SELECT CASE GP.YMode
                         CASE cCategory: Txt$ = Cat$(GP.NVals - CatNum% + 1)
                         CASE ELSE:      Txt$ = clVal2Str$(TY, Axis.TicDecimal
                 END SELECT
                 TxtLen% = GetGTextLen(Txt$)

                 ' Space the label 1/2 character width to the left of the tic
                 ' mark and center it vertically on the tic mark (round vertic
                 ' location to the next highest integer):
                 X% = PMAP(TicX, 0) - TxtLen% - (.5 * GFI.MaxWidth)
                 Y% = -INT(-(PMAP(TY, 1) - (GFI.Ascent + GFI.Leading) / 2))

                 ' Print the label:
                 clHPrint X%, Y%, Txt$

                 ' Go to the next tic mark:
                 TY = TY + Axis.TicInterval
                 CatNum% = CatNum% + 1
         NEXT i%

 END SUB

 '=== clLayoutLegend - Calculates size of the legend
 '
 '  Arguments:
 '     SeriesLabel$(1) - The labels used in the legend
 '
 '     First%   - The first series (label) to process
 '
 '     Last%    - The last series (label) to process
 '
 '  Return Values:
 '     The coordinates in the legend window portion of Env are altered
 '
 '  Remarks:
 '     Sizing the legend window requires finding out where it goes (right
 '     or bottom) and determining how big the labels are and how big
 '     the legend needs to be to hold them.
 '
 '=================================================================
 SUB clLayoutLegend (SeriesLabel$(), First%, Last%)
 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED GFI AS FontInfo
 SHARED LLayout AS LegendLayout
 SHARED TTitleLayout AS TitleLayout
 DIM W AS RegionType

         ' If "no legend" is specified, then exit:
         IF GE.Legend.Legend = cNo THEN EXIT SUB

         ' This may be an auto legend or not, but, in either case we're
         ' going to need the following information:
         clSetChartFont GE.Legend.TextFont

         LLayout.SymbolSize = GFI.Ascent - GFI.Leading - 1
         LLayout.HorizBorder = GFI.Ascent
         LLayout.VertBorder = GFI.AvgWidth
         LLayout.RowSpacing = 1.75 * (LLayout.SymbolSize + 1)
         LLayout.LabelOffset = LLayout.SymbolSize / GP.Aspect + GFI.AvgWidth

         'RowLeading% = LLayout.RowSpacing - LLayout.SymbolSize
         RowLeading% = .75 * LLayout.SymbolSize + 1.75

         ColWid% = clMaxStrLen(SeriesLabel$(), First%, Last%) + LLayout.LabelO
         LLayout.ColSpacing = ColWid% + GFI.AvgWidth

         ' If this isn't an autosize legend:
         IF GE.Legend.AutoSize = cNo THEN

                 ' Check the legend coordinates supplied by the user to make
                 ' sure that they are valid.  If they are, exit:
                 W = GE.Legend.LegendWindow
                 LWid% = W.X2 - W.X1
                 LHgt% = W.Y2 - W.Y1
                 IF LWid% > 0 AND LHgt% > 0 THEN

                         ' Calculate the number of columns and rows of labels
                         ' fit in the legend:
                         NumCol% = INT((LWid% - LLayout.VertBorder) / (LLayout
                         IF NumCol% <= 0 THEN NumCol% = 1
                         IF NumCol% > GP.NSeries THEN NumCol% = GP.NSeries
                         NumRow% = -INT(-GP.NSeries / NumCol%)
                         LLayout.NumRow = NumRow%
                         LLayout.NumCol = NumCol%

                         ' Re-calculate the column and row spacing:
                         LLayout.ColSpacing = INT((LWid% - LLayout.VertBorder)
                         LLayout.RowSpacing = INT((LHgt% - 2 * LLayout.HorizBo

                         EXIT SUB

                 ' If invalid legend coordinates are discovered set an error a
                 ' go on to calculate new ones:
                 ELSE

                   clSetError cBadLegendWindow

                 END IF
         END IF

         ' Do remaining calculations according to the legend placement specifi
         ' (right, bottom, overlay):
         SELECT CASE GE.Legend.Place

                 CASE cRight, cOverlay:

                         ' Leave room at top for chart titles:
                         Top% = TTitleLayout.TotalSize

                         ' Figure out the maximum number of legend rows that w
                         ' fit in the amount of space you have left for the le
                         ' height.  Then, see how many columns are needed.  On
                         ' the number of columns is set refigure how many rows
                         ' required:
                         NumRow% = INT((GP.ChartHgt - Top% - 2 * LLayout.Horiz
                         IF NumRow% > GP.NSeries THEN NumRow% = GP.NSeries
                         NumCol% = -INT(-GP.NSeries / NumRow%)
                         NumRow% = -INT(-GP.NSeries / NumCol%)

                         ' Set the width and height:
                         LWid% = NumCol% * LLayout.ColSpacing - GFI.AvgWidth +
                         LHgt% = (NumRow% * LLayout.RowSpacing - RowLeading% +

                         ' Place the legend one character width from right and
                         ' what will be the top of the data window:
                         LLft% = GP.ChartWid - 1 - LWid% - GFI.AvgWidth
                         LTop% = Top%

                 CASE cBottom:

                         ' The number of label columns that will fit (using th
                         ' procedure as above except figure columns first):
                         NumCol% = INT((GP.ChartWid - 2 * LLayout.HorizBorder)
                         IF NumCol% > GP.NSeries THEN NumCol% = GP.NSeries
                         NumRow% = -INT(-GP.NSeries / NumCol%)
                         NumCol% = -INT(-GP.NSeries / NumRow%)

                         ' Set the width and height:
                         LWid% = NumCol% * LLayout.ColSpacing - GFI.AvgWidth +
                         LHgt% = (NumRow% * LLayout.RowSpacing - RowLeading% +

                         ' Center the legend horizontally one character from t
                         LLft% = (GP.ChartWid - 1 - LWid%) / 2
                         LTop% = GP.ChartHgt - 1 - LHgt% - GFI.Ascent

         END SELECT

         ' Record legend columns and rows:
         LLayout.NumRow = NumRow%
         LLayout.NumCol = NumCol%

         ' Finally, place the legend coordinates in GE:
         GE.Legend.LegendWindow.X1 = LLft%
         GE.Legend.LegendWindow.Y1 = LTop%
         GE.Legend.LegendWindow.X2 = LLft% + LWid%
         GE.Legend.LegendWindow.Y2 = LTop% + LHgt%

         ' If, after all this, the legend window is invalid, set error:
         IF LLft% < 0 OR LTop% < 0 OR LWid% <= 0 OR LHgt% <= 0 THEN
                 clSetError cBadLegendWindow
         END IF

 END SUB

 '=== clLayoutTitle - Figures out title layouts for Top, X-axis and
 '                      Y-axis titles
 '
 '  Arguments:
 '     TL    -  Layout variable into which to place titles
 '
 '     T1    -  First title
 '
 '     T2    -  Second Title
 '
 '  Return Values:
 '     none
 '
 '=================================================================
 SUB clLayoutTitle (TL AS TitleLayout, T1 AS TitleType, T2 AS TitleType)
 SHARED GFI AS FontInfo

         ' Set the title heights initially to 0:
         TL.TitleOne = 0
         TL.TitleTwo = 0

         ' If the first title is set then get its height:
         Total% = 0
         IF LTRIM$(T1.Title) <> "" THEN
                 clSetChartFont T1.TitleFont
                 TL.TitleOne = GFI.PixHeight
                 Total% = Total% + 1
         END IF

         ' If the second title is set then get it's height:
         IF LTRIM$(T2.Title) <> "" THEN
                 clSetChartFont T2.TitleFont
                 TL.TitleTwo = GFI.PixHeight
                 Lead2% = GFI.Leading
                 Total% = Total% + 1
         END IF

         ' Set the "leading" values for label spacing depending on how many
         ' of the titles were non-blank:
         TotalHeight% = TL.TitleOne + TL.TitleTwo
         SELECT CASE Total%
                 CASE 0:
                         TL.Top = 8
                         TL.Middle = 0
                         TL.Bottom = 4

                 CASE 1:
                         TL.Top = 8 + TotalHeight% / 8
                         TL.Middle = 0
                         TL.Bottom = TL.Top

                 CASE 2:
                         TL.Top = 8 + TotalHeight% / 8
                         TL.Middle = 0: IF Lead2% = 0 THEN TL.Middle = TL.Titl
                         TL.Bottom = TL.Top
         END SELECT

         TL.TotalSize = TL.Top + TL.TitleOne + TL.Middle + TL.TitleTwo + TL.Bo

 END SUB

 '=== clMap2Attrib% - Maps an integer to a screen attribute for current
 '                    screen mode
 '
 '  Arguments:
 '     N% - The number to map
 '
 '  Return Values:
 '     The function returns:
 '        0 is mapped to 0, all other numbers are mapped to the range
 '        1 to GP.MaxColor
 '
 '=================================================================
 FUNCTION clMap2Attrib% (N%)
 SHARED GP AS GlobalParams

         AbsN% = ABS(N%)
         IF AbsN% = 0 THEN
                 clMap2Attrib% = AbsN%
         ELSE
                 clMap2Attrib% = (AbsN% - 1) MOD GP.MaxColor + 1
         END IF

 END FUNCTION

 '=== clMap2Pal% - Maps an integer into a palette reference
 '
 '  Arguments:
 '     N% - The number to map
 '
 '  Return Values:
 '     The function returns (N%-1) MOD cPalLen + 1
 '
 '  Remarks:
 '     This FUNCTION is used in almost every reference to a palette to ensure
 '     that an invalid number doesn't cause a reference outside of a palette
 '     array (and thus crash the library).  This FUNCTION maps the first
 '     cPalLen values to themselves. Numbers above cPalLen are mapped to
 '     the values 2..cPalLen.
 '
 '=================================================================
 FUNCTION clMap2Pal% (N%)

         AbsN% = ABS(N%)
         IF AbsN% > cPalLen THEN
                 clMap2Pal% = (AbsN% - 2) MOD (cPalLen - 1) + 2
         ELSE
                 clMap2Pal% = AbsN%
         END IF

 END FUNCTION

 '=== clMaxStrLen% - Finds the length of the longest string in a list
 '
 '  Arguments:
 '     Txt$(1)  -  One-dimensional array of strings to search
 '
 '     First%   -  First string to consider
 '
 '     Last%    -  Last string to consider
 '
 '  Return Values:
 '     This FUNCTION returns the length of the longest string
 '
 '=================================================================
 FUNCTION clMaxStrLen% (Txt$(), First%, Last%)

         ' Set Max to 0 then loop through each label updating Max if the
         ' label is longer:
         Max% = 0
         FOR Row% = First% TO Last%
                 L% = GetGTextLen(Txt$(Row%))
                 IF L% > Max% THEN Max% = L%
         NEXT Row%

         ' Return Max as the value of the FUNCTION:
         clMaxStrLen% = Max%

 END FUNCTION

 '=== clMaxVal - Returns the maximum of two numbers
 '
 '  Arguments:
 '     A  -  The first number
 '
 '     B  -  The second number
 '
 '  Return Values:
 '     The function returns the maximum of the two values
 '
 '=================================================================
 FUNCTION clMaxVal (A, B)

         IF A > B THEN clMaxVal = A ELSE clMaxVal = B

 END FUNCTION

 '=== clPrintTitle - Prints title correctly justified and colored
 '
 '  Arguments:
 '     TitleVar - A TitleType variable containing specifications for the
 '                title to be printed
 '
 '     Y%       - Vertical position in window for bottom of line
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clPrintTitle (TitleVar AS TitleType, Y%)
 SHARED GFI AS FontInfo, GP AS GlobalParams

         ' Calculate width of the title text:
         clSetChartFont TitleVar.TitleFont

         Txt$ = RTRIM$(TitleVar.Title)
         TxtLen% = GetGTextLen(Txt$)
         IF TxtLen% = 0 THEN EXIT SUB

         ' Calculate horizontal position depending on justification style
         SELECT CASE TitleVar.Justify

                 CASE cCenter: X% = (GP.ChartWid - 1 - (TxtLen%)) / 2
                 CASE cRight:  X% = GP.ChartWid - 1 - TxtLen% - GFI.AvgWidth
                 CASE ELSE:    X% = GFI.AvgWidth

         END SELECT

         ' Set color of text and print it:
         clSetCharColor TitleVar.TitleColor
         clHPrint X%, Y%, Txt$

 END SUB

 '=== clRenderBar - Renders a bar for a bar or column chart
 '
 '  Arguments:
 '     X1    -  Left side of bar (in data world coordinates)
 '
 '     Y1    -  Top of bar (in data world coordinates)
 '
 '     X2    -  Right side of bar (in data world coordinates)
 '
 '     Y2    -  Bottom of bar (in data world coordinates)
 '
 '     C%    -  Palette entry number to use for border color and fill pattern
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clRenderBar (X1, Y1, X2, Y2, C%)
 SHARED PaletteC%(), PaletteP$()

         ' First clear out space for the bar by drawing a bar in black:
         LINE (X1, Y1)-(X2, Y2), 0, BF

         ' Put a border around the bar and fill with pattern:
         MC% = clMap2Pal%(C%)

         LINE (X1, Y1)-(X2, Y2), 1, B
         PAINT ((X1 + X2) / 2, (Y1 + Y2) / 2), PaletteP$(MC%), 1
         LINE (X1, Y1)-(X2, Y2), PaletteC%(MC%), B

 END SUB

 '=== clRenderWindow - Renders a window on the screen
 '
 '  Arguments:
 '     W - A RegionType variable
 '
 '  Return Values:
 '     None
 '
 '  Remarks:
 '     This routine assumes that the viewport is set to the borders of
 '     the window to be rendered
 '
 '=================================================================
 SUB clRenderWindow (W AS RegionType)
 SHARED PaletteC%(), PaletteB%()

         ' Set window since the size of the viewport is unknown and draw
         ' a filled box of the background color specified by the window
         ' definition:
         WINDOW (0, 0)-(1, 1)
         LINE (0, 0)-(1, 1), PaletteC%(clMap2Pal%(W.Background)), BF

         ' Draw a border if specified:
         IF W.Border = cYes THEN
                 LINE (0, 0)-(1, 1), PaletteC%(clMap2Pal%(W.BorderColor)), B,
         END IF

 END SUB

 '=== clScaleAxis - Calculates minimum, maximum and scale factor for an axis
 '
 '  Arguments:
 '     A        - An AxisType variable
 '
 '     AxisMode%- cCategory or cValue
 '
 '     D1(2)    - Two-dimensional array of values to be scaled
 '
 '  Return Values:
 '     ScaleMin, ScaleMax, ScaleFactor, and ScaleTitle elements in
 '     axis variable will be altered if it is a category axis or
 '     AutoScale is Yes.
 '
 '=================================================================
 SUB clScaleAxis (Axis AS AxisType, AxisMode%, D1())
 SHARED GE AS ChartEnvironment, GP AS GlobalParams

         ' If this is a category axis then ignore all the flags and force
         ' scale parameters to those needed by charting routines:
         IF AxisMode% = cCategory THEN
                 Axis.ScaleMin = 0
                 Axis.ScaleMax = 1
                 Axis.ScaleFactor = 1
                 Axis.ScaleTitle.Title = ""
                 EXIT SUB
         END IF

         ' If AutoScale isn't Yes then exit:
         IF Axis.AutoScale <> cYes THEN EXIT SUB

         ' AutoScale was specified, calculate the different scale variables
         ' Set maximum and minimum to defaults.

         ' Initialize the value- and row-minimum and maximum values to zero:
         VMin = 0
         VMax = 0

         RMin = 0
         RMax = 0

         ' Compare data values for minimum and maximum:
         FOR Row% = 1 TO GP.NVals

                 ' Initialize positive and negative sum variables:
                 RSumPos = 0
                 RSumNeg = 0

                 ' Evaluate the value from this row in each series:
                 FOR Column% = 1 TO GP.NSeries

                         ' Get the value from the data array:
                         V = D1(Row%, Column%)

                         ' Process values that aren't missing only:
                         IF V <> cMissingValue THEN

                                 ' Add positive values to positive sum and neg
                                 ' negative sum:
                                 IF V > 0 THEN RSumPos = RSumPos + V
                                 IF V < 0 THEN RSumNeg = RSumNeg + V

                                 ' Compare the value against current maximum a
                                 ' replace them if appropriate:
                                 IF V < VMin THEN VMin = V
                                 IF V > VMax THEN VMax = V

                         END IF

                 NEXT Column%

                 ' Compare the positive and negative sums for this row with th
                 ' current row maximum and minimum and replace them if appropr
                 IF RSumNeg < RMin THEN RMin = RSumNeg
                 IF RSumPos > RMax THEN RMax = RSumPos

         NEXT Row%

         ' If the chart style is one, meaning that the data isn't stacked for
         ' bar and column charts, or it is a line or scatter chart then the sc
         ' minimum and maximum are the minimum and maximum values found.
         ' Each value is adjusted so the data is not drawn on or beyond the
         ' border of the data window:
         IF GE.ChartStyle = 1 OR GE.ChartType = cLine OR GE.ChartType = cScatt
                 IF VMin < 0 THEN
                         Axis.ScaleMin = VMin - .01 * (VMax - VMin)
                 END IF
                 IF VMax > 0 THEN
                         Axis.ScaleMax = VMax + .01 * (VMax - VMin)
                 END IF

         ' Otherwise, the scale minimum and maximum are the minimum and maximu
         ' sums of the data for each row:
         ELSE
                 IF RMin < 0 THEN
                         Axis.ScaleMin = RMin - .01 * (RMax - RMin)
                 END IF
                 IF RMax > 0 THEN
                         Axis.ScaleMax = RMax + .01 * (RMax - RMin)
                 END IF
         END IF

         ' If no data then force range to be non-zero:
         IF Axis.ScaleMin = Axis.ScaleMax THEN Axis.ScaleMax = 1

         ' Adjust the scale limits by ScaleFactor if required:
         clAdjustScale Axis

 END SUB

 '=== clSelectChartFont - Selects a font to use and gets info about it
 '
 '  Arguments:
 '     N%    -  Font number to use
 '
 '  Return Values:
 '     none
 '
 '=================================================================
 SUB clSelectChartFont (N%)
 SHARED GFI AS FontInfo

         ' Select the font and get information about it:
         SelectFont N%
         GetFontInfo GFI
 END SUB

 '=== clSelectChartWindow - Sets viewport to chart window
 '
 '  Arguments:
 '     Env         - A ChartEnvironment variable
 '
 '  Return Values:
 '     None
 '
 '  Remarks:
 '     This routine erases any previous viewport
 '
 '=================================================================
 SUB clSelectChartWindow
 SHARED GP AS GlobalParams

         ' Set viewport to chart window:
         VIEW (GP.CwX1, GP.CwY1)-(GP.CwX2, GP.CwY2)

 END SUB

 '=== clSelectRelWindow - Sets viewport to window relative to chart window
 '
 '  Arguments:
 '     Env   - A ChartEnvironment variable
 '
 '     W     - RegionType variable of window to set
 '
 '  Return Values:
 '     None
 '
 '  Remarks:
 '     This routine erases any previous viewport
 '
 '=================================================================
 SUB clSelectRelWindow (W AS RegionType)
 SHARED GP AS GlobalParams

         ' New viewport is defined relative to the current one:
         VIEW (GP.CwX1 + W.X1, GP.CwY1 + W.Y1)-(GP.CwX1 + W.X2, GP.CwY1 + W.Y2

 END SUB

 '=== clSetAxisModes - Sets axis modes for X- and Y-axis according to
 '                   ChartType
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     Alters XAxis and YAxis axis modes
 '
 '=================================================================
 SUB clSetAxisModes
 SHARED GE AS ChartEnvironment
 SHARED GP AS GlobalParams

         SELECT CASE GE.ChartType

                 CASE cBar:
                         GP.XMode = cValue
                         GP.YMode = cCategory

                 CASE cColumn, cLine:
                         GP.XMode = cCategory
                         GP.YMode = cValue

                 CASE cScatter:
                         GP.XMode = cValue
                         GP.YMode = cValue

                 CASE cPie:
                         GP.XMode = cCategory
                         GP.YMode = cCategory

         END SELECT

 END SUB

 '=== clSetCharColor - Sets color for DRAW characters
 '
 '  Arguments:
 '     N%    -  Color number
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clSetCharColor (N%)
 SHARED PaletteC%()

         ' Check for valid color number then set color if correct:
         SetGTextColor PaletteC%(clMap2Pal%(N%))

 END SUB

 '=== clSetChartFont - Selects the specified font
 '
 '  Arguments:
 '     N%    -  Number of loaded font to select
 '
 '  Return Values:
 '     none
 '
 '=================================================================
 SUB clSetChartFont (N AS INTEGER)
 SHARED GFI AS FontInfo

         ' Select font and get information on it:
         SelectFont N%
         GetFontInfo GFI

 END SUB

 '=== clSetError - Sets the ChartLib error variable
 '
 '  Arguments:
 '     ErrNo    - The error number to set
 '
 '  Return Values:
 '     Sets ChartErr to ErrNo
 '
 '=================================================================
 SUB clSetError (ErrNo AS INTEGER)

         ChartErr = ErrNo

 END SUB

 '=== clSetGlobalParams - Sets some global parameters that other routines use
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     GP.ValLenX and GP.ValLenY are altered
 '
 '=================================================================
 SUB clSetGlobalParams
 SHARED GP AS GlobalParams, GE AS ChartEnvironment

         ' Figure out longest label on X axis:
         clSetChartFont GE.XAxis.TicFont
         SF = GE.XAxis.ScaleMin
         Len1 = GetGTextLen(clVal2Str$(SF, GE.XAxis.TicDecimals, GE.XAxis.TicF
         SF = GE.XAxis.ScaleMax
         Len2 = GetGTextLen(clVal2Str$(SF, GE.XAxis.TicDecimals, GE.XAxis.TicF
         GP.ValLenX = clMaxVal(Len1, Len2)

         ' Figure out longest label on Y axis:
         clSetChartFont GE.YAxis.TicFont
         SF = GE.YAxis.ScaleMin
         Len1 = GetGTextLen(clVal2Str$(SF, GE.YAxis.TicDecimals, GE.YAxis.TicF
         SF = GE.YAxis.ScaleMax
         Len2 = GetGTextLen(clVal2Str$(SF, GE.YAxis.TicDecimals, GE.YAxis.TicF
         GP.ValLenY = clMaxVal(Len1, Len2)

 END SUB

 '=== clSizeDataWindow - Calculates general data window size
 '
 '  Arguments:
 '     Cat$(1)  - One-dimensional array of category labels (only
 '                used if one of the axes is a category one)
 '
 '  Return Values:
 '     The X1, Y1, X2, Y2 elements of the GE variable will be
 '     set to the data window coordinates
 '
 '=================================================================
 SUB clSizeDataWindow (Cat$())
 SHARED GE AS ChartEnvironment
 SHARED GP AS GlobalParams
 SHARED GFI AS FontInfo
 SHARED TTitleLayout AS TitleLayout
 SHARED XTitleLayout AS TitleLayout
 SHARED YTitleLayout AS TitleLayout

         ' *** TOP
         ' Adjust the top of the data window:
         DTop% = TTitleLayout.TotalSize

         ' *** LEFT
         ' Do left side:
         DLeft% = YTitleLayout.TotalSize

         ' Add room for axis labels if the axis is labeled and not a pie chart
         IF GE.ChartType <> cPie THEN
                 IF GE.YAxis.Labeled = cYes THEN

                         ' Get the correct font:
                         clSetChartFont GE.YAxis.TicFont

                         ' If it is a category axis then add longest category
                         IF GP.YMode = cCategory THEN
                                 DLeft% = DLeft% + clMaxStrLen%(Cat$(), 1, GP.

                         ' If it a value axis just add characters for label (p
                         ' spacing):
                         ELSE
                                 DLeft% = DLeft% + GP.ValLenY + (.5 * GFI.MaxW
                         END IF

                 ELSEIF GP.XMode = cValue AND GE.XAxis.Labeled = cYes THEN

                         ' Then space over 1/2 of the leftmost label on the X
                         ' a value axis; if it's a category axis assume the la
                         ' correct:
                         DLeft% = DLeft% + GP.ValLenX \ 2
                 END IF
         END IF

         ' *** RIGHT
         ' For the right, space over 8 pixels from the right:
         DRight% = 12

         ' Then space over 1/2 of the rightmost label on the X Axis if it's
         ' a value axis; if it's a category axis assume the label will be
         ' correct:
         IF GP.XMode = cValue AND GE.XAxis.Labeled = cYes THEN
                 DRight% = DRight% + (GP.ValLenX) \ 2
         END IF

         DRight% = GP.ChartWid - DRight%

         ' *** YTIC MARKS
         ' Finally, adjust the window coordinates for tic marks (if it's not a
         ' pie chart):
         IF GE.ChartType <> cPie THEN
                 IF GE.YAxis.Labeled = cYes THEN
                         DLeft% = DRight% - (DRight% - DLeft%) / (1 + cTicSize
                 END IF
         END IF

         ' *** LEGEND
         ' Account for the legend if its on the right:
         IF GE.Legend.Legend = cYes AND GP.MSeries = cYes THEN
                 IF GE.Legend.Place = cRight THEN
                         A% = GE.Legend.LegendWindow.X1
                         DRight% = DRight% - ABS(GP.ChartWid - A%)
                 END IF
         END IF

         ' Now we have DLeft%, DRight% we can check if the labels fit on the
         ' X axis or if we need to put them on two rows:
         GP.XStagger = cFalse
         IF GP.XMode = cCategory AND GE.ChartType <> cPie THEN
                 clSetChartFont GE.XAxis.TicFont
                 TicInterval% = (DRight% - DLeft%) \ GP.NVals
                 IF clMaxStrLen%(Cat$(), 1, GP.NVals) + .5 * GFI.MaxWidth > Ti
                         GP.XStagger = cTrue
                 END IF
         END IF

         ' If we do have to stagger, check if there is enough space to the
         ' left and right for long categories.  Make adjustments as necessary:
         IF GP.XStagger THEN
                 LenLeft% = GetGTextLen%(Cat$(1)) + GFI.AvgWidth
                 LenRight% = GetGTextLen%(Cat$(GP.NVals)) + GFI.AvgWidth
                 SizeRight% = cTrue
                 SizeLeft% = cTrue
                 OldRight% = DRight%
                 OldLeft% = DLeft%
                 DO WHILE SizeRight% OR SizeLeft%
                         IF LenRight% - TicInterval% > 2 * (GP.ChartWid - DRig
                                 SizeRight% = cTrue
                         ELSE
                                 SizeRight% = cFalse
                         END IF
                         IF SizeRight% THEN
                                 TicInterval% = (2 * (GP.ChartWid - DLeft%) -
                                 IF LenRight% > 2 * TicInterval% THEN
                                         TicInterval% = (GP.ChartWid - DLeft%)
                                 END IF
                                 DRight% = DLeft% + GP.NVals * TicInterval%
                         END IF
                         IF LenLeft% - TicInterval% > 2 * DLeft% AND 2 * DLeft
                                 SizeLeft% = cTrue
                         ELSE
                                 SizeLeft% = cFalse
                         END IF
                         IF SizeLeft% THEN
                                 TicInterval% = (2 * DRight% - LenLeft%) \ (2
                                 IF LenLeft% > 2 * TicInterval% THEN
                                         TicInterval% = DRight% / (GP.NVals +
                                 END IF
                                 DLeft% = DRight% - GP.NVals * TicInterval%
                         END IF

                         ' Make sure we haven't gone too far on either side:
                         IF DRight% > OldRight% THEN
                                 DRight% = OldRight%
                         END IF
                         IF DLeft% < OldLeft% THEN
                                 DLeft% = OldLeft%
                         END IF

                         ' Check if there has been a change, if not, we are do
                         IF ABS(ChangeRight% - DRight%) + ABS(ChangeLeft% - DL
                                 EXIT DO
                         ELSE
                                 ChangeRight% = DRight%
                                 ChangeLeft% = DLeft%
                         END IF
                 LOOP
         END IF

         ' *** BOTTOM
         DBot% = XTitleLayout.TotalSize

         ' If axis is labeled (and not a pie chart), add row for tic
         ' labels + 1/2 row spacing:
         IF GE.XAxis.Labeled = cYes AND GE.ChartType <> cPie THEN
                 IF GP.XStagger = cTrue THEN
                         DBot% = DBot% + 3 * GFI.PixHeight
                 ELSE
                         DBot% = DBot% + 1.5 * GFI.PixHeight
                 END IF
         END IF

         ' Make the setting relative to the chart window:
         DBot% = GP.ChartHgt - 1 - DBot%


         ' *** XTIC MARKS
         ' Finally, adjust the window coordinates for tic marks (if it's not a
         ' pie chart):
         IF GE.ChartType <> cPie THEN
                 IF GE.XAxis.Labeled = cYes THEN
                         DBot% = DTop% + (DBot% - DTop%) / (1 + cTicSize)
                 END IF

         END IF

         ' *** LEGEND
         ' Account for the legend if its on the bottom:
         IF GE.Legend.Legend = cYes AND GP.MSeries = cYes THEN
                 IF GE.Legend.Place = cBottom THEN
                         A% = GE.Legend.LegendWindow.Y1
                         DBot% = DBot% - ABS(GP.ChartHgt - A%)
                 END IF
         END IF

         ' Install values in the DataWindow definition:
         GE.DataWindow.X1 = DLeft%
         GE.DataWindow.X2 = DRight%
         GE.DataWindow.Y1 = DTop%
         GE.DataWindow.Y2 = DBot%

         ' If the window is invalid then set error:
         IF DLeft% >= DRight% OR DTop% >= DBot% THEN
                 clSetError cBadDataWindow
         END IF

 END SUB

 '=== clSpaceTics - Calculates TicInterval
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     The TicInterval will be altered
 '
 '  Remarks:
 '     The TicInterval is the distance between tic marks in WORLD
 '     coordinates (i.e. the coordinates your data are in)
 '
 '=================================================================
 SUB clSpaceTics
 SHARED GE AS ChartEnvironment, GP AS GlobalParams
 SHARED GFI AS FontInfo

         ' X-Axis:
         ' Calculate the length of the axis and of the longest tic label.  The
         ' use that information to calculate the number of tics that will fit:
         clSetChartFont GE.XAxis.TicFont
         AxisLen% = GE.DataWindow.X2 - GE.DataWindow.X1 + 1
         TicWid% = GP.ValLenX + GFI.MaxWidth
         clSpaceTicsA GE.XAxis, GP.XMode, AxisLen%, TicWid%

         ' Y-Axis:
         ' Same procedure as above:
         clSetChartFont GE.YAxis.TicFont
         AxisLen% = GE.DataWindow.Y2 - GE.DataWindow.Y1 + 1
         TicWid% = 2 * GFI.Ascent
         clSpaceTicsA GE.YAxis, GP.YMode, AxisLen%, TicWid%

 END SUB

 '=== clSpaceTicsA - Figures out TicInterval for an axis
 '
 '  Arguments:
 '     Axis     -  An AxisType variable to space tics for
 '
 '     AxisMode%-  cCategory or cValue
 '
 '     AxisLen% -  Length of the axis in pixels
 '
 '  Return Values:
 '     The TicInterval value may be changed for an axis
 '
 '  Remarks:
 '     The TicInterval is the distance between tic marks in adjusted world
 '     coordinates (i.e. the coordinates your data are in scaled by
 '     ScaleFactor and adjusted by LogBase if it is a log axis).
 '
 '=================================================================
 SUB clSpaceTicsA (Axis AS AxisType, AxisMode%, AxisLen%, TicWid%)
 SHARED GP AS GlobalParams

         ' If this is a category axis the tic interval is 1
         ' divided by the number-of-categories:
         IF AxisMode% = cCategory THEN
                 Axis.TicInterval = 1 / GP.NVals
                 EXIT SUB
         END IF

         ' Otherwise, if we're supposed to scale this axis then the tic interv
         ' depends on how many will fit and some aesthetic considerations:
         IF Axis.AutoScale = cYes THEN

                 ' Figure which is bigger in absolute value between scale maxi
                 ' and minimum:
                 MaxRange = ABS(Axis.ScaleMax)
                 IF ABS(Axis.ScaleMin) > MaxRange THEN MaxRange = ABS(Axis.Sca

                 ' Calculate the maximum number of tic marks that will fit:
                 MaxTics% = INT(AxisLen% / TicWid%)

                 ' If the maximum number of tics is one or less set the tic
                 ' interval to the axis range and the number of tics to one:
                 IF MaxTics% <= 1 THEN
                         NumTics% = 1
                         TicInterval = Axis.ScaleMax - Axis.ScaleMin

                 ELSE
                         ' Guess that the tic interval is equal to 1/10th of t
                         ' of magnitude of the largest of the scale max or min
                         TicInterval = .1 * 10 ^ INT(LOG(MaxRange) / LOG(10!))

                         ' If this doesn't result in too many tic marks then O
                         ' multiply the tic interval by 2 and 5 alternatively
                         ' number of tic marks falls into the acceptable range
                         NextStep% = 2
                         ScaleRange = Axis.ScaleMax - Axis.ScaleMin
                         DO
                                 NumTics% = -INT(-ScaleRange / TicInterval)
                                 IF (NumTics% <= MaxTics%) THEN EXIT DO
                                 TicInterval = TicInterval * NextStep%
                                 NextStep% = 7 - NextStep%
                         LOOP UNTIL NumTics% <= MaxTics%
                 END IF

                 ' Set Axis.TicInterval and adjust scale maximum and minimum:
                 Axis.TicInterval = TicInterval
                 IF ABS(TicInterval) < 1 THEN
                         Axis.TicDecimals = -INT(-ABS(LOG(1.1 * TicInterval) /
                 END IF

                 Axis.ScaleMax = -INT(-Axis.ScaleMax / TicInterval) * TicInter
                 Axis.ScaleMin = INT(Axis.ScaleMin / TicInterval) * TicInterva
         END IF

 END SUB

 '=== clTitleXAxis - Draws titles on X axis (AxisTitle and ScaleTitle)
 '
 '  Arguments:
 '     Axis  -  AxisType variable describing axis
 '
 '     X1%   -  Left of DataWindow
 '
 '     X2%   -  Right of DataWindow
 '
 '     YBoundry%   -  Top boundry of title block
 '
 '=================================================================
 SUB clTitleXAxis (Axis AS AxisType, X1%, X2%, YBoundry%)
 SHARED GFI AS FontInfo
 SHARED XTitleLayout AS TitleLayout

         CH% = GFI.PixHeight
         CW% = GFI.MaxWidth

         ' Set position of first title:
         Y% = YBoundry% + XTitleLayout.Top

         ' Loop through the two titles (AxisTitle and ScaleTitle), printing
         ' them if they aren't blank:
         FOR i% = 1 TO 2

                 ' Get the test, color, and justification for the title to be
                 SELECT CASE i%

                         CASE 1:  ' AxisTitle
                                 Txt$ = Axis.AxisTitle.Title
                                 C% = Axis.AxisTitle.TitleColor
                                 J% = Axis.AxisTitle.Justify
                                 F% = Axis.AxisTitle.TitleFont
                                 Lead% = XTitleLayout.Middle

                         CASE 2:  ' ScaleTitle
                                 Txt$ = Axis.ScaleTitle.Title
                                 C% = Axis.ScaleTitle.TitleColor
                                 J% = Axis.ScaleTitle.Justify
                                 F% = Axis.ScaleTitle.TitleFont
                                 Lead% = XTitleLayout.Bottom

                 END SELECT
                 clSetChartFont F%
                 Txt$ = RTRIM$(Txt$)
                 TxtLen% = GetGTextLen(Txt$)

                 ' If the title isn't all blank:
                 IF TxtLen% <> 0 THEN

                         ' Set the title's color:
                         clSetCharColor C%

                         ' Calculate x position of title's first character dep
                         ' the justification flag:
                         SELECT CASE J%
                                 CASE cLeft:   X% = X1%
                                 CASE cCenter: X% = ((X1% + X2%) - TxtLen%) /
                                 CASE ELSE:    X% = X2% - TxtLen%
                         END SELECT

                         ' Write out the text:
                         clHPrint X%, Y%, Txt$

                         ' Move down to the next title position:
                         Y% = Y% + GFI.PixHeight + XTitleLayout.Middle

                 END IF

         NEXT i%

 END SUB

 '=== clTitleYAxis - Draws titles on Y axis (AxisTitle and ScaleTitle)
 '
 '  Arguments:
 '     Axis  -  AxisType variable describing axis
 '
 '     Y1%   -  Top of DataWindow
 '
 '     Y2%   -  Bottom of DataWindow
 '
 '  Return Values:
 '
 '=================================================================
 SUB clTitleYAxis (Axis AS AxisType, Y1%, Y2%) STATIC
 SHARED GFI AS FontInfo
 SHARED YTitleLayout AS TitleLayout


         ' Set position for first title:
         X% = YTitleLayout.Top

         ' Loop through the two titles (AxisTitle and ScaleTitle), printing
         ' them if they aren't blank:
         FOR i% = 1 TO 2

                 ' Get the test, color, and justification for the title to be
                 SELECT CASE i%

                         CASE 1:  ' AxisTitle
                                 Txt$ = Axis.AxisTitle.Title
                                 C% = Axis.AxisTitle.TitleColor
                                 J% = Axis.AxisTitle.Justify
                                 F% = Axis.AxisTitle.TitleFont
                                 Lead% = YTitleLayout.TitleOne + YTitleLayout.

                         CASE 2:  ' ScaleTitle
                                 Txt$ = Axis.ScaleTitle.Title
                                 C% = Axis.ScaleTitle.TitleColor
                                 J% = Axis.ScaleTitle.Justify
                                 F% = Axis.ScaleTitle.TitleFont
                                 Lead% = 0

                 END SELECT
                 clSetChartFont F%
                 Txt$ = RTRIM$(Txt$)
                 TxtLen% = GetGTextLen(Txt$)

                 IF TxtLen% <> 0 THEN

                         ' Set title's color:
                         clSetCharColor C%

                         ' Calculate y position of title's first character dep
                         ' the justification flag:
                         SELECT CASE J%
                                 CASE cLeft:   Y% = Y2%
                                 CASE cCenter: Y% = ((Y1% + Y2%) + TxtLen%) /
                                 CASE ELSE:    Y% = Y1% + (TxtLen% - 1)
                         END SELECT

                         ' Write out the text:
                         clVPrint X%, Y%, Txt$

                         ' Move to next title position:
                         X% = X% + Lead%

                 END IF

         NEXT i%

 END SUB

 '=== clUnFlagSystem - Sets GP.SysFlag to cNo
 '
 '  Arguments:
 '     None
 '
 '  Return Values:
 '     Alters the value of GP.SysFlag
 '
 '=================================================================
 SUB clUnFlagSystem
 SHARED GP AS GlobalParams

         GP.SysFlag = cNo

 END SUB

 '=== clVal2Str$ - Converts a single precision value to a string
 '
 '  Arguments:
 '     X        -  The value to convert
 '
 '     Places%  -  The number of places after the decimal to produce
 '
 '     Format%  -  1 For normal, other than 1 for exponential
 '
 '  Return Values:
 '     Returns a string representation of the input number
 '
 '=================================================================
 FUNCTION clVal2Str$ (X, Places%, Format%)

         ' Make a local copy of the value:
         XX = ABS(X)

         ' Force format to exponential if that is specified or number is
         ' bigger than a long integer will hold (2^31-1):
         IF Format% <> cNormFormat OR XX >= 2 ^ 31 THEN

                 ' For exponential format calculate the exponent that will mak
                 ' one decimal to left of decimal place.  This is done by trun
                 ' the log (base 10) of XX:
                 IF XX = 0 THEN ExpX = 0 ELSE ExpX = INT(LOG(XX) / LOG(10))
                 XX = XX / (10 ^ ExpX)

                 ' If no decimals are specified then a number of 9.5x will be
                 ' rounded up to 10 leaving two places to left of decimal so c
                 ' for that and if that occurs divide number by 10 and add 1 t
                 IF Places% <= 0 AND CLNG(XX) > 9 THEN
                         XX = XX / 10
                         ExpX = ExpX + 1
                 END IF

         END IF

         ' If no decimal places are specified then generate a rounded integer:
         IF Places% <= 0 THEN
                 ValStr$ = LTRIM$(STR$(CLNG(XX)))

         ' If decimal places are called for, round number to requisite number
         ' decimals and generate string:
         ELSE

                 ' Limit places after decimal to six:
                 DP% = Places%
                 IF DP% > 6 THEN DP% = 6
                 RF% = 10 ^ DP%

                 ' Figure out integer portion:
                 IntX = FIX(XX)

                 ' Round the fractional part to correct number of decimals.  I
                 ' the fraction carries to the 1's place in the rounding
                 ' adjust IntX by adding 1:
                 FracX = CLNG((1 + XX - IntX) * RF%)
                 IF FracX >= 2 * RF% THEN
                         IntX = IntX + 1
                 END IF

                 'Finally, generate the output string:
                 ValStr$ = LTRIM$(STR$(IntX)) + "." + MID$(STR$(FracX), 3)

         END IF

         ' Add exponent ending if format is exponent:
         IF Format% <> cNormFormat OR ABS(X) > 2 ^ 31 THEN
                 ValStr$ = ValStr$ + "E"
                 IF ExpX >= 0 THEN ValStr$ = ValStr$ + "+"
                 ValStr$ = ValStr$ + LTRIM$(STR$(ExpX))
         END IF

         ' Add minus sign if appropriate:
         IF X < 0 AND VAL(ValStr$) <> 0 THEN ValStr$ = "-" + ValStr$
         clVal2Str$ = ValStr$

 END FUNCTION

 '=== clVPrint - Prints text vertically on the screen
 '
 '  Arguments:
 '     X     -  X position of lower left of first char (in absolute screen
 '              coordinates)
 '
 '     Y     -  Y position of lower left of first char (in absolute screen
 '              coordinates)
 '
 '     Txt$  -  Text to print
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB clVPrint (X%, Y%, Txt$)

         ' Map the input coordinates relative to the current viewport:
         X = PMAP(X%, 2)
         Y = PMAP(Y%, 3)

         ' Print text out vertically:
         SetGTextDir 1
         TextLen% = OutGText(X, Y, Txt$)
         SetGTextDir 0

 END SUB

 '=== DefaultChart - Sets up the ChartEnvironment variable to generate a
 '                   default chart of the type and style specified
 '
 '  Arguments:
 '     Env        - A ChartEnvironment variable
 '
 '     ChartType  - The chart type desired: 1=Bar, 2=Column, 3=Line,
 '                  4=Scatter, 5=Pie
 '
 '     ChartStyle - The chart style (depends on type, see README file)
 '
 '
 '  Return Values:
 '     Elements of Env variable are set to default values
 '
 '  Remarks:
 '     This subprogram should be called to initialize the ChartEnvironment
 '     variable before a charting routine is called.
 '
 '=================================================================
 SUB DefaultChart (Env AS ChartEnvironment, ChartType AS INTEGER, ChartStyle A

 SHARED DTitle AS TitleType, DWindow AS RegionType
 SHARED DAxis AS AxisType, DLegend AS LegendType

         ' Clear any previous chart errors:
         clClearError

         ' Check initialization:
         clChkInit

   ' Put type in environment:
         IF ChartType < 1 OR ChartType > 5 THEN
                 clSetError cBadType
                 EXIT SUB
         END IF
         Env.ChartType = ChartType

         ' Put chart style in environment:
         IF ChartStyle < 1 OR ChartStyle > 2 THEN
                 clSetError cBadStyle
                 ChartStyle = 1
         END IF
         Env.ChartStyle = ChartStyle

         ' Set elements of chart to default:
         Env.DataFont = 1

         Env.MainTitle = DTitle
         Env.SubTitle = DTitle

         Env.ChartWindow = DWindow           ' Chart window is default window
         Env.ChartWindow.Border = cYes       ' with a border.

         Env.DataWindow = DWindow

         Env.XAxis = DAxis
         Env.YAxis = DAxis

         Env.Legend = DLegend

 END SUB

 '=== GetPaletteDef - Changes an entry in the internal palette
 '
 '  Arguments:
 '     C%()     -  Color palette array
 '
 '     S%()     -  Style palette array
 '
 '     P$()     -  Pattern palette array
 '
 '     Char%()  -  Plot character palette array
 '
 '     B%()     -  Border style palette array
 '
 '  Return Values:
 '     Chart error may be set
 '
 '=================================================================
 SUB GetPaletteDef (C() AS INTEGER, s() AS INTEGER, P$(), Char() AS INTEGER, B
 SHARED GP AS GlobalParams
 SHARED PaletteC%(), PaletteS%(), PaletteP$(), PaletteCh%(), PaletteB%()

         ' Reset any outstanding errors:
         clClearError

         ' Make sure palettes have been initialized:
         IF NOT GP.PaletteSet THEN
                 clSetError cPalettesNotSet
                 EXIT SUB
         END IF

         ' Make sure the user's palettes are the correct size:
         clChkPalettes C(), s(), P$(), Char(), B()
         IF (ChartErr <> 0) THEN EXIT SUB

         ' Replace the palette values with input variables (making sure that
         ' the color and character numbers are in range):
         FOR N% = 0 TO cPalLen
                 C(N%) = PaletteC%(N%)
                 s(N%) = PaletteS%(N%)
                 P$(N%) = PaletteP$(N%)
                 Char(N%) = PaletteCh%(N%)
                 B(N%) = PaletteB%(N%)
         NEXT N%

 END SUB

 '=== GetPattern - Returns a pattern from among 3 pattern palettes
 '
 '  Arguments:
 '     Bits%       -  The number of bits per pixel for the pattern
 '
 '     PatternNum% -  The pattern number to return
 '
 '  Return Values:
 '     Returns a pattern tile from the list below.
 '
 '  Remarks:
 '     Below are three pattern sets.  There is a set of patterns for one, two
 '     and eight bit-per-pixel screens.
 '
 '=================================================================
 FUNCTION GetPattern$ (Bits%, PatternNum%)

         SELECT CASE Bits%

                 ' One bit-per-pixel patterns:
                 CASE 1:
                         SELECT CASE PatternNum%
                                 CASE 1: P$ = CHR$(&HFF)
                                 CASE 2: P$ = CHR$(&H55) + CHR$(&HAA)
                                 CASE 3: P$ = CHR$(&H33) + CHR$(&HCC)
                                 CASE 4: P$ = CHR$(&H0) + CHR$(&HE7)
                                 CASE 5: P$ = CHR$(&H7F) + CHR$(&HBF) + CHR$(&
                                 CASE 6: P$ = CHR$(&H7E) + CHR$(&HBD) + CHR$(&
                                 CASE 7: P$ = CHR$(&HFE) + CHR$(&HFD) + CHR$(&
                                 CASE 8: P$ = CHR$(&H33) + CHR$(&HCC) + CHR$(&
                                 CASE 9: P$ = CHR$(&H0) + CHR$(&HFD) + CHR$(&H
                                 CASE 10: P$ = CHR$(&HF) + CHR$(&H87) + CHR$(&
                                 CASE 11: P$ = CHR$(&HA8) + CHR$(&H51) + CHR$(
                                 CASE 12: P$ = CHR$(&HAA) + CHR$(&H55) + CHR$(
                                 CASE 13: P$ = CHR$(&H2A) + CHR$(&H15) + CHR$(
                                 CASE 14: P$ = CHR$(&H88) + CHR$(&H0) + CHR$(&
                                 CASE 15: P$ = CHR$(&HFF) + CHR$(&H0) + CHR$(&
                         END SELECT

                 ' Two bit-per-pixel patterns:
                 CASE 2:
                         SELECT CASE PatternNum%
                                 CASE 1: P$ = CHR$(&HFF)
                                 CASE 2: P$ = CHR$(&HCC) + CHR$(&H33)
                                 CASE 3: P$ = CHR$(&HF0) + CHR$(&H3C) + CHR$(&
                                 CASE 4: P$ = CHR$(&HF0) + CHR$(&HF)
                                 CASE 5: P$ = CHR$(&H3) + CHR$(&HC) + CHR$(&H3
                                 CASE 6: P$ = CHR$(&HFF) + CHR$(&HC)
                                 CASE 7: P$ = CHR$(&HF0) + CHR$(&HF0) + CHR$(&
                                 CASE 8: P$ = CHR$(&HFF) + CHR$(&HC) + CHR$(&H
                                 CASE 9: P$ = CHR$(&HC0) + CHR$(&H30) + CHR$(&
                                 CASE 10: P$ = CHR$(&HC0) + CHR$(&HC)
                                 CASE 11: P$ = CHR$(&HCC) + CHR$(&HCC) + CHR$(
                                 CASE 12: P$ = CHR$(&HCC) + CHR$(&HCC) + CHR$(
                                 CASE 13: P$ = CHR$(&HFF) + CHR$(&H33) + CHR$(
                                 CASE 14: P$ = CHR$(&HFF) + CHR$(&H0)
                                 CASE 15: P$ = CHR$(&HCC) + CHR$(&H30) + CHR$(
                         END SELECT

                 ' Eight bit-per-pixel patterns:
                 CASE 8:
                         P$ = CHR$(&HFF)

         END SELECT

         ' Return the pattern as the value of the function:
         GetPattern$ = P$

 END FUNCTION

 '=== LabelChartH - Prints horizontal text on a chart
 '
 '  Arguments:
 '     Env        - A ChartEnvironment variable
 '
 '     X          - Horizontal position of text relative to the left of
 '                  the Chart window (in pixels)
 '
 '     Y          - Vertical position of text relative to the top of
 '                  the Chart window (in pixels)
 '
 '     Font%      - Font number to use for the text
 '
 '     TxtColor   - Color number (in internal color palette) for text
 '
 '     TxtString$ - String variable containing text to print
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB LabelChartH (Env AS ChartEnvironment, X AS INTEGER, Y AS INTEGER, Font AS

         ' Reset any outstanding errors:
         clClearError

         ' Check initialization and fonts:
         clChkInit
         clChkFonts
         IF ChartErr >= 100 THEN EXIT SUB

         ' Select ChartWindow as reference viewport:
         clSelectChartWindow

         ' Select font and set color:
         SelectFont Font
         clSetCharColor TxtColor

         ' Call internal print routine to print text:
         clHPrint X, Y, TxtString$

 END SUB

 '=== LabelChartV - Prints vertical text on a chart
 '
 '  Arguments:
 '     Env        - A ChartEnvironment variable
 '
 '     X          - Horizontal position of text relative to the left of
 '                  the Chart window (in pixels)
 '
 '     Y          - Vertical position of text relative to the top of
 '                  the Chart window (in pixels)
 '
 '     Font%      - Font number to use for the text
 '
 '     TxtColor   - Color number (in internal color palette) for text
 '
 '     TxtString$ - String variable containing text to print
 '
 '  Return Values:
 '     None
 '
 '=================================================================
 SUB LabelChartV (Env AS ChartEnvironment, X AS INTEGER, Y AS INTEGER, Font AS

         ' Reset any outstanding errors:
         clClearError

         ' Check initialization and fonts:
         clChkInit
         clChkFonts
         IF ChartErr >= 100 THEN EXIT SUB

         ' Select ChartWindow as reference viewport:
         clSelectChartWindow

         ' Select font and set color:
         SelectFont Font%
         clSetCharColor TxtColor

         ' Call internal print routine to print text:
         clVPrint X, Y, TxtString$

 END SUB

 '=== MakeChartPattern$ - Makes a pattern given reference pattern and
 '                        foreground and background colors
 '
 '  Arguments:
 '     RefPattern$ -  Reference pattern
 '
 '     FG%         -  Foreground color
 '
 '     BG%         -  Background color
 '
 '  Return Values:
 '     Returns a pattern in standard PAINT format
 '     Sets error cBadScreen if ChartScreen hasn't been called
 '
 '=================================================================
 FUNCTION MakeChartPattern$ (RefPattern$, FG AS INTEGER, BG AS INTEGER)
 SHARED GP AS GlobalParams

         ' Reset any outstanding errors:
         clClearError

         ' Check initialization:
         clChkInit
         IF ChartErr >= 100 THEN EXIT FUNCTION
         IF NOT GP.PaletteSet THEN
                 clSetError cBadScreen
                 EXIT FUNCTION
         END IF

         FGColor% = clMap2Attrib%(FG%)
         BGColor% = clMap2Attrib%(BG%)

         ' Screens 1, 2, 11 and 13 are 1 bit plane modes and require one metho
         ' of generating pattern tiles.  The other modes supported are multipl
         ' bit plane modes and require another method of generating pattern
         ' tiles.  Select the appropriate method for this screen mode:
         SELECT CASE GP.PaletteScrn

                 ' One bit plane modes:
                 CASE 1, 2, 11, 13: SinglePlane% = cTrue
                 CASE ELSE: SinglePlane% = cFalse

         END SELECT

         ' Do foreground part of pattern:
         IF SinglePlane% THEN
                         FGPattern$ = clBuildBitP$(GP.PaletteBits, FGColor%, R
         ELSE
                         FGPattern$ = clBuildPlaneP$(GP.PaletteBits, FGColor%,
         END IF

         ' Do background part of pattern (if background color is black then
         ' the pattern is just the foreground pattern):
         IF BGColor% = 0 THEN
                 Pattern$ = FGPattern$

         ELSE
                 ' Background reference pattern is inverted foreground pattern
                 BGPattern$ = ""
                 FOR i% = 1 TO LEN(RefPattern$)
                         BGPattern$ = BGPattern$ + CHR$(ASC(MID$(RefPattern$,
                 NEXT i%

                 ' Build the corresponding PAINT style pattern:
                 IF SinglePlane% THEN
                                 BGPattern$ = clBuildBitP$(GP.PaletteBits, BGC
                 ELSE
                                 BGPattern$ = clBuildPlaneP$(GP.PaletteBits, B
                 END IF

                 ' Put foreground and background patterns back together:
                 Pattern$ = ""
                 FOR i% = 1 TO LEN(FGPattern$)
                         Pattern$ = Pattern$ + CHR$(ASC(MID$(FGPattern$, i%, 1
                 NEXT i%

         END IF

         MakeChartPattern$ = Pattern$

 END FUNCTION

 '=== ResetPaletteDef - Resets charting palettes for last screen
 '                      mode set with ChartScreen.
 '
 '=================================================================
 SUB ResetPaletteDef
 SHARED GP AS GlobalParams

         ' Clear outstanding errors:
         clClearError

         ' Check initialization:
         clChkInit

         ' Make sure that ChartScreen has been called at least once:
         IF NOT GP.PaletteSet THEN
                 clSetError cBadScreen
                 EXIT SUB
         END IF

         ' Now rebuild the palette with the last set screen mode:
         clBuildPalette GP.PaletteScrn, GP.PaletteBits

 END SUB

 '=== SetPaletteDef - Changes an entry in the internal palette
 '
 '  Arguments:
 '     C%()     -  Color palette array
 '
 '     S%()     -  Style palette array
 '
 '     P$()     -  Pattern palette array
 '
 '     Char%()  -  Plot character palette array
 '
 '     B%()     -  Border style palette array
 '
 '  Return Values:
 '     Internal chart palettes may be modified or ChartErr set
 '
 '=================================================================
 SUB SetPaletteDef (C() AS INTEGER, s() AS INTEGER, P$(), Char() AS INTEGER, B
 SHARED PaletteC%(), PaletteS%(), PaletteP$(), PaletteCh%(), PaletteB%()

         ' Reset any outstanding errors and check that palettes are dimesioned
         ' correctly:
         clClearError
         clChkPalettes C(), s(), P$(), Char(), B()
         IF (ChartErr <> 0) THEN EXIT SUB

         ' Check initialization:
         clChkInit

         ' Replace the palette values with input variables (making sure that
         ' the color and character numbers are in range):
         FOR N% = 0 TO cPalLen
                 PaletteC%(N%) = clMap2Attrib%(C%(N%))
                 PaletteS%(N%) = s(N%)
                 PaletteP$(N%) = P$(N%)
                 PaletteCh%(N%) = ABS(Char(N%)) MOD (cMaxChars + 1)
                 PaletteB%(N%) = B(N%)
         NEXT N%

 END SUB



 CHRTDEM1.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\CHRTDEM1.BAS

 '       CHRTDEM1.BAS - second module of the CHRTB demonstration program.
 '
 '               Copyright (C) 1989, Microsoft Corporation
 '
 '   Main module - CHRTDEMO.BAS
 '   Include files - CHRTDEMO.BI
 '
 '$INCLUDE: 'chrtdemo.bi'

 'local subs
 DECLARE SUB ChangeStyle ()

 DEFINT A-Z
 '
 ' Sub Name: ChangeAxis
 '
 ' Description: Allows user to view and change attributes of either
 '              chart axis.
 '
 ' Arguments: title$ - window title
 '            axis - X or Y axis variable
 '
 SUB ChangeAxis (title$, axis AS AxisType)

     DIM colorBox AS ListBox
     DIM styleBox AS ListBox
     DIM fontBox AS ListBox

     ' set up color list box
     colorBox.scrollButton = 2
     colorBox.areaButton = 3
     colorBox.listLen = numColors
     colorBox.topRow = 3
     colorBox.botRow = 16
     colorBox.leftCol = 4
     colorBox.rightCol = 18
     colorBox.listPos = axis.AxisColor + 1

     ' set up border style list box
     styleBox.scrollButton = 5
     styleBox.areaButton = 6
     styleBox.listLen = MAXSTYLES
     styleBox.topRow = 5
     styleBox.botRow = 16
     styleBox.leftCol = 24
     styleBox.rightCol = 40
     styleBox.listPos = axis.GridStyle

     ' set up font list box
     fontBox.scrollButton = 8
     fontBox.areaButton = 9
     fontBox.listLen = numFonts
     fontBox.topRow = 5
     fontBox.botRow = 9
     fontBox.leftCol = 46
     fontBox.rightCol = 65
     fontBox.listPos = axis.TicFont

     ' open window for display
     winRow = 4
     winCol = 6
     WindowOpen 1, winRow, winCol, 22, 73, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE
     WindowBox 1, 2, 17, 20
     WindowLocate 2, 4
     WindowPrint 2, "Axis Color:"
     WindowBox 1, 22, 17, 42
     WindowLocate 4, 24
     WindowPrint 2, "Grid Style:"
     WindowBox 1, 44, 17, 67
     WindowLocate 4, 46
     WindowPrint 2, "Label Font:"
     WindowLocate 10, 46
     WindowPrint 2, "Range Type:"
     WindowBox 11, 46, 16, 65
     WindowLocate 14, 48
     WindowPrint 2, "Log Base:"
     WindowBox 13, 57, 15, 63
     WindowLine 18

     ' create list boxes
     CreateListBox colors$(), colorBox, 0
     CreateListBox styles$(), styleBox, 0
     CreateListBox fonts$(), fontBox, 0

     ' open control buttons
     ButtonOpen 4, 1, "Display Grid", 2, 24, 0, 0, 2
     ButtonOpen 7, 1, "Display Labels", 2, 46, 0, 0, 2
     ButtonOpen 10, 1, "Lin", 12, 48, 0, 0, 3
     ButtonOpen 11, 1, "Log", 12, 57, 0, 0, 3
     ButtonOpen 12, 2, "OK ", 19, 10, 0, 0, 1
     ButtonOpen 13, 1, "Cancel ", 19, 26, 0, 0, 1
     ButtonOpen 14, 1, "Axis Title ", 19, 46, 0, 0, 1

     ' edit field for log base
     EditFieldOpen 1, LTRIM$(STR$(axis.LogBase)), 14, 58, 0, 7, 5, 20


     currButton = 3                                      ' start with cursor o
     currEditField = 0

     optionButton = axis.RangeType + 9                   ' set proper state fo
     ButtonToggle optionButton
     IF axis.Labeled THEN ButtonToggle 7
     IF axis.Grid THEN ButtonToggle 4

     pushButton = 12                                     ' active command butt

     ' window control loop
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, currEditField              ' wait for event
         SELECT CASE Dialog(0)
             CASE 1                                      ' button pressed
                 currButton = Dialog(1)
                 SELECT CASE currButton
                     CASE 4, 7
                         ButtonToggle currButton
                         currEditField = 0
                     CASE 10, 11
                         ButtonToggle optionButton
                         optionButton = currButton
                         ButtonToggle optionButton
                         currEditField = 0
                     CASE 2, 3
                         currEditField = 0
                         ScrollList colors$(), colorBox, currButton, 1, 0, win
                         currButton = 3
                     CASE 5, 6
                         currEditField = 0
                         ScrollList styles$(), styleBox, currButton, 1, 0, win
                         currButton = 6
                     CASE 8, 9
                         currEditField = 0
                         ScrollList fonts$(), fontBox, currButton, 1, 0, winRo
                         currButton = 9
                     CASE 12, 13
                         pushButton = currButton
                         finished = TRUE
                     CASE 14
                         currEditField = 0
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                         ChangeTitle 2, title$ + " Title", axis.AxisTitle, 6,
                 END SELECT
             CASE 2                                      ' edit field
                 currEditField = 1
                 currButton = 0
             CASE 6                                      ' enter
                 SELECT CASE pushButton
                     CASE 12, 13: finished = TRUE
                     CASE 14: ChangeTitle 2, title$ + " Title", axis.AxisTitle
                 END SELECT
                 currButton = pushButton
             CASE 7                                      ' tab
                 SELECT CASE currButton
                     CASE 0:
                         currEditField = 0
                         currButton = 12
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE 2, 3: currButton = 4
                     CASE 4: currButton = 6
                     CASE 5, 6: currButton = 7
                     CASE 7: currButton = 9
                     CASE 8, 9: currButton = optionButton
                     CASE 10, 11:
                         currButton = 0
                         currEditField = 1
                     CASE 12, 13:
                         currButton = currButton + 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE 14:
                         ButtonSetState currButton, 1
                         pushButton = 12
                         ButtonSetState pushButton, 2
                         currButton = 3
                 END SELECT
             CASE 8                                      ' back tab
                 SELECT CASE currButton
                     CASE 0:
                         currEditField = 0
                         currButton = optionButton
                     CASE 2, 3:
                         currButton = 14
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE 4: currButton = 3
                     CASE 5, 6: currButton = 4
                     CASE 7: currButton = 6
                     CASE 8, 9: currButton = 7
                     CASE 10, 11: currButton = 9
                     CASE 12:
                         currButton = 0
                         currEditField = 1
                     CASE 13, 14:
                         currButton = currButton - 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                 END SELECT
             CASE 9                                      ' escape
                 pushButton = 13
                 finished = TRUE
             CASE 10, 12                                 ' up, left arrow
                 SELECT CASE currButton
                     CASE 4, 7: ButtonSetState currButton, 2
                     CASE 2, 3: ScrollList colors$(), colorBox, currButton, 2,
                     CASE 5, 6: ScrollList styles$(), styleBox, currButton, 2,
                     CASE 8, 9: ScrollList fonts$(), fontBox, currButton, 2, 0
                     CASE 10, 11:
                         ButtonToggle currButton
                         currButton = 21 - currButton
                         optionButton = currButton
                         ButtonToggle optionButton
                 END SELECT
             CASE 11, 13                                 ' down, right arrow
                 SELECT CASE currButton
                     CASE 1, 4, 7: ButtonSetState currButton, 1
                     CASE 2, 3: ScrollList colors$(), colorBox, currButton, 3,
                     CASE 5, 6: ScrollList styles$(), styleBox, currButton, 3,
                     CASE 8, 9: ScrollList fonts$(), fontBox, currButton, 3, 0
                     CASE 10, 11:
                         ButtonToggle currButton
                         currButton = 21 - currButton
                         optionButton = currButton
                         ButtonToggle optionButton
                 END SELECT
             CASE 14                                     ' space bar
                 SELECT CASE currButton
                     CASE 1, 4, 7: ButtonToggle currButton
                     CASE 12, 13: finished = TRUE
                     CASE 14: ChangeTitle 2, title$ + " Title", axis.AxisTitle
                 END SELECT
         END SELECT

         ' error checking on log base before exiting
         IF finished AND pushButton = 12 THEN
             IF VAL(EditFieldInquire(1)) <= 0 THEN
                 PrintError " Log base must be greater than zero."
                 currEditField = 1
                 currButton = 0
                 finished = FALSE
             ELSEIF VAL(EditFieldInquire(1)) = 1 THEN
                 PrintError " Log base cannot equal one. Overflow results."
                 currEditField = 1
                 currButton = 0
                 finished = FALSE
             END IF
         END IF
     WEND

     ' if not canceled then assign and return new values
     IF pushButton = 12 THEN
         IF setNum > 0 THEN chartChanged = TRUE

         axis.LogBase = VAL(EditFieldInquire(1))
         axis.Grid = (ButtonInquire(4) = 2)
         axis.Labeled = (ButtonInquire(7) = 2)
         axis.RangeType = optionButton - 9
         axis.AxisColor = colorBox.listPos - 1
         axis.ScaleTitle.TitleColor = axis.AxisTitle.TitleColor
         axis.ScaleTitle.Justify = axis.AxisTitle.Justify
         axis.GridStyle = styleBox.listPos
         axis.TicFont = fontBox.listPos
     END IF

     WindowClose 1

 END SUB

 '
 ' Sub Name: ChangeChartType
 '
 ' Description: Changes chart type based on menu selection and
 '              allows the user access to changing the chart style.
 '
 ' Arguments: ctype - new chart type
 '
 SUB ChangeChartType (ctype)

     'change type if user selected a different type
     IF CEnv.ChartType <> ctype THEN
         IF setNum > 0 THEN chartChanged = TRUE

         ' reset chosen type
         MenuItemToggle GALLERYTITLE, CEnv.ChartType
         ' reset other affected menu items
         IF CEnv.ChartType = cPie THEN
             MenuSetState CHARTTITLE, 4, 1
             MenuSetState CHARTTITLE, 5, 1
             MenuSetState TITLETITLE, 3, 1
             MenuSetState TITLETITLE, 4, 1
         END IF

         CEnv.ChartType = ctype

         'if new type is pie then turn off some items
         IF CEnv.ChartType = cPie THEN
             MenuSetState CHARTTITLE, 4, 0
             MenuSetState CHARTTITLE, 5, 0
             MenuSetState TITLETITLE, 3, 0
             MenuSetState TITLETITLE, 4, 0
         END IF

         ' set type in menu bar
         MenuItemToggle GALLERYTITLE, CEnv.ChartType
     END IF

     ' allow user to change chart style
     ChangeStyle

 END SUB

 '
 ' Sub Name: ChangeLegend
 '
 ' Description: Allows user to view and modify all attributes of the chart
 '              legend
 '
 ' Arguments: none
 '
 SUB ChangeLegend

     DIM fgColorBox AS ListBox
     DIM fontBox AS ListBox

     ' set up foreground color box
     fgColorBox.scrollButton = 6
     fgColorBox.areaButton = 7
     fgColorBox.listLen = numColors
     fgColorBox.topRow = 3
     fgColorBox.botRow = 10
     fgColorBox.leftCol = 27
     fgColorBox.rightCol = 41
     fgColorBox.listPos = CEnv.Legend.TextColor + 1

     ' set up font box
     fontBox.scrollButton = 8
     fontBox.areaButton = 9
     fontBox.listLen = numFonts
     fontBox.topRow = 3
     fontBox.botRow = 10
     fontBox.leftCol = 43
     fontBox.rightCol = 57
     fontBox.listPos = CEnv.Legend.TextFont

     ' set up display window
     winRow = 6
     winCol = 10
     WindowOpen 1, winRow, winCol, 18, 69, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE
     WindowBox 1, 2, 11, 23
     WindowLocate 5, 4
     WindowPrint 2, "Location:"
     WindowBox 6, 4, 10, 21
     WindowBox 1, 25, 11, 59
     WindowLocate 2, 27
     WindowPrint 2, "Text Color:"
     WindowLocate 2, 43
     WindowPrint 2, "Text Font:"
     WindowLine 12

     ' create list boxes
     CreateListBox colors$(), fgColorBox, 0
     CreateListBox fonts$(), fontBox, 0

     ' open command buttons
     ButtonOpen 1, 1, "Display Legend", 2, 4, 0, 0, 2
     ButtonOpen 2, 1, "Autosize", 3, 4, 0, 0, 2
     ButtonOpen 3, 1, "Overlay", 7, 6, 0, 0, 3
     ButtonOpen 4, 1, "Bottom", 8, 6, 0, 0, 3
     ButtonOpen 5, 1, "Right", 9, 6, 0, 0, 3
     ButtonOpen 10, 2, "OK ", 13, 8, 0, 0, 1
     ButtonOpen 11, 1, "Cancel ", 13, 21, 0, 0, 1
     ButtonOpen 12, 1, "Legend Window ", 13, 38, 0, 0, 1

     currButton = 1                                      ' start with cursor o

     ' set button states based on current values
     optionButton = CEnv.Legend.Place + 2
     ButtonToggle optionButton
     IF CEnv.Legend.Legend THEN ButtonToggle 1
     IF CEnv.Legend.AutoSize THEN ButtonToggle 2
     pushButton = 10

     ' window control loop
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, 0                          ' wait for event
         SELECT CASE Dialog(0)
             CASE 1                                      ' button pressed
                 currButton = Dialog(1)
                 SELECT CASE currButton
                     CASE 1, 2: ButtonToggle currButton
                     CASE 3, 4, 5
                         ButtonToggle optionButton
                         optionButton = currButton
                         ButtonToggle optionButton
                     CASE 6, 7:
                         ScrollList colors$(), fgColorBox, currButton, 1, 0, w
                         currButton = 7
                     CASE 8, 9:
                         ScrollList fonts$(), fontBox, currButton, 1, 0, winRo
                         currButton = 9
                     CASE 10, 11
                         pushButton = currButton
                         finished = TRUE
                     CASE 12
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = 12
                         ChangeWindow 2, "Legend Window", CEnv.Legend.LegendWi
                 END SELECT
             CASE 6                                      ' enter
                 IF pushButton <> 12 THEN
                     finished = TRUE
                 ELSE
                     ChangeWindow 2, "Legend Window", CEnv.Legend.LegendWindow
                 END IF
             CASE 7                                      ' tab
                 SELECT CASE currButton
                     CASE 1: currButton = 2
                     CASE 2: currButton = optionButton
                     CASE 3, 4, 5: currButton = 7
                     CASE 6, 7: currButton = 9
                     CASE 8, 9:
                         currButton = 10
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE 10, 11:
                         currButton = currButton + 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE 12:
                         ButtonSetState currButton, 1
                         pushButton = 10
                         ButtonSetState pushButton, 2
                         currButton = 1
                 END SELECT
             CASE 8                                      ' back tab
                 SELECT CASE currButton
                     CASE 1:
                         currButton = 12
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE 2: currButton = 1
                     CASE 3, 4, 5: currButton = 2
                     CASE 6, 7: currButton = optionButton
                     CASE 8, 9: currButton = 7
                     CASE 10: currButton = 9
                     CASE 11, 12:
                         currButton = currButton - 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                 END SELECT
             CASE 9                                      ' escape
                 pushButton = 11
                 finished = TRUE
             CASE 10, 12                                 ' up, left arrow
                 SELECT CASE currButton
                     CASE 1, 2: ButtonSetState currButton, 2
                     CASE 3:
                         ButtonToggle currButton
                         currButton = 5
                         optionButton = currButton
                         ButtonToggle optionButton
                     CASE 4, 5:
                         ButtonToggle currButton
                         currButton = currButton - 1
                         optionButton = currButton
                         ButtonToggle optionButton
                     CASE 6, 7: ScrollList colors$(), fgColorBox, currButton,
                     CASE 8, 9: ScrollList fonts$(), fontBox, currButton, 2, 0
                 END SELECT
             CASE 11, 13                                 ' down, right arrow
                 SELECT CASE currButton
                     CASE 1, 2: ButtonSetState currButton, 1
                     CASE 3, 4:
                         ButtonToggle currButton
                         currButton = currButton + 1
                         optionButton = currButton
                         ButtonToggle optionButton
                     CASE 5:
                         ButtonToggle currButton
                         currButton = 3
                         optionButton = currButton
                         ButtonToggle optionButton
                     CASE 6, 7: ScrollList colors$(), fgColorBox, currButton,
                     CASE 8, 9: ScrollList fonts$(), fontBox, currButton, 3, 0
                 END SELECT
             CASE 14                                     ' space bar
                 SELECT CASE currButton
                     CASE 1, 2: ButtonToggle currButton
                     CASE 10, 11: finished = TRUE
                     CASE 12: ChangeWindow 2, "Legend Window", CEnv.Legend.Leg
                END SELECT
         END SELECT
     WEND

     ' if not canceled then return the new values
     IF pushButton = 10 THEN
         IF setNum > 0 THEN chartChanged = TRUE

         CEnv.Legend.TextColor = fgColorBox.listPos - 1
         CEnv.Legend.TextFont = fontBox.listPos
         CEnv.Legend.AutoSize = (ButtonInquire(2) = 2)
         CEnv.Legend.Legend = (ButtonInquire(1) = 2)
         CEnv.Legend.Place = optionButton - 2
     END IF

     WindowClose 1

 END SUB

 '
 ' Sub Name: ChangeStyle
 '
 ' Description: Allows user to view and modify the chart style
 '
 ' Arguments: none
 '
 SUB ChangeStyle
 DIM fontBox AS ListBox

     ' determine button labels based on chart type
     SELECT CASE CEnv.ChartType
         CASE cBar, cColumn
             style1$ = "Adjacent"
             style2$ = "Stacked"
         CASE cLine, cScatter
             style1$ = "Lines"
             style2$ = "No Lines"
         CASE cPie
             style1$ = "Percentages"
             style2$ = "No Percentages"
     END SELECT

     topRow = 8
     leftCol = 26
     ' if pie, line or scatter chart then add data font
     IF CEnv.ChartType > 2 THEN
         WindowOpen 1, topRow, leftCol, 19, 47, 0, 7, 0, 7, 15, FALSE, FALSE,
         okLine = 12

         WindowLocate 5, 3
         WindowPrint -2, "Data Font:"
         ' set up list box containing valid fonts
         fontBox.scrollButton = 3
         fontBox.areaButton = 4
         fontBox.listLen = numFonts
         fontBox.topRow = 6
         fontBox.botRow = 10
         fontBox.leftCol = 3
         fontBox.rightCol = 20
         fontBox.listPos = CEnv.DataFont
         CreateListBox fonts$(), fontBox, 0
     ELSE
         WindowOpen 1, topRow, leftCol, 13, 47, 0, 7, 0, 7, 15, FALSE, FALSE,
         okLine = 6
     END IF

     ' open buttons
     ButtonOpen 1, 1, style1$, 2, 3, 1, 0, 3
     ButtonOpen 2, 1, style2$, 3, 3, 1, 0, 3
     WindowLine okLine - 1
     ButtonOpen 5, 2, "OK", okLine, 3, 1, 0, 1
     ButtonOpen 6, 1, "Cancel", okLine, 11, 1, 0, 1

     pushButton = 5
     optionButton = CEnv.ChartStyle                     ' set current style
     currButton = optionButton
     ButtonSetState optionButton, 2

     ' window control loop
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, 0                          ' wait for event
         SELECT CASE Dialog(0)
             CASE 1                                      'button pressed
                 currButton = Dialog(1)
                 SELECT CASE currButton
                     CASE 1, 2:
                         ButtonSetState optionButton, 1
                         optionButton = currButton
                         ButtonSetState optionButton, 2
                     CASE 3, 4:
                         ScrollList fonts$(), fontBox, currButton, 1, 0, topRo
                         currButton = 4
                     CASE 5, 6:
                         finished = TRUE
                 END SELECT
             CASE 6                                      'enter
                 finished = TRUE
             CASE 7                                      'tab
                 SELECT CASE currButton
                     CASE 1, 2:
                         IF CEnv.ChartType > 2 THEN
                             currButton = 4
                         ELSE
                             currButton = 5
                             ButtonSetState pushButton, 1
                             pushButton = currButton
                             ButtonSetState pushButton, 2
                         END IF
                     CASE 3, 4:
                         currButton = 5
                         ButtonSetState pushButton, 1
                         pushButton = currButton
                         ButtonSetState currButton, 2
                     CASE 5:
                         currButton = 6
                         ButtonSetState pushButton, 1
                         pushButton = currButton
                         ButtonSetState currButton, 2
                     CASE 6:
                         currButton = optionButton
                         ButtonSetState pushButton, 1
                         pushButton = 5
                         ButtonSetState pushButton, 2
                 END SELECT
             CASE 8                                      'back tab
                 SELECT CASE currButton
                     CASE 1, 2:
                         currButton = 6
                         ButtonSetState pushButton, 1
                         pushButton = currButton
                         ButtonSetState pushButton, 2
                     CASE 3, 4:
                         currButton = optionButton
                     CASE 5:
                         IF CEnv.ChartType > 2 THEN
                             currButton = 4
                         ELSE
                             currButton = optionButton
                         END IF
                     CASE 6:
                         currButton = 5
                         ButtonSetState pushButton, 1
                         pushButton = currButton
                         ButtonSetState currButton, 2
                 END SELECT
             CASE 9                                      'escape
                 finished = TRUE
                 pushButton = 5
             CASE 10, 12                                 'up, left arrow
                 SELECT CASE currButton
                     CASE 1, 2:
                         ButtonSetState currButton, 1
                         currButton = 3 - currButton
                         optionButton = currButton
                         ButtonSetState currButton, 2
                     CASE 3, 4:
                         ScrollList fonts$(), fontBox, currButton, 2, 0, topRo
                 END SELECT
             CASE 11, 13                                 'down, right arrow
                 SELECT CASE currButton
                     CASE 1, 2:
                         ButtonSetState currButton, 1
                         currButton = 3 - currButton
                         optionButton = currButton
                         ButtonSetState currButton, 2
                     CASE 3, 4:
                         ScrollList fonts$(), fontBox, currButton, 3, 0, topRo
                 END SELECT
             CASE 14                                     'space bar
                 IF currButton > 4 THEN finished = TRUE
         END SELECT
     WEND

     ' if not canceled then set new chart style
     IF pushButton = 5 THEN
         IF setNum > 0 THEN chartChanged = TRUE
         CEnv.ChartStyle = optionButton
         IF CEnv.ChartType > 2 THEN CEnv.DataFont = fontBox.listPos
     END IF

     WindowClose 1

 END SUB

 '
 ' Sub Name: ChangeTitle
 '
 ' Description: Allows user to view and modify the chart titles
 '
 ' Arguments: handle - window number
 '            wTitle$ - window title
 '            title -  chart title
 '            topRow - top row of window
 '            leftCol - left column of window
 '
 SUB ChangeTitle (handle, wTitle$, title AS TitleType, topRow, leftCol)
 SHARED mode$(), numModes AS INTEGER

     DIM colorBox AS ListBox
     DIM fontBox AS ListBox

     ' set up foreground color box
     colorBox.scrollButton = 1
     colorBox.areaButton = 2
     colorBox.listLen = numColors
     colorBox.topRow = 6
     colorBox.botRow = 10
     colorBox.leftCol = 2
     colorBox.rightCol = 16
     colorBox.listPos = title.TitleColor + 1

     ' set up font box
     fontBox.scrollButton = 3
     fontBox.areaButton = 4
     fontBox.listLen = numFonts
     fontBox.topRow = 6
     fontBox.botRow = 10
     fontBox.leftCol = 18
     fontBox.rightCol = 36
     fontBox.listPos = title.TitleFont

     ' set up display window
     WindowOpen handle, topRow, leftCol, topRow + 11, leftCol + 50, 0, 7, 0, 7
     WindowLocate 2, 2
     WindowPrint 2, "Title:"
     WindowBox 1, 8, 3, 50
     WindowBox 6, 38, 10, 50
     WindowLine 4
     WindowLine 11
     WindowLocate 5, 1
     WindowPrint -1, " Color:          Font:               Justify:"

     ' set color attribute for title editfield background to that of the chart
     IF mode$(1) = "10" OR (mode$(1) = "2" AND mode$(2) <> "1") OR mode$(1) =
         func = 0
         EditFieldOpen 1, RTRIM$(title.title), 2, 9, 0, 7, 41, 70
     ELSE
         SetAtt 5, CEnv.ChartWindow.Background + 1
         EditFieldOpen 1, RTRIM$(title.title), 2, 9, 12, 5, 41, 70
         func = 2
     END IF

     ' create list boxes
     CreateListBox colors$(), colorBox, func
     CreateListBox fonts$(), fontBox, 0

     ' open buttons
     ButtonOpen 5, 1, "Left", 7, 39, 0, 0, 3
     ButtonOpen 6, 1, "Center", 8, 39, 0, 0, 3
     ButtonOpen 7, 1, "Right", 9, 39, 0, 0, 3
     ButtonOpen 8, 2, "OK ", 12, 10, 0, 0, 1
     ButtonOpen 9, 1, "Cancel ", 12, 33, 0, 0, 1

     currButton = 0                                      ' start in edit field
     currEditField = 1
     optionButton = 4 + title.Justify                    ' set button state
     ButtonToggle optionButton
     pushButton = 8

     ' window control loop
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, currEditField              ' wait for event
         SELECT CASE Dialog(0)
             CASE 1                                      ' button pressed
                 currButton = Dialog(1)
                 SELECT CASE currButton
                     CASE 1, 2
                         currEditField = 0
                         ScrollList colors$(), colorBox, currButton, 1, func,
                         currButton = 2
                     CASE 3, 4
                         currEditField = 0
                         ScrollList fonts$(), fontBox, currButton, 1, 0, topRo
                         currButton = 4
                     CASE 5, 6, 7
                         ButtonToggle optionButton
                         optionButton = currButton
                         ButtonToggle optionButton
                         currEditField = 0
                     CASE 8, 9
                         pushButton = currButton
                         finished = TRUE
                 END SELECT
             CASE 2                                      ' edit field
                 currButton = 0
                 currEditField = 1
             CASE 6                                      ' enter
                 finished = TRUE
             CASE 7                                      ' tab
                 SELECT CASE currButton
                     CASE 0:
                         currButton = 2
                         currEditField = 0
                     CASE 1, 2: currButton = 4
                     CASE 3, 4: currButton = optionButton
                     CASE 5, 6, 7:
                         currButton = 8
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = 8
                     CASE 8:
                         currButton = currButton + 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE 9:
                         ButtonSetState currButton, 1
                         pushButton = 8
                         ButtonSetState pushButton, 2
                         currButton = 0
                         currEditField = 1
                 END SELECT
             CASE 8                                      ' back tab
                 SELECT CASE currButton
                     CASE 0:
                         currButton = 9
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = 9
                         currEditField = 0
                     CASE 1, 2:
                         currButton = 0
                         currEditField = 1
                     CASE 3, 4: currButton = 2
                     CASE 5, 6, 7: currButton = 4
                     CASE 8: currButton = optionButton
                     CASE 9:
                         currButton = currButton - 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                 END SELECT
             CASE 9                                      ' escape
                 pushButton = 9
                 finished = TRUE
             CASE 10, 12                                 ' up, left arrow
                 SELECT CASE currButton
                     CASE 1, 2: ScrollList colors$(), colorBox, currButton, 2,
                     CASE 3, 4: ScrollList fonts$(), fontBox, currButton, 2, 0
                     CASE 5:
                         ButtonToggle currButton
                         currButton = 7
                         optionButton = 7
                         ButtonToggle optionButton
                     CASE 6, 7:
                         ButtonToggle currButton
                         currButton = currButton - 1
                         optionButton = currButton
                         ButtonToggle optionButton
                 END SELECT
             CASE 11, 13                                 ' down, right arrow
                 SELECT CASE currButton
                     CASE 1, 2: ScrollList colors$(), colorBox, currButton, 3,
                     CASE 3, 4: ScrollList fonts$(), fontBox, currButton, 3, 0
                     CASE 5, 6:
                         ButtonToggle currButton
                         currButton = currButton + 1
                         optionButton = currButton
                         ButtonToggle optionButton
                     CASE 7:
                         ButtonToggle currButton
                         currButton = 5
                         optionButton = 5
                         ButtonToggle optionButton
                 END SELECT
             CASE 14                                     ' space bar
                 IF currButton > 7 THEN
                     pushButton = currButton
                     finished = TRUE
                 END IF
         END SELECT
     WEND

     ' done and not canceled so return new title information
     IF pushButton = 8 THEN
         IF setNum > 0 THEN chartChanged = TRUE

         title.title = EditFieldInquire(1)
         title.TitleFont = fontBox.listPos
         title.TitleColor = colorBox.listPos - 1
         title.Justify = optionButton - 4
     END IF

     WindowClose handle

 END SUB

 '
 ' Sub Name: ChangeWindow
 '
 ' Description: Allows user to view and modify any of the chart windows
 '
 ' Arguments: handle - window number
 '            wTitle$ - window title
 '            win - chart window
 '
 SUB ChangeWindow (handle, title$, win AS RegionType)

     DIM bgColorBox AS ListBox
     DIM bdColorBox AS ListBox
     DIM bdStyleBox AS ListBox

     ' set up background color box
     bgColorBox.scrollButton = 1
     bgColorBox.areaButton = 2
     bgColorBox.listLen = numColors
     bgColorBox.topRow = 4
     bgColorBox.botRow = 14
     bgColorBox.leftCol = 4
     bgColorBox.rightCol = 18
     bgColorBox.listPos = win.Background + 1

     ' set up border color box
     bdColorBox.scrollButton = 3
     bdColorBox.areaButton = 4
     bdColorBox.listLen = numColors
     bdColorBox.topRow = 5
     bdColorBox.botRow = 14
     bdColorBox.leftCol = 24
     bdColorBox.rightCol = 38
     bdColorBox.listPos = win.BorderColor + 1

     ' set up border style box
     bdStyleBox.scrollButton = 5
     bdStyleBox.areaButton = 6
     bdStyleBox.listLen = MAXSTYLES
     bdStyleBox.topRow = 5
     bdStyleBox.botRow = 14
     bdStyleBox.leftCol = 40
     bdStyleBox.rightCol = 54
     bdStyleBox.listPos = win.BorderStyle

     ' set up display window
     winRow = 5
     winCol = 3
     WindowOpen handle, winRow, winCol, 21, 76, 0, 7, 0, 7, 15, FALSE, FALSE,
     WindowBox 1, 2, 15, 20
     WindowLocate 2, 5
     WindowPrint 2, "Background"
     WindowLocate 3, 5
     WindowPrint 2, "Color:"
     WindowBox 1, 22, 15, 56
     WindowLocate 4, 24
     WindowPrint 2, "Border Color:"
     WindowLocate 4, 40
     WindowPrint 2, "Border Style:"
     WindowBox 1, 58, 15, 73
     WindowLocate 2, 60
     WindowPrint 2, "Coordinates:"
     WindowBox 3, 63, 5, 71
     WindowLocate 4, 60
     WindowPrint 2, "X1:"
     WindowBox 6, 63, 8, 71
     WindowLocate 7, 60
     WindowPrint 2, "Y1:"
     WindowBox 9, 63, 11, 71
     WindowLocate 10, 60
     WindowPrint 2, "X2:"
     WindowBox 12, 63, 14, 71
     WindowLocate 13, 60
     WindowPrint 2, "Y2:"
     WindowLine 16

     CreateListBox colors$(), bgColorBox, 0
     CreateListBox colors$(), bdColorBox, 0
     CreateListBox styles$(), bdStyleBox, 0

     ButtonOpen 7, 1, "Display Border", 2, 24, 0, 0, 2
     ButtonOpen 8, 2, "OK ", 17, 14, 0, 0, 1
     ButtonOpen 9, 1, "Cancel ", 17, 51, 0, 0, 1

     EditFieldOpen 1, LTRIM$(STR$(win.X1)), 4, 64, 0, 7, 7, 10
     EditFieldOpen 2, LTRIM$(STR$(win.Y1)), 7, 64, 0, 7, 7, 10
     EditFieldOpen 3, LTRIM$(STR$(win.X2)), 10, 64, 0, 7, 7, 10
     EditFieldOpen 4, LTRIM$(STR$(win.Y2)), 13, 64, 0, 7, 7, 10

     currButton = 2                                      ' start in first list
     currEditField = 0
     IF win.border = TRUE THEN ButtonSetState 7, 2
     pushButton = 8

     ' window control loop
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, currEditField              ' wait for event
         SELECT CASE Dialog(0)
             CASE 1                                      ' button pressed
                 currButton = Dialog(1)
                 SELECT CASE currButton
                     CASE 1, 2
                         currEditField = 0
                         ScrollList colors$(), bgColorBox, currButton, 1, 0, w
                         currButton = 2
                     CASE 3, 4
                         currEditField = 0
                         ScrollList colors$(), bdColorBox, currButton, 1, 0, w
                         currButton = 4
                     CASE 5, 6
                         currEditField = 0
                         ScrollList styles$(), bdStyleBox, currButton, 1, 0, w
                         currButton = 6
                     CASE 7
                         ButtonToggle currButton
                         currEditField = 0
                     CASE 8, 9
                         pushButton = currButton
                         finished = TRUE
                 END SELECT
             CASE 2                                      ' edit field
                 currEditField = Dialog(2)
                 currButton = 0
             CASE 6                                      ' enter
                 finished = TRUE
             CASE 7                                      ' tab
                 SELECT CASE currButton
                     CASE 0:
                         SELECT CASE currEditField
                             CASE 1, 2, 3: currEditField = currEditField + 1
                             CASE 4:
                                 currEditField = 0
                                 currButton = 8
                                 ButtonSetState pushButton, 1
                                 ButtonSetState currButton, 2
                                 pushButton = currButton
                         END SELECT
                     CASE 1, 2: currButton = 7
                     CASE 3, 4: currButton = 6
                     CASE 5, 6:
                         currButton = 0
                         currEditField = 1
                     CASE 7: currButton = 4
                     CASE 8:
                         currButton = currButton + 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE 9:
                         ButtonSetState currButton, 1
                         pushButton = 8
                         ButtonSetState pushButton, 2
                         currButton = 2
                         currEditField = 0
                 END SELECT
             CASE 8                                      ' back tab
                 SELECT CASE currButton
                     CASE 0:
                         SELECT CASE currEditField
                             CASE 1:
                                 currEditField = 0
                                 currButton = 6
                             CASE 2, 3, 4: currEditField = currEditField - 1
                         END SELECT
                     CASE 1, 2:
                         currButton = 9
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE 3, 4: currButton = 7
                     CASE 5, 6: currButton = 4
                     CASE 7: currButton = 2
                     CASE 8:
                         currButton = 0
                         currEditField = 4
                     CASE 9:
                         currButton = currButton - 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                 END SELECT
             CASE 9                                      ' escape
                 pushButton = 9
                 finished = TRUE
             CASE 10, 12                                 ' up, left arrow
                 SELECT CASE currButton
                     CASE 1, 2: ScrollList colors$(), bgColorBox, currButton,
                     CASE 3, 4: ScrollList colors$(), bdColorBox, currButton,
                     CASE 5, 6: ScrollList styles$(), bdStyleBox, currButton,
                     CASE 7: ButtonSetState currButton, 2
                 END SELECT
             CASE 11, 13                                 ' down, right arrow
                 SELECT CASE currButton
                     CASE 1, 2: ScrollList colors$(), bgColorBox, currButton,
                     CASE 3, 4: ScrollList colors$(), bdColorBox, currButton,
                     CASE 5, 6: ScrollList styles$(), bdStyleBox, currButton,
                     CASE 7: ButtonSetState currButton, 1
                 END SELECT
             CASE 14                                     ' space bar
                 SELECT CASE currButton
                     CASE 7: ButtonToggle currButton
                     CASE 8, 9: finished = TRUE
                 END SELECT
         END SELECT
     WEND

     ' return new window information
     IF pushButton = 8 THEN
         IF setNum > 0 THEN chartChanged = TRUE

         win.X1 = VAL(EditFieldInquire(1))
         win.Y1 = VAL(EditFieldInquire(2))
         win.X2 = VAL(EditFieldInquire(3))
         win.Y2 = VAL(EditFieldInquire(4))
         win.Background = bgColorBox.listPos - 1
         win.border = (ButtonInquire(7) = 2)
         win.BorderColor = bdColorBox.listPos - 1
         win.BorderStyle = bdStyleBox.listPos
     END IF

     WindowClose handle

 END SUB



 CHRTDEM2.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\CHRTDEM2.BAS

 '       CHRTDEM2.BAS - third module of the CHRTB demonstration program.
 '
 '               Copyright (C) 1989, Microsoft Corporation
 '
 '   Main module - CHRTDEMO.BAS
 '   Include files - CHRTDEMO.BI
 '
 '$INCLUDE: 'chrtdemo.bi'

 ' local functions
 DECLARE FUNCTION TrueColr% (colr%)

 ' local subs
 DECLARE SUB OpenChart (newFlag%)
 DECLARE SUB Quit ()
 DECLARE SUB InitFonts ()
 DECLARE SUB InitStyles ()
 DECLARE SUB SetDisplayColor ()
 DECLARE SUB SetUpBackground ()
 DECLARE SUB SetUpMenu ()
 DECLARE SUB ViewChart ()
 DECLARE SUB ViewFont ()
 DECLARE SUB ViewScreenMode ()

 DIM colorDisplay            AS INTEGER
 DIM egacolor(0 TO 15)       AS INTEGER
 DIM origPath$

 DEFINT A-Z
 '
 ' Sub Name: ClearData
 '
 ' Description: Clears all chart data
 ' Arguments: None
 '
 SUB ClearData
 SHARED Cat$(), catLen AS INTEGER
 SHARED setVal!(), setLen() AS INTEGER, setName$()

     ' Can't view  chart when no data present
     MenuSetState VIEWTITLE, 2, 0

     ' Clear categories
     FOR i = 1 TO cMaxValues
         Cat$(i) = ""
     NEXT i
     catLen = 0

     ' Clear set names and values
     FOR i = 1 TO cMaxSets
         setName$(i) = ""
         setLen(i) = 0
         FOR j = 1 TO cMaxValues
             setVal!(j, i) = cMissingValue
         NEXT j
     NEXT i
     setNum = 0

     ' chart not changed
     chartChanged = FALSE

 END SUB

 '
 ' Sub Name: ClearFonts
 '
 ' Description: Sets all chart font pointers to 1.  This is called
 '              each time new fonts are loaded to ensure that
 '              all chart fonts specify a meaningful font
 '
 ' Arguments: None
 '
 SUB ClearFonts

     ' reset all font pointers if don't map to current fonts
     IF CEnv.DataFont > numFonts THEN CEnv.DataFont = 1
     IF CEnv.MainTitle.TitleFont > numFonts THEN CEnv.MainTitle.TitleFont = 1
     IF CEnv.SubTitle.TitleFont > numFonts THEN CEnv.SubTitle.TitleFont = 1
     IF CEnv.XAxis.AxisTitle.TitleFont > numFonts THEN CEnv.XAxis.AxisTitle.Ti
     IF CEnv.XAxis.TicFont > numFonts THEN CEnv.XAxis.TicFont = 1
     IF CEnv.YAxis.AxisTitle.TitleFont > numFonts THEN CEnv.YAxis.AxisTitle.Ti
     IF CEnv.YAxis.TicFont > numFonts THEN CEnv.YAxis.TicFont = 1
     IF CEnv.Legend.TextFont > numFonts THEN CEnv.Legend.TextFont = 1

 END SUB

 '
 ' Sub Name: CreateListBox
 '
 ' Description: Creates a list box within the current window
 ' Arguments: text$() - the list
 '            tbox    - the listBox
 '            func    - function flag for DrawList
 '
 SUB CreateListBox (text$(), tbox AS ListBox, func)

     ' get box length
     tbox.boxLen = tbox.botRow - tbox.topRow - 1

     ' get displayable length
     IF tbox.listLen < tbox.boxLen THEN
         tbox.maxLen = tbox.listLen
     ELSE
         tbox.maxLen = tbox.boxLen
     END IF

     ' get box width
     tbox.boxWid = tbox.rightCol - tbox.leftCol - 1

     ' create box
     WindowBox tbox.topRow, tbox.leftCol, tbox.botRow, tbox.rightCol

     ' add scroll bar if necessary or if forced (func = 5)
     IF tbox.listLen <> tbox.maxLen OR func = 5 THEN
         ButtonOpen tbox.scrollButton, 1, "", tbox.topRow + 1, tbox.rightCol,
     ELSE
         tbox.scrollButton = 0
     END IF

     ' open area button
     ButtonOpen tbox.areaButton, 1, "", tbox.topRow + 1, tbox.leftCol + 1, tbo

     ' set current list element relative to list box top
     IF tbox.listPos <= tbox.maxLen THEN
         tbox.currTop = 1
         tbox.currPos = tbox.listPos
     ELSEIF tbox.listPos + tbox.maxLen > tbox.listLen + 1 THEN
         tbox.currTop = tbox.listLen - tbox.maxLen + 1
         tbox.currPos = tbox.listPos - tbox.currTop + 1
     ELSE
         tbox.currTop = tbox.listPos
         tbox.currPos = 1
     END IF

     ' Display list within the box
     DrawList text$(), tbox, func

 END SUB

 '
 ' Sub Name: DrawList
 '
 ' Description: Displays a list within the boundaries of a list box
 ' Arguments: text$() - the list
 '            tbox    - the listBox
 '            func    - function flag for special operations
 '
 SUB DrawList (text$(), tbox AS ListBox, func)

     ' Draw each element of list that should currently appear in box
     FOR i% = 1 TO tbox.boxLen
         ' highlight current list element
         IF i% = tbox.currPos THEN
             WindowColor 7, 0
         ELSE
             WindowColor 0, 7
         END IF

         WindowLocate tbox.topRow + i%, tbox.leftCol + 1
         IF i <= tbox.maxLen THEN
             WindowPrint -1, LEFT$(text$(tbox.currTop + i% - 1) + STRING$(tbox
         ELSE
             WindowPrint -1, STRING$(tbox.boxWid, " ")
         END IF
     NEXT i%

     ' update scrollbar position indicator if scrollbar present
     IF tbox.scrollButton <> 0 THEN
         IF tbox.listLen <> 0 THEN
             position = (tbox.currTop + tbox.currPos - 1) * (tbox.maxLen - 2)
             IF position < 1 THEN
                position = 1
             ELSEIF position > tbox.maxLen - 2 THEN
               position = tbox.maxLen - 2
             END IF
         ELSE
             position = 1
         END IF
         ButtonSetState tbox.scrollButton, position
     END IF

     ' Reset color in case current element was last to be drawn
     WindowColor 0, 7

     ' update current position in case list has been scrolled
     tbox.listPos = tbox.currTop + tbox.currPos - 1

     ' handle special operation of immediately updating colors$ in title editf
     SELECT CASE func
         CASE 2: SetAtt 12, tbox.listPos          ' update title editfield for
     END SELECT

 END SUB

 '
 ' Func Name: HandleMenuEvent
 '
 ' Description: Determines the action to be performed when user makes
 '              a menu selection.
 '
 ' Arguments: none
 '
 SUB HandleMenuEvent
 SHARED saveFile$, colorDisplay AS INTEGER

     menu = MenuCheck(0)
     item = MenuCheck(1)

     SELECT CASE menu
         ' file menu title selection
         CASE FILETITLE
             SELECT CASE item
                 ' new chart
                 CASE 1: OpenChart TRUE
                 ' open existing chart
                 CASE 2: OpenChart FALSE
                 ' save current chart
                 CASE 3: junk = SaveChart(saveFile$, FALSE)
                 ' save current chart under new name
                 CASE 4: junk = SaveChart(saveFile$, TRUE)
                 ' exit program
                 CASE 6: Quit
             END SELECT

         ' view menu title selection
         CASE VIEWTITLE
             SELECT CASE item
                 ' Display and edit existing chart data
                 CASE 1: ViewData
                 ' Display chart
                 CASE 2: ViewChart
                 ' Display and load fonts
                 CASE 3: ViewFont
                 ' Display and edit screen mode
                 CASE 4: ViewScreenMode
             END SELECT

         ' Gallery menu title selection
         CASE GALLERYTITLE
             ' change chart type
             ChangeChartType item

         ' Chart menu title selection
         CASE CHARTTITLE
             SELECT CASE item
                 ' Change chart window
                 CASE 1: ChangeWindow 1, "Chart Window", CEnv.ChartWindow
                 ' Change data window
                 CASE 2: ChangeWindow 1, "Data Window", CEnv.DataWindow
                 ' Change legend
                 CASE 3: ChangeLegend
                 ' Change X axis
                 CASE 4: ChangeAxis "X Axis", CEnv.XAxis
                 ' Change Y axis
                 CASE 5: ChangeAxis "Y Axis", CEnv.YAxis
             END SELECT

         ' Title menu title selection
         CASE TITLETITLE
             SELECT CASE item
                 ' Display and modify main title
                 CASE 1: ChangeTitle 1, "Main Title", CEnv.MainTitle, 6, 16
                 ' Display and modify sub title
                 CASE 2: ChangeTitle 1, "Sub Title", CEnv.SubTitle, 6, 16
                 ' Display and modify x axis title
                 CASE 3:
                     ChangeTitle 1, "X-axis Title", CEnv.XAxis.AxisTitle, 6, 1
                     CEnv.XAxis.ScaleTitle.TitleColor = CEnv.XAxis.AxisTitle.T
                     CEnv.XAxis.ScaleTitle.Justify = CEnv.XAxis.AxisTitle.Just
                 ' Display and modify y axis title
                 CASE 4:
                     ChangeTitle 1, "Y-axis Title", CEnv.YAxis.AxisTitle, 6, 1
                     CEnv.YAxis.ScaleTitle.TitleColor = CEnv.YAxis.AxisTitle.T
                     CEnv.YAxis.ScaleTitle.Justify = CEnv.YAxis.AxisTitle.Just
             END SELECT

         ' Options menu title selection
         CASE OPTIONSTITLE
             colorDisplay = item - 2
             SetDisplayColor
     END SELECT

 END SUB

 '
 ' Func Name: InitAll
 '
 ' Description: Performs all initialization for the program
 '
 ' Arguments: none
 '
 SUB InitAll
 SHARED finished AS INTEGER, screenMode AS INTEGER, saveFile$
 SHARED origPath$, colorDisplay  AS INTEGER

     saveFile$ = ""                          ' No save file to begin with
     origPath$ = CURDIR$                     ' get working path
     colorDisplay = FALSE                    ' start with mono display
     GetBestMode screenMode                  ' get initial screen mode

     SCREEN 0                                ' init screen
     WIDTH 80, 25
     CLS

     MenuInit                                ' init menu routines
     WindowInit                              ' init window routines
     MouseInit                               ' init mouse routines

     ' exit if no graphic mode available
     IF screenMode = 0 THEN
         PrintError "No graphic screen modes available for charting. Exiting p
         finished = TRUE
         EXIT SUB
     ELSE
         finished = FALSE
     END IF

     SetUpMenu                               ' Set up menu bar
     SetUpBackground                         ' Set up screen background
     InitChart                               ' Initialize chart
     InitColors                              ' Set up color list
     InitStyles                              ' Set up border style list
     InitFonts                               ' Set up font lists

     MenuShow                                ' display menu bar
     MouseShow                               ' display mouse

     '               display program introduction
     a$ = "Microsoft QuickChart|"
     a$ = a$ + "A Presentation Graphics Toolbox Demo|"
     a$ = a$ + "for|"
     a$ = a$ + "Microsoft BASIC 7.0 Professional Development System|"
     a$ = a$ + "Copyright (c) 1989 Microsoft Corporation|"

     temp = Alert(4, a$, 9, 12, 15, 68, "Color", "Monochrome", "")

     ' set display to color or monochrome depending on colorDislay
     IF temp = 1 THEN colorDisplay = TRUE

     SetDisplayColor

 END SUB

 '
 ' Sub Name: InitChart
 '
 ' Description: Initializes chart environment variables and other
 '              related information.
 '
 ' Arguments: None
 '
 SUB InitChart

     MenuItemToggle GALLERYTITLE, cBar       ' default chart type is BAR so
                                             ' set up menu that way

     DefaultChart CEnv, cBar, cPlain         ' Get defaults for chart variable

     ClearData                               ' Clear all chart data

 END SUB

 '
 ' Sub Name: Initcolors
 '
 ' Description: Creates color list based on screen mode
 '
 ' Arguments: None
 '
 SUB InitColors
 SHARED screenMode AS INTEGER
 SHARED egacolor() AS INTEGER

     ' init EGA colors$ for SetAtt
     egacolor(0) = 0
     egacolor(1) = 1
     egacolor(2) = 2
     egacolor(3) = 3
     egacolor(4) = 4
     egacolor(5) = 5
     egacolor(6) = 20
     egacolor(7) = 7
     egacolor(8) = 56
     egacolor(9) = 57
     egacolor(10) = 58
     egacolor(11) = 59
     egacolor(12) = 60
     egacolor(13) = 61
     egacolor(14) = 62
     egacolor(15) = 63

     ' create list of displayable colors$ based on screen mode
     SELECT CASE screenMode
         CASE 1
             numColors = 4
             REDIM color$(numColors)
             colors$(1) = "Black"
             colors$(2) = "White"
             colors$(3) = "Bright Cyan"
             colors$(4) = "Bright Magenta"
         CASE 2, 3, 4, 11
             numColors = 2
             REDIM color$(numColors)
             colors$(1) = "Black"
             colors$(2) = "White"
         CASE 7, 8, 9, 12, 13
             numColors = 16
             REDIM color$(numColors)
             colors$(1) = "Black"
             colors$(2) = "High White"
             colors$(3) = "Blue"
             colors$(4) = "Green"
             colors$(5) = "Cyan"
             colors$(6) = "Red"
             colors$(7) = "Magenta"
             colors$(8) = "Brown"
             colors$(9) = "White"
             colors$(10) = "Gray"
             colors$(11) = "Bright Blue"
             colors$(12) = "Bright Green"
             colors$(13) = "Bright Cyan"
             colors$(14) = "Bright Red"
             colors$(15) = "Bright Magenta"
             colors$(16) = "Yellow"
         CASE 10
             numColors = 4
             REDIM color$(numColors)
             colors$(1) = "Off"
             colors$(2) = "On High"
             colors$(3) = "On Normal"
             colors$(4) = "Blink"
     END SELECT

     ' reset chart color pointers to default values
     IF numColors < 16 THEN
         CEnv.ChartWindow.Background = 0
         CEnv.ChartWindow.BorderColor = 1
         CEnv.DataWindow.Background = 0
         CEnv.DataWindow.BorderColor = 1
         CEnv.MainTitle.TitleColor = 1
         CEnv.SubTitle.TitleColor = 1
         CEnv.XAxis.AxisColor = 1
         CEnv.XAxis.AxisTitle.TitleColor = 1
         CEnv.YAxis.AxisColor = 1
         CEnv.YAxis.AxisTitle.TitleColor = 1
         CEnv.Legend.TextColor = 1
         CEnv.Legend.LegendWindow.Background = 0
         CEnv.Legend.LegendWindow.BorderColor = 1
     END IF
 END SUB

 '
 ' Sub Name: InitFonts
 '
 ' Description: sets up default font and initializes font list
 '
 ' Arguments: None
 '
 SUB InitFonts
 DIM FI AS FontInfo

     ' reset
     UnRegisterFonts
     SetMaxFonts 1, 1

     ' get default font
     DefaultFont Segment%, Offset%
     reg% = RegisterMemFont%(Segment%, Offset%)

     ' load default font
     numFonts = LoadFont("n1")

     IF numFonts = 0 THEN numFonts = 1

     fonts$(numFonts) = "IBM 8 Point"

     UnRegisterFonts
 END SUB

 '
 ' Sub Name: InitStyles
 '
 ' Description: Initializes border styles list
 '
 ' Arguments: None
 '
 SUB InitStyles

     ' create list of border styles
     styles$(1) = "────────────────"
     styles$(2) = "────    ────        "
     styles$(3) = "────         ──      "
     styles$(4) = "──  ──  ──      ──  "
     styles$(5) = "──  ─   ──  ─       "
     styles$(6) = "─── ─── ─── ──    ─ "
     styles$(7) = "─── ─ ─ ─── ─     ─ "
     styles$(8) = "──── ── ── ──── "
     styles$(9) = "──── ── ──── ── "
     styles$(10) = "──── ─ ─ ── ─     ─ "
     styles$(11) = "──  ─── ─    ─  ─── "
     styles$(12) = "─ ─ ─   ─ ─ ─       "
     styles$(13) = "─ ─ ─ ─ ─ ─ ─     ─ "
     styles$(14) = "───  ─  ───  ─      "
     styles$(15) = "──  ─   ─   ─    ─  "

 END SUB

 '
 ' Func Name: Min
 '
 ' Description: Compares two numbers and returns the smallest
 '
 ' Arguments: num1, num2 - numbers to compare
 '
 FUNCTION Min% (num1, num2)

     IF num1 <= num2 THEN
         Min% = num1
     ELSE
         Min% = num2
     END IF

 END FUNCTION

 '
 ' Sub Name: Quit
 '
 ' Description: Exits the program after allowing the user a chance to
 '              save the current chart
 '
 ' Arguments: None
 '
 SUB Quit
 SHARED finished AS INTEGER, saveFile$, origPath$

     ' Allow user to save chart if necessary
     IF chartChanged THEN
         a$ = "| " + "Current chart has not been saved.  Save now?"

         status = Alert(4, a$, 8, 15, 12, 65, "Yes", "No", "Cancel")

         ' save chart
         IF status = OK THEN
             status = SaveChart(saveFile$, FALSE)
         END IF
     ELSE
         status = OK
     END IF

     ' quit if operation has not been canceled.
     IF status <> CANCEL THEN
         CHDRIVE MID$(origPath$, 1, 2)
         CHDIR MID$(origPath$, 3, LEN(origPath$))
         finished = TRUE
         MouseHide
         COLOR 15, 0
         CLS
     END IF

 END SUB

 '
 ' Sub Name: ScrollList
 '
 ' Description: Handles scrolling for a list box.
 '
 ' Arguments: text$() - list
 '            tbox - list box
 '            currButton - current button
 '            status - to determine if button was pressed, or up or down arrow
 '                     keys were used
 '            func - for special operations (passed to DrawList)
 '            winRow - top row of current window
 '            winCol - left column of current window
 '
 SUB ScrollList (text$(), tbox AS ListBox, currButton, status, func, winRow, w

     ' scroll using scroll buttons
     IF currButton = tbox.scrollButton AND status = 1 THEN
         SELECT CASE Dialog(19)
             ' scroll up
             CASE -1:
                 IF tbox.currTop > 1 THEN
                     tbox.currTop = tbox.currTop - 1
                     tbox.currPos = tbox.currPos + 1
                     IF tbox.currPos > tbox.maxLen THEN tbox.currPos = tbox.ma
                 END IF
             ' scroll down
             CASE -2:
                 IF tbox.currTop + tbox.maxLen <= tbox.listLen THEN
                     tbox.currTop = tbox.currTop + 1
                     tbox.currPos = tbox.currPos - 1
                     IF tbox.currPos < 1 THEN tbox.currPos = 1
                 END IF
             ' scroll to position
             CASE ELSE:
                 position = Dialog(19)
                 IF position > 1 THEN
                     position = position * (tbox.listLen) / (tbox.boxLen - 2)
                     IF position < 1 THEN
                         positon = 1
                     ELSEIF position > tbox.listLen THEN
                         position = tbox.listLen
                     END IF
                 END IF

                 IF tbox.currTop <= position AND tbox.currTop + tbox.maxLen >
                     tbox.currPos = position - tbox.currTop + 1
                 ELSEIF position <= tbox.maxLen THEN
                     tbox.currTop = 1
                     tbox.currPos = position
                 ELSE
                     tbox.currTop = position - tbox.maxLen + 1
                     tbox.currPos = position - tbox.currTop + 1
                 END IF
         END SELECT

     ' area button chosen
     ELSEIF status = 1 THEN
         ' make selected position the current position
         IF Dialog(17) <= tbox.maxLen THEN
             tbox.currPos = Dialog(17)
             DrawList text$(), tbox, func
         END IF

         ' poll for repeated scrolling while mouse button is down
         DO
             X! = TIMER
             MousePoll r, c, lb, rb              ' poll mouse
             IF lb = TRUE THEN
                 ' if below list box then scroll down
                 IF r > tbox.botRow + winRow - 2 THEN
                     GOSUB Down1
                 ' if above list box then scroll up
                 ELSEIF r < tbox.topRow + winRow THEN
                     GOSUB Up1
                 ' if to right of list box then scroll down
                 ELSEIF c > tbox.rightCol + winCol - 2 THEN
                     GOSUB Down1
                 ' if to left of list box then scroll up
                 ELSEIF c < tbox.leftCol + winCol THEN
                     GOSUB Up1
                 ' inside box
                 ELSEIF r - winRow - tbox.topRow + 1 <= tbox.maxLen THEN
                     tbox.currPos = r - winRow - tbox.topRow + 1
                 END IF

                 ' draw list
                 DrawList text$(), tbox, func
             ELSE
                 EXIT DO
             END IF
             WHILE TIMER < X! + .05: WEND
         LOOP

     ' up arrow key hit
     ELSEIF status = 2 THEN
         GOSUB Up1

     ' down arrow key hit
     ELSEIF status = 3 THEN
         GOSUB Down1
     END IF

     DrawList text$(), tbox, func                    ' redraw list

     EXIT SUB

 ' scroll list up one
 Up1:
     IF tbox.currPos > 1 THEN
         tbox.currPos = tbox.currPos - 1
     ELSEIF tbox.currTop > 1 THEN
         tbox.currTop = tbox.currTop - 1
     END IF
 RETURN

 ' scroll list down one
 Down1:
     IF tbox.currPos < tbox.maxLen THEN
         tbox.currPos = tbox.currPos + 1
     ELSEIF tbox.currTop + tbox.maxLen <= tbox.listLen THEN
         tbox.currTop = tbox.currTop + 1
     END IF
 RETURN

 END SUB

 '
 ' Sub Name: Setatt
 '
 ' Description: Changes a color's attribute to that of another color's.
 '              This is used in the ChangeTitle routine to allow user
 '              color selections to immediately change the foreground
 '              color of the title edit field.  This allows the user
 '              to view the colors as they would look on a chart
 '
 ' Arguments: change - color to change
 '            source - color to change to
 '
 SUB SetAtt (change, source)
 SHARED screenMode AS INTEGER
 SHARED egacolor() AS INTEGER

     ' map colors$ based on screen mode
     SELECT CASE screenMode
         CASE 10:
             IF source > 2 THEN
                 temp = 9                            ' set "normal" and "blink
             ELSE
                 temp = source                       ' off = black; high white
             END IF
         CASE 1:
             IF source = 3 THEN                      ' map to cyan
                 temp = 13
             ELSEIF source = 4 THEN                  ' map to magenta
                 temp = 15
             ELSE                                    ' others okay
                 temp = source
             END IF
         CASE ELSE
             temp = source                           ' colors$ okay
     END SELECT

     ' change attribute
     DIM regs AS RegType
     regs.ax = &H1000
     regs.bx = 256 * egacolor(TrueColr(temp)) + change
     CALL INTERRUPT(&H10, regs, regs)

 END SUB

 '
 ' Sub Name: SetDisplayColor
 '
 ' Description: Changes the program's display to monochrome (no colors) or
 '              to color (include colors in menu bar) based on the value of
 '              colorDisplay.
 '
 ' Arguments: none
 '
 SUB SetDisplayColor
 SHARED colorDisplay AS INTEGER

     MouseHide

     ' redraw background based on display color
     SetUpBackground

     ' set menu bar to include colors
     IF colorDisplay THEN
         MenuSetState OPTIONSTITLE, 1, 2
         MenuSetState OPTIONSTITLE, 2, 1
         MenuColor 0, 7, 4, 8, 0, 4, 7
     ' set monochrome menu bar
     ELSE
         MenuSetState OPTIONSTITLE, 1, 1
         MenuSetState OPTIONSTITLE, 2, 2
         MenuColor 0, 7, 15, 8, 7, 0, 15
     END IF

     MenuShow
     MouseShow

 END SUB

 '
 ' Sub Name: SetUpBackground
 '
 ' Description: Creates and displays background screen pattern
 '
 ' Arguments: none
 '
 SUB SetUpBackground
 SHARED colorDisplay AS INTEGER

     MouseHide

     WIDTH , 25
     IF colorDisplay THEN
         COLOR 15, 1                             ' set color for background
     ELSE
         COLOR 15, 0
     END IF
     CLS

     FOR a = 2 TO 80 STEP 4                      ' create and display pattern
         FOR b = 2 TO 25 STEP 2
             LOCATE b, a
             PRINT CHR$(250);
         NEXT b
     NEXT a

     MouseShow

 END SUB

 '
 ' Sub Name: SetUpMenu
 '
 ' Description: Creates menu bar for the program
 '
 ' Arguments: none
 '
 SUB SetUpMenu

     ' file menu title
     MenuSet FILETITLE, 0, 1, "File", 1
     MenuSet FILETITLE, 1, 1, "New", 1
     MenuSet FILETITLE, 2, 1, "Open ...", 1
     MenuSet FILETITLE, 3, 1, "Save", 1
     MenuSet FILETITLE, 4, 1, "Save As ...", 6
     MenuSet FILETITLE, 5, 1, "-", 1
     MenuSet FILETITLE, 6, 1, "Exit", 2

     ' view menu title
     MenuSet VIEWTITLE, 0, 1, "View", 1
     MenuSet VIEWTITLE, 1, 1, "Data ...", 1
     MenuSet VIEWTITLE, 2, 1, "Chart        F5", 1
     MenuSet VIEWTITLE, 3, 1, "Fonts ...", 1
     MenuSet VIEWTITLE, 4, 1, "Screen Mode ...", 1

     ' gallery menu title
     MenuSet GALLERYTITLE, 0, 1, "Gallery", 1
     MenuSet GALLERYTITLE, 1, 1, "Bar ...", 1
     MenuSet GALLERYTITLE, 2, 1, "Column ...", 1
     MenuSet GALLERYTITLE, 3, 1, "Line ...", 1
     MenuSet GALLERYTITLE, 4, 1, "Scatter ...", 1
     MenuSet GALLERYTITLE, 5, 1, "Pie ...", 1

     ' chart menu title
     MenuSet CHARTTITLE, 0, 1, "Chart", 1
     MenuSet CHARTTITLE, 1, 1, "Chart Window ...", 1
     MenuSet CHARTTITLE, 2, 1, "Data Window ...", 1
     MenuSet CHARTTITLE, 3, 1, "Legend ...", 1
     MenuSet CHARTTITLE, 4, 1, "X Axis ...", 1
     MenuSet CHARTTITLE, 5, 1, "Y Axis ...", 1

     ' title menu title
     MenuSet TITLETITLE, 0, 1, "Title", 1
     MenuSet TITLETITLE, 1, 1, "Main ...", 1
     MenuSet TITLETITLE, 2, 1, "Sub ...", 1
     MenuSet TITLETITLE, 3, 1, "X Axis ...", 1
     MenuSet TITLETITLE, 4, 1, "Y Axis ...", 1

     ' options menu title
     MenuSet OPTIONSTITLE, 0, 1, "Options", 1
     MenuSet OPTIONSTITLE, 1, 1, "Color", 1
     MenuSet OPTIONSTITLE, 2, 1, "Monochrome", 1

     ' setup short cuts for some menu choices
     ShortCutKeySet VIEWTITLE, 2, CHR$(0) + CHR$(63)     ' F5 = View Chart

     ' set original menu colors for monochrome screen
     MenuColor 0, 7, 15, 8, 7, 0, 15
     MenuPreProcess

 END SUB

 '
 ' Function Name: TrueColr
 '
 ' Description: Maps a given chart color to its actual color
 '              and returns this color.  This is needed because the chart
 '              colors start with BLACK = 1 and HIGH WHITE = 2
 '
 ' Arguments: colr - chart color number
 '
 FUNCTION TrueColr% (colr)

     IF colr = 1 THEN                                ' black
         TrueColr% = 0                               ' bright white
     ELSEIF colr = 2 THEN
         TrueColr% = 15
     ELSE
         TrueColr% = colr - 2                        ' all others
     END IF

 END FUNCTION

 '
 ' Sub Name: ViewChart
 '
 ' Description: Displays the chart
 '
 ' Arguments: none
 '
 SUB ViewChart
 SHARED setVal!(), Cat$(), setLen() AS INTEGER, setName$()
 SHARED screenMode AS INTEGER

     ' When a chart is drawn, data is moved from the 2-dimensional array
     ' into arrays suitable for the charting library routines.  The
     ' following arrays are used directly in calls to the charting routines:
     DIM ValX1!(1 TO cMaxValues)                    ' pass to chart routine
     DIM ValY1!(1 TO cMaxValues)
     DIM ValX2!(1 TO cMaxValues, 1 TO cMaxSeries)   ' pass to chartMS routine
     DIM ValY2!(1 TO cMaxValues, 1 TO cMaxSeries)

     DIM explode(1 TO cMaxValues)  AS INTEGER       ' explode pie chart pieces


    ' Make sure some data exists
    IF setNum <= 0 THEN
        a$ = "|"
        a$ = a$ + "No data available for chart."
        junk = Alert(4, a$, 8, 15, 12, 65, "", "", "")
        EXIT SUB
    END IF

    ' find the longest series
    maxLen% = 0
    FOR i% = 1 TO setNum
       IF setLen(i%) > maxLen% THEN maxLen% = setLen(i%)
    NEXT i%

    ' Set up the proper screen mode (exit if not valid)
    ChartScreen screenMode
    IF ChartErr = cBadScreen THEN
         PrintError "Invalid screen mode. Can't display chart."
         EXIT SUB
    END IF

    ' Process depending on chart type
    SELECT CASE CEnv.ChartType
       CASE cBar, cColumn, cLine, cPie:
          ' If the chart is a single series one or a pie chart:
          IF setNum = 1 OR CEnv.ChartType = cPie THEN

             ' Transfer data into a single dimension array:
             FOR i% = 1 TO maxLen%
                ValX1!(i%) = setVal!(i%, 1)
             NEXT i%

             IF CEnv.ChartType = cPie THEN
                 ' determine which pieces to explode
                 FOR i% = 1 TO maxLen%
                     IF setVal!(i%, 2) <> 0 THEN
                         explode(i%) = 1
                     ELSE
                         explode(i%) = 0
                     END IF
                 NEXT i%

                 ' display pie chart
                 ChartPie CEnv, Cat$(), ValX1!(), explode(), maxLen%
             ELSE
                 Chart CEnv, Cat$(), ValX1!(), maxLen%
             END IF

          ' If multiple series, then data is OK so just call routine:
          ELSE
             ChartMS CEnv, Cat$(), setVal!(), maxLen%, 1, setNum, setName$()
          END IF

       CASE cScatter:
          ' Make sure there's enough data sets:
          IF setNum = 1 THEN
             SCREEN 0
             WIDTH 80
             SetUpBackground
             MenuShow
             MouseShow
             a$ = "|"
             a$ = a$ + "Too few data sets for Scatter chart"
             junk = Alert(4, a$, 8, 15, 12, 65, "", "", "")
             EXIT SUB

          ' If it's a single series scatter, transfer data to one-
          ' dimensional arrays and make chart call:
          ELSEIF setNum = 2 THEN
             FOR i% = 1 TO maxLen%
                ValX1!(i%) = setVal!(i%, 1)
                ValY1!(i%) = setVal!(i%, 2)
             NEXT i%
             ChartScatter CEnv, ValX1!(), ValY1!(), maxLen%

          ' If it's a multiple series scatter, transfer odd columns to
          ' X-axis data array and even columns to Y-axis array and make
          ' chart call:
          ELSE
             FOR j% = 2 TO setNum STEP 2
                FOR i% = 1 TO maxLen%
                   ValX2!(i%, j% \ 2) = setVal!(i%, j% - 1)
                   ValY2!(i%, j% \ 2) = setVal!(i%, j%)
                NEXT i%
             NEXT j%

             ChartScatterMS CEnv, ValX2!(), ValY2!(), maxLen%, 1, setNum \ 2,
          END IF

    END SELECT

    ' If there's been a "fatal" error, indicate what it was:
    IF ChartErr <> 0 THEN
        GOSUB ViewError

    ' Otherwise, just wait for a keypress:
    ELSE
       ' Wait for keypress
       DO
             c$ = INKEY$
             MousePoll r, c, lb, rb
       LOOP UNTIL c$ <> "" OR lb OR rb
       SCREEN 0
       WIDTH 80
       SetUpBackground
       MenuShow
       MouseShow
    END IF

 EXIT SUB

 ' handle charting errors
 ViewError:

     ' re-init the display
     SCREEN 0
     WIDTH 80
     SetUpBackground
     MenuShow
     MouseShow

     ' display appropriate error message
     SELECT CASE ChartErr
         CASE cBadDataWindow:
             PrintError "Data window cannot be displayed in available space."
         CASE cBadLegendWindow:
             PrintError "Invalid legend coordinates."
         CASE cTooFewSeries:
             PrintError "Too few series to plot."
         CASE cTooSmallN:
             PrintError "No data in series."
         CASE IS > 200:                              ' basic error
             PrintError "BASIC error #" + LTRIM$(STR$(ChartErr - 200)) + " occ
         CASE ELSE:                                  ' extraneous error
             PrintError "Charting error #" + LTRIM$(STR$(ChartErr)) + " occurr
     END SELECT

 RETURN

 END SUB

 '
 ' Sub Name: ViewFont
 '
 ' Description: Displays list of registered fonts and allows user to
 '              select one or more of these fonts to load
 '
 ' Arguments: none
 '
 SUB ViewFont
 SHARED screenMode AS INTEGER
 SHARED origPath$
 DIM FI AS FontInfo
 DIM rfonts$(1 TO MAXFONTS)

     SetMaxFonts MAXFONTS, MAXFONTS

     ' get default font
     DefaultFont Segment%, Offset%
     numReg = RegisterMemFont%(Segment%, Offset%)

     ' use font files that are best suited for current screen mode
     IF MID$(origPath$, LEN(origPath$), 1) = "\" THEN
         t$ = ""
     ELSE
         t$ = "\"
     END IF
     SELECT CASE screenMode
         CASE 2, 8
             cour$ = origPath$ + t$ + "COURA.FON"
             helv$ = origPath$ + t$ + "HELVA.FON"
             tims$ = origPath$ + t$ + "TMSRA.FON"
         CASE 11, 12
             cour$ = origPath$ + t$ + "COURE.FON"
             helv$ = origPath$ + t$ + "HELVE.FON"
             tims$ = origPath$ + t$ + "TMSRE.FON"
         CASE ELSE
             cour$ = origPath$ + t$ + "COURB.FON"
             helv$ = origPath$ + t$ + "HELVB.FON"
             tims$ = origPath$ + t$ + "TMSRB.FON"
     END SELECT
     ' register courier fonts
     numReg = numReg + RegisterFonts%(cour$)
     fontname$ = cour$
     IF FontErr > 0 THEN GOSUB FontError

     ' register helvetica fonts
     numReg = numReg + RegisterFonts%(helv$)
     fontname$ = helv$
     IF FontErr > 0 THEN GOSUB FontError

     ' register times roman fonts
     numReg = numReg + RegisterFonts%(tims$)
     fontname$ = tims$
     IF FontErr > 0 THEN GOSUB FontError

     ' create a list of registered fonts
     FOR i = 1 TO numReg
         GetRFontInfo i, FI
         rfonts$(i) = RTRIM$(MID$(FI.FaceName, 1, 8)) + STR$(FI.Points) + " Po
     NEXT i

     ' set up window display
     winRow = 5
     winCol = 25
     WindowOpen 1, winRow, winCol, winRow + numReg + 1, 51, 0, 7, 0, 7, 15, FA

     ' open buttons for each font in list
     FOR i% = 1 TO numReg
         ButtonOpen i, 1, rfonts$(i), i, 4, 0, 0, 2
         FOR j% = 1 TO numFonts
             IF fonts$(j%) = rfonts$(i%) THEN ButtonSetState i, 2
         NEXT j%
     NEXT i%

     WindowLine numReg + 1
     ButtonOpen numReg + 1, 2, "Load", numReg + 2, 4, 0, 0, 1
     ButtonOpen numReg + 2, 1, "Cancel ", numReg + 2, 15, 0, 0, 1

     ' start with cursor on first button
     currButton = 1
     pushButton = numReg + 1

     ' window control loop
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, 0
         SELECT CASE Dialog(0)
             CASE 1                                     ' button pressed
                 currButton = Dialog(1)
                 IF currButton > numReg THEN
                     pushButton = currButton
                     finished = TRUE
                 ELSE
                     ButtonToggle currButton
                 END IF
             CASE 6                                      ' enter
                 finished = TRUE
             CASE 7                                      ' tab
                 SELECT CASE currButton
                     CASE numReg, numReg + 1:
                         currButton = currButton + 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE numReg + 2:
                         currButton = 1
                         ButtonSetState pushButton, 1
                         pushButton = numReg + 1
                         ButtonSetState pushButton, 2
                     CASE ELSE:
                         currButton = currButton + 1
                 END SELECT
             CASE 8                                      ' back tab
                 SELECT CASE currButton
                     CASE 1:
                         currButton = numReg + 2
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE numReg + 2:
                         currButton = numReg + 1
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = currButton
                     CASE ELSE:
                         currButton = currButton - 1
                     END SELECT
             CASE 9                                      ' escape
                 pushButton = numReg + 2
                 finished = TRUE
             CASE 10, 12                                 ' up, left arrow
                 IF currButton <= numReg THEN ButtonSetState currButton, 2
             CASE 11, 13                                 ' down, right arrow
                 IF currButton <= numReg THEN ButtonSetState currButton, 1
             CASE 14                                     ' space bar
                 IF currButton <= numReg THEN
                     ButtonToggle currButton
                 ELSE
                     finished = TRUE
                 END IF
         END SELECT

     ' finished and not cancelled
     IF finished AND pushButton = numReg + 1 THEN
         ' create font spec for load operation
         FontSpec$ = ""
         FOR i% = 1 TO numReg
             IF ButtonInquire(i) = 2 THEN
                 FontSpec$ = FontSpec$ + "/n" + LTRIM$(STR$(i))
             END IF
         NEXT i%

         ' default if none chosen
         IF FontSpec$ = "" THEN
             PrintError "No fonts selected - using default."
             numFonts = LoadFont%("N1")
             REDIM fonts$(1)
             fonts$(1) = rfonts$(1)
         ELSE
             ' load selected fonts
             numLoaded = LoadFont%(RIGHT$(FontSpec$, LEN(FontSpec$) - 1))

             ' notify user of error and let them try again.
             IF FontErr <> 0 THEN
                 GOSUB FontError
                 finished = FALSE
                 currButton = 1
             ELSE
                 REDIM fonts$(numLoaded)
                 ' create a list of loaded fonts
                 FOR i = 1 TO numLoaded
                     SelectFont i
                     GetFontInfo FI
                     fonts$(i) = RTRIM$(MID$(FI.FaceName, 1, 8)) + STR$(FI.Poi
                 NEXT i
                 numFonts = numLoaded
                 ClearFonts
             END IF
         END IF
     ' reload existing fonts if operation cancelled
     ELSEIF finished = TRUE AND pushButton = numReg + 2 THEN
         FontSpec$ = ""
         FOR i = 1 TO numReg
             FOR j% = 1 TO numFonts
                 IF fonts$(j%) = rfonts$(i%) THEN FontSpec$ = FontSpec$ + "/n"
             NEXT j%
         NEXT i
         numFonts = LoadFont%(RIGHT$(FontSpec$, LEN(FontSpec$) - 1))
     END IF

     WEND

     UnRegisterFonts

     WindowClose 1

     EXIT SUB

 ' handle font loading errors
 FontError:
     SELECT CASE FontErr
         CASE cNoFontMem:
             PrintError "Not enough memory to load selected fonts."
         CASE cFileNotFound:
             PrintError fontname$ + " font file not found."
         CASE cTooManyFonts:
             numReg = MAXFONTS
         CASE cBadFontFile:
             PrintError "Invalid font file format for " + fontname$ + "."
         CASE cNoFonts:
             PrintError "No fonts are loaded."
         CASE cBadFontType:
             PrintError "Font not a bitmap font."
         CASE IS > 200:                                  ' basic error
             PrintError "BASIC error #" + LTRIM$(STR$(FontErr - 200)) + " occu
         CASE ELSE                                       ' unplanned font erro
             PrintError "Font error #" + LTRIM$(STR$(FontErr)) + " occurred."
     END SELECT

 RETURN

 END SUB

 '
 ' Sub Name: ViewScreenMode
 '
 ' Description: Displays list of valid screen modes and allows the
 '              user to select one for viewing the chart
 '
 ' Arguments: none
 '
 SUB ViewScreenMode
 SHARED screenMode AS INTEGER, numModes AS INTEGER, mode$()

 DIM modeBox AS ListBox

     ' set up list box containing valid screen modes
     modeBox.scrollButton = 1
     modeBox.areaButton = 2
     modeBox.listLen = numModes
     modeBox.topRow = 1
     modeBox.botRow = numModes + 2
     modeBox.leftCol = 7
     modeBox.rightCol = 21

     ' determine current screen mode
     FOR i = 1 TO numModes
         IF screenMode = VAL(mode$(i)) THEN modeBox.listPos = i
     NEXT i

     ' set up display window
     winRow = 6
     winCol = 25
     WindowOpen 1, winRow, winCol, winRow + numModes + 3, 51, 0, 7, 0, 7, 15,
     WindowLine numModes + 3

     ' create the list box
     CreateListBox mode$(), modeBox, 0

     ' open command buttons
     ButtonOpen 3, 2, "OK ", numModes + 4, 4, 0, 0, 1
     ButtonOpen 4, 1, "Cancel ", numModes + 4, 16, 0, 0, 1


         a$ = "Screen Mode Warning ||"
         a$ = a$ + "Selecting screen modes that support less than |"
         a$ = a$ + "than 16 colors will reset all chart colors to |"
         a$ = a$ + "their black and white defaults.               |"
         a$ = a$ + "|" + " Fonts should be reloaded after screen mode is   |"
         a$ = a$ + " changed to ensure best font match for screen   |"
         a$ = a$ + " resolution.                                     "
         junk = Alert(4, a$, 6, 15, 16, 65, "", "", "")


     ' start with cursor in area button
     currButton = 2
     pushButton = 3

     ' window control loop
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, 0                         ' wait for event
         SELECT CASE Dialog(0)
             CASE 1                                     ' button pressed
                 currButton = Dialog(1)
                 SELECT CASE currButton
                     CASE 1, 2:
                         ScrollList mode$(), modeBox, currButton, 1, 0, winRow
                         currButton = 2
                     CASE 3, 4:
                         pushButton = currButton
                         finished = TRUE
                 END SELECT
             CASE 6                                      ' enter
                 finished = TRUE
             CASE 7                                      ' tab
                 SELECT CASE currButton
                     CASE 1, 2:
                         currButton = 3
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = 3
                     CASE 3:
                         currButton = 4
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = 4
                     CASE 4:
                         ButtonSetState currButton, 1
                         currButton = 2
                         pushButton = 3
                         ButtonSetState pushButton, 2
                 END SELECT
             CASE 8                                      ' back tab
                 SELECT CASE currButton
                     CASE 1, 2:
                         currButton = 4
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = 4
                     CASE 3: currButton = 2
                     CASE 4:
                         currButton = 3
                         ButtonSetState pushButton, 1
                         ButtonSetState currButton, 2
                         pushButton = 3
                     END SELECT
             CASE 9                                      ' escape
                 pushButton = 4
                 finished = TRUE
             CASE 10, 12                                 ' up, left arrow
                 SELECT CASE currButton
                     CASE 1, 2: ScrollList mode$(), modeBox, currButton, 2, 0,
                 END SELECT
             CASE 11, 13                                 ' down, right arrow
                 SELECT CASE currButton
                     CASE 1, 2: ScrollList mode$(), modeBox, currButton, 3, 0,
                 END SELECT
             CASE 14                                     ' space bar
                 IF currButton > 2 THEN finished = TRUE
         END SELECT
     WEND

     ' if not canceled
     IF pushButton = 3 THEN
         ' change screen mode
         IF screenMode <> VAL(mode$(modeBox.listPos)) THEN
             IF setNum > 0 THEN chartChanged = TRUE

             screenMode = VAL(mode$(modeBox.listPos))

             ' reset window coords
             CEnv.ChartWindow.X1 = 0
             CEnv.ChartWindow.Y1 = 0
             CEnv.ChartWindow.X2 = 0
             CEnv.ChartWindow.Y2 = 0

             ' change color list based on new screen mode
             InitColors
         END IF
     END IF

     WindowClose 1

 END SUB



 CHRTDEMO.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\CHRTDEMO.BAS

 '       CHRTDEMO.BAS - Main module of CHRTB demonstration program
 '
 '             Copyright (C) 1989, Microsoft Corporation
 '
 '   This demo program uses the Presentation Graphics and User Interface
 '   toolboxes to implement a general purpose charting package.
 '   It consists of three modules (CHRTDEMO.BAS, CHRTDEM1.BAS and CHRTDEM2.BAS
 '   and one include file (CHRTDEMO.BI).  It requires access to both the
 '   Presentation Graphics and User Interface toolboxes.
 '
 '   EMS is needed to load and run the demo under QBX.  If you do not
 '   have EMS, refer to the command line compile instructions below which
 '   will allow you to run the demo from the DOS prompt.  Running the
 '   demo under QBX requires access to the Presentation Graphics and User
 '   Interface toolboxes.  This can be done in one of two methods:
 '       1) One large QuickLib covering both toolboxes can be created.  The
 '          library "CHRTDEM.LIB" and QuickLib "CHRTDEM.QLB" are created
 '          as follows:
 '           BC /X/FS chrtb.bas;
 '           BC /X/FS fontb.bas;
 '           LIB chrtdem.lib + uitbefr.lib + fontasm + chrtasm + fontb + chrtb
 '           LINK /Q chrtdem.lib, chrtdem.qlb,,qbxqlb.lib;
 '          Once created, just start QBX with this QuickLib and load the
 '          demo's modules (chrtdemo.bas, chrtdem1.bas and chrtdem2.bas).
 '
 '       2) Either the Presentation Graphics or User Interface QuickLib
 '          may be used alone provided the other's source code files
 '          are loaded into the QBX environment.  If CHRTBEFR.QLB is
 '          is used then WINDOW.BAS, GENERAL.BAS, MENU.BAS and MOUSE.BAS
 '          must be loaded.  If UITBEFR.QLB is used then CHRTB.BAS and
 '          FONTB.BAS must be loaded.  Once a QuickLib is specified and
 '          all necessary source files are loaded, load the program
 '          modules (chrtdemo.bas, chrtdem1.bas and chrtdem2.bas)
 '
 '   To create a compiled version of the chart demo program perform the
 '   following steps:
 '       BC /X/FS chrtb.bas;
 '       BC /X/FS fontb.bas;
 '       LIB chrtdem.lib + uitbefr.lib + fontasm + chrtasm + fontb + chrtb;
 '       BC /X/FS chrtdemo.bas;
 '       BC /FS chrtdem1.bas;
 '       BC /FS chrtdem2.bas;
 '       LINK /EX chrtdemo chrtdem1 chrtdem2, chrtdemo.exe,, chrtdem.lib;
 '   "CHRTDEMO" can now be run from the command line.
 '
 '
 DEFINT A-Z

 '$INCLUDE: 'chrtdemo.bi'

 ' local functions
 DECLARE FUNCTION GetLoadFile% (FileName$)
 DECLARE FUNCTION GetSaveFile% (FileName$)
 DECLARE FUNCTION GetFileCount% (fileSpec$)

 ' local subs
 DECLARE SUB LoadChart (fileNum%)
 DECLARE SUB ShowError (errorNum%)


 ' necessary variables for the toolboxes
 DIM GloTitle(MAXMENU)           AS MenuTitleType
 DIM GloItem(MAXMENU, MAXITEM)   AS MenuItemType
 DIM GloWindow(MAXWINDOW)        AS windowType
 DIM GloButton(MAXBUTTON)        AS buttonType
 DIM GloEdit(MAXEDITFIELD)       AS EditFieldType
 DIM GloWindowStack(MAXWINDOW)   AS INTEGER
 DIM GloBuffer$(MAXWINDOW + 1, 2)

 ' variables shared across modules
 DIM colors$(1 TO MAXCOLORS)                     'valid colors$
 DIM styles$(1 TO MAXSTYLES)                     'border style list
 DIM fonts$(1 TO MAXFONTS)                       'fonts list
 DIM Cat$(1 TO cMaxValues)                       'category names
 DIM setName$(1 TO cMaxSets)                     'set names
 DIM setLen(1 TO cMaxSets)   AS INTEGER          '# values per set
 DIM setVal!(1 TO cMaxValues, 1 TO cMaxSets)     ' actual values
 DIM mode$(1 TO 13)                              'list of modes


     ' set up main error handler
     ON ERROR GOTO ErrorHandle

     ' initialize the program
     InitAll

     ' Main loop
     WHILE NOT finished
         kbd$ = MenuInkey$
         WHILE MenuCheck(2)
             HandleMenuEvent
         WEND
     WEND

     END

 'catch all error handler
 ErrorHandle:
     ShowError ERR
     WindowClose 1                               ' close any active windows
     WindowClose 2
 RESUME NEXT

 '
 ' Function Name: GetBestMode
 '
 ' Description: Creates a list of valid screen modes for use by charting funct
 '              and sets the initial screen mode to the highest resolution
 '              possible.  If no graphic screen modes are available then
 '              it causes the program to exit.
 '
 ' Arguments: screenMode
 '
 SUB GetBestMode (screenMode)
 SHARED mode$(), numModes AS INTEGER

 ON LOCAL ERROR GOTO badmode                     ' trap screen mode errors

     ' test all possible screen modes creating a list of valid ones as we go
     numModes = 0
     FOR i = 13 TO 1 STEP -1
         valid = TRUE
         SCREEN i
         IF valid THEN
             numModes = numModes + 1
             mode$(numModes) = LTRIM$(STR$(i))
         END IF
     NEXT i

     ' exit if no modes available
     IF numModes = 0 THEN
         screenMode = 0
     ' set current screen mode to best possible
     ELSEIF mode$(1) = "13" THEN
         screenMode = VAL(mode$(2))
     ELSE
         screenMode = VAL(mode$(1))
     END IF

 EXIT SUB

 badmode:
     valid = FALSE
 RESUME NEXT

 END SUB

 '
 ' Func Name: GetFileCount
 '
 ' Description: Returns number of DOS files matching a given file spec
 '
 ' Arguments: fileSpec$ - DOS file spec  (i.e. "*.*")
 '
 FUNCTION GetFileCount% (fileSpec$)

 ON LOCAL ERROR GOTO GetCountError

     count = 0

     FileName$ = DIR$(fileSpec$)             ' Get first match if any

     DO WHILE FileName$ <> ""                ' continue until no more matches
         count = count + 1
         FileName$ = DIR$
     LOOP

     GetFileCount = count                    ' return count

     EXIT FUNCTION

 GetCountError:

     ShowError ERR                               ' display error message

 RESUME NEXT

 END FUNCTION

 '
 ' Func Name: GetLoadFile
 '
 ' Description: Called by OpenChart, this prompts the user for a
 '              DOS file to open.  It returns the file number of
 '              the chart file with the actual file name being
 '              passed back via the argument.
 '
 ' Arguments: FileName$ - name of file to open
 '
 FUNCTION GetLoadFile% (FileName$)
 DIM fileList$(1 TO 10)
 DIM fileBox AS ListBox

 ON LOCAL ERROR GOTO GetLoadError                ' handle file opening errors

     fileSpec$ = "*.CHT"                         ' default file spec
     origDir$ = CURDIR$
     origPos = 0                                 ' no file list element select

     ' get list of files matching spec
     fileCount = GetFileCount(fileSpec$)
     IF fileCount THEN
         REDIM fileList$(fileCount)
     END IF
     fileList$(1) = DIR$(fileSpec$)
     FOR i% = 2 TO fileCount
         fileList$(i%) = DIR$
     NEXT i%

     ' set up list box for file list
     fileBox.scrollButton = 1
     fileBox.areaButton = 2
     fileBox.listLen = fileCount
     fileBox.topRow = 8
     fileBox.botRow = 14
     fileBox.leftCol = 7
     fileBox.rightCol = 22
     fileBox.listPos = origPos

     ' create window for display
     winRow = 6
     winCol = 25
     WindowOpen 1, winRow, winCol, 21, 52, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE
     WindowLocate 2, 2
     WindowPrint 2, "File Name:"
     WindowBox 1, 13, 3, 27
     WindowLocate 5, 2
     WindowPrint -1, origDir$
     WindowLocate 7, 11
     WindowPrint 2, "Files"
     WindowLine 15

     ' create list box for file list
     CreateListBox fileList$(), fileBox, 5

     ' open edit field for file spec
     EditFieldOpen 1, fileSpec$, 2, 14, 0, 7, 13, 70

     ' open command buttons
     ButtonOpen 3, 2, "OK", 16, 5, 0, 0, 1
     ButtonOpen 4, 1, "Cancel", 16, 15, 0, 0, 1

     ' start with cursor in edit field
     currButton = 0
     currEditField = 1
     pushButton = 3

     ' control loop
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, currEditField              ' wait for event
         SELECT CASE Dialog(0)
             CASE 1                                      ' button pressed
                 currButton = Dialog(1)
                 SELECT CASE currButton
                     CASE 1, 2: currEditField = 0
                         ScrollList fileList$(), fileBox, currButton, 1, 0, wi
                         currButton = 2
                     CASE 3, 4: pushButton = currButton
                         finished = TRUE
                 END SELECT
             CASE 2                                      ' Edit Field
                 currButton = 0
                 currEditField = 1
             CASE 6                                      ' enter
                 IF INSTR(EditFieldInquire$(1), "*") = 0 THEN finished = TRUE
             CASE 7                                      ' tab
                 SELECT CASE currButton
                     CASE 0: currButton = 2
                         currEditField = 0
                     CASE 1, 2:
                         currButton = 3
                         ButtonSetState 3, 2
                         ButtonSetState 4, 1
                         pushButton = 3
                     CASE 3:
                         currButton = 4
                         ButtonSetState 3, 1
                         ButtonSetState 4, 2
                         pushButton = 4
                     CASE 4:
                         currButton = 0
                         currEditField = 1
                         ButtonSetState 3, 2
                         ButtonSetState 4, 1
                         pushButton = 3
                 END SELECT
             CASE 8                                      ' back tab
                 SELECT CASE currButton
                     CASE 0: currButton = 4
                         currEditField = 0
                         ButtonSetState 3, 1
                         ButtonSetState 4, 2
                         pushButton = 4
                     CASE 1, 2:
                         currButton = 0
                         currEditField = 1
                     CASE 3:
                         currButton = 2
                     CASE 4:
                         currButton = 3
                         ButtonSetState 3, 2
                         ButtonSetState 4, 1
                         pushButton = 3
                 END SELECT
             CASE 9                                      ' escape
                 pushButton = 4
                 finished = TRUE
             CASE 10, 12                                 ' up, left arrow
                 IF currButton = 1 OR currButton = 2 THEN ScrollList fileList$
             CASE 11, 13                                 'down, right arrow
                 IF currButton = 1 OR currButton = 2 THEN ScrollList fileList$
             CASE 14                                     ' space bar
                 IF currButton > 2 THEN
                     pushButton = currButton
                     finished = TRUE
                 END IF
         END SELECT

         temp$ = EditFieldInquire$(1)

         ' simple error checking before finishing
         IF finished AND pushButton <> 4 THEN
             ' invalid file specified
             IF INSTR(temp$, "*") THEN
                 PrintError "Invalid file specification."
                 finished = FALSE
             ELSEIF LEN(temp$) = 0 THEN
                 PrintError "Must specify a name."
                 finished = FALSE
             ELSE
                 fileSpec$ = temp$
                 fileNum% = FREEFILE
                 OPEN fileSpec$ FOR INPUT AS fileNum%

             END IF
         END IF

         ' more processing to do
         IF NOT finished THEN
             ' update edit field display based on list box selection
             IF fileBox.listPos <> origPos THEN
                 fileSpec$ = fileList$(fileBox.listPos)
                 origPos = fileBox.listPos
                 EditFieldClose 1
                 EditFieldOpen 1, fileSpec$, 2, 14, 0, 7, 13, 70
             ' update list box contents based on new edit field contents
             ELSEIF LTRIM$(RTRIM$(fileSpec$)) <> LTRIM$(RTRIM$(temp$)) THEN
                 fileSpec$ = UCASE$(temp$)
                 IF fileSpec$ <> "" THEN
                     IF MID$(fileSpec$, 2, 1) = ":" THEN
                         CHDRIVE MID$(fileSpec$, 1, 2)
                         fileSpec$ = MID$(fileSpec$, 3, LEN(fileSpec$))
                     END IF
                     position = 0
                     WHILE INSTR(position + 1, fileSpec$, "\") <> 0
                         position = INSTR(position + 1, fileSpec$, "\")
                     WEND
                     IF position = 1 THEN
                         CHDIR "\"
                     ELSEIF position > 0 THEN
                         CHDIR LEFT$(fileSpec$, position - 1)
                     END IF
                     fileSpec$ = MID$(fileSpec$, position + 1, LEN(fileSpec$))
                     WindowLocate 5, 2
                     IF LEN(CURDIR$) > 26 THEN
                         direct$ = LEFT$(CURDIR$, 26)
                     ELSE
                         direct$ = CURDIR$
                     END IF
                     WindowPrint -1, direct$ + STRING$(26 - LEN(direct$), " ")

                     fileCount = GetFileCount(fileSpec$)
                 ELSE
                     fileCount = 0
                 END IF

                 EditFieldClose 1
                 EditFieldOpen 1, fileSpec$, 2, 14, 0, 7, 13, 70

                 fileBox.listLen = fileCount
                 fileBox.maxLen = Min(fileCount, fileBox.boxLen)
                 origPos = 0
                 fileBox.listPos = origPos
                 fileBox.currTop = 1
                 fileBox.currPos = 0
                 ' get new file list
                 IF fileCount = 0 THEN
                     REDIM fileList$(10)
                 ELSE
                     REDIM fileList$(fileCount)
                     fileList$(1) = DIR$(fileSpec$)
                     FOR i% = 2 TO fileCount
                         fileList$(i%) = DIR$
                     NEXT i%
                 END IF

                 DrawList fileList$(), fileBox, 0   ' redraw file list
             END IF
         END IF
     WEND

     ' if operation not canceled return file name and file number
     IF pushButton = 3 THEN
         FileName$ = fileSpec$
         GetLoadFile% = fileNum%
     ELSE
         GetLoadFile% = 0

         CHDRIVE MID$(origDir$, 1, 2)
         CHDIR MID$(origDir$, 3, LEN(origDir$))
     END IF

     WindowClose 1

     EXIT FUNCTION

 ' handle any file opening errors
 GetLoadError:
     CLOSE fileNum%
     finished = FALSE                            ' don't allow exit until vali

     ShowError ERR                               ' display error message
 RESUME NEXT

 END FUNCTION

 '
 ' Func Name: GetSaveFile
 '
 ' Description: Prompts the user for a DOS file to save the current
 '              chart data and settings in.  It returns the file number
 '              with the actual file name being passed back via the
 '              argument.
 '
 ' Arguments: fileName$ - name of save file
 '
 FUNCTION GetSaveFile% (FileName$)

 ON LOCAL ERROR GOTO GetSaveError                    ' handle file open errors

     ' Open window for display
     WindowOpen 1, 8, 20, 12, 58, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 1
     WindowLocate 2, 2
     WindowPrint 2, "File Name:"
     WindowBox 1, 13, 3, 38
     WindowLine 4

     ' open edit field for file name
     EditFieldOpen 1, RTRIM$(FileName$), 2, 14, 0, 7, 24, 70

     ' open command buttons
     ButtonOpen 1, 2, "OK", 5, 6, 0, 0, 1
     ButtonOpen 2, 1, "Cancel", 5, 25, 0, 0, 1

     ' start with cursor in edit field
     currButton = 0
     currEditField = 1
     pushButton = 1

     ' control loop for window
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, currEditField              ' wait for event
         SELECT CASE Dialog(0)
             CASE 1                                      ' Button pressed
                 pushButton = Dialog(1)
                 finished = TRUE
             CASE 2                                      ' Edit Field
                 currButton = 0
                 currEditField = 1
             CASE 6                                      ' enter
                 finished = TRUE
             CASE 7                                      ' tab
                 SELECT CASE currButton
                     CASE 0, 1:
                         ButtonSetState currButton, 1
                         currButton = currButton + 1
                         pushButton = currButton
                         ButtonSetState pushButton, 2
                         currEditField = 0
                     CASE 2
                         currButton = 0
                         pushButton = 1
                         currEditField = 1
                         ButtonSetState 1, 2
                         ButtonSetState 2, 1
                 END SELECT
             CASE 8                                      ' back tab
                 SELECT CASE currButton
                     CASE 0:
                         currButton = 2
                         pushButton = 2
                         currEditField = 0
                         ButtonSetState 1, 1
                         ButtonSetState 2, 2
                     CASE 1
                         currButton = 0
                         currEditField = 1
                     CASE 2
                         currButton = 1
                         pushButton = 1
                         ButtonSetState 1, 2
                         ButtonSetState 2, 1
                 END SELECT
             CASE 9                                      ' escape
                 pushButton = 2
                 finished = TRUE
             CASE 14                                     ' space bar
                 IF currButton <> 0 THEN
                     finished = TRUE
                 END IF
         END SELECT

         ' simple error checking before finishing
         IF finished = TRUE AND pushButton = 1 THEN
             temp$ = EditFieldInquire$(1)
             ' must specify a file
             IF temp$ = "" THEN
                 PrintError "Must specify a name."
                 finished = FALSE
             ' check if file is valid and can be opened
             ELSE
                 ' open file
                 fileNum% = FREEFILE
                 OPEN temp$ FOR OUTPUT AS fileNum%

             END IF
         END IF
     WEND

     ' if operation not canceled return file name and file number
     IF pushButton = 1 THEN
         FileName$ = EditFieldInquire$(1)
         GetSaveFile% = fileNum%
     ELSE
         GetSaveFile% = 0
     END IF

     WindowClose 1

     EXIT FUNCTION

 ' local error handler
 GetSaveError:
       finished = FALSE                              ' don't exit until valid
       CLOSE fileNum%

       ShowError ERR                                 ' display errors
 RESUME NEXT

 END FUNCTION

 '
 ' Sub Name: LoadChart
 '
 ' Description: Loads chart data and settings from the given file.
 '
 ' Arguments: fileNum%  - file number
 '
 SUB LoadChart (fileNum%)
 SHARED Cat$(), catLen AS INTEGER
 SHARED setLen() AS INTEGER, setName$(), setVal!()
 SHARED screenMode AS INTEGER, numModes AS INTEGER, mode$()

 ON LOCAL ERROR GOTO LoadError                       ' handle file loading err

     ' Read file until EOF is reached:
     DO UNTIL EOF(fileNum%)
         ' get data type from file (C=category, V=value, T=title, S=setting):
         INPUT #fileNum%, type$

         ' category data
         IF UCASE$(type$) = "C" THEN
             INPUT #fileNum%, catLen
             FOR i% = 1 TO catLen
                 INPUT #fileNum%, Cat$(i%)
             NEXT i%

         ' value data
         ELSEIF UCASE$(type$) = "V" THEN
             ' too many sets in file
             IF setNum >= cMaxSets THEN
                 PrintError "Too many data sets in file. Extra sets lost."
                 EXIT DO
             END IF

             setNum = setNum + 1
             INPUT #fileNum%, setName$(setNum)         ' get set name
             INPUT #fileNum%, setLen(setNum)           ' get set length
             FOR i% = 1 TO setLen(setNum)
                 INPUT #fileNum%, setVal!(i%, setNum)  ' get set values
             NEXT i%

         ' title data
         ELSEIF UCASE$(type$) = "T" THEN
             INPUT #fileNum%, CEnv.MainTitle.title
             INPUT #fileNum%, CEnv.SubTitle.title
             INPUT #fileNum%, CEnv.XAxis.AxisTitle.title
             INPUT #fileNum%, CEnv.YAxis.AxisTitle.title

         ' chart settings
         ELSEIF UCASE$(type$) = "S" THEN
             INPUT #fileNum%, screenMode
             ' test for valid screen mode
             valid = FALSE
             FOR i = 1 TO numModes
                 IF screenMode = VAL(mode$(i)) THEN valid = TRUE
             NEXT i
             IF NOT valid THEN
                 IF mode$(1) = "13" THEN
                     screenMode = VAL(mode$(2))
                 ELSE
                     screenMode = VAL(mode$(1))
                 END IF
             END IF

             INPUT #fileNum%, CEnv.ChartType, CEnv.ChartStyle, CEnv.DataFont

             INPUT #fileNum%, CEnv.ChartWindow.X1, CEnv.ChartWindow.Y1, CEnv.C
             INPUT #fileNum%, CEnv.ChartWindow.Background, CEnv.ChartWindow.bo
             INPUT #fileNum%, CEnv.DataWindow.X1, CEnv.DataWindow.Y1, CEnv.Dat
             INPUT #fileNum%, CEnv.DataWindow.Background, CEnv.DataWindow.bord

             INPUT #fileNum%, CEnv.MainTitle.TitleFont, CEnv.MainTitle.TitleCo
             INPUT #fileNum%, CEnv.SubTitle.TitleFont, CEnv.SubTitle.TitleColo

             INPUT #fileNum%, CEnv.XAxis.Grid, CEnv.XAxis.GridStyle, CEnv.XAxi
             INPUT #fileNum%, CEnv.XAxis.AxisTitle.TitleFont, CEnv.XAxis.AxisT
             INPUT #fileNum%, CEnv.XAxis.RangeType, CEnv.XAxis.LogBase, CEnv.X
             INPUT #fileNum%, CEnv.XAxis.ScaleMax, CEnv.XAxis.ScaleFactor, CEn
             INPUT #fileNum%, CEnv.XAxis.ScaleTitle.title
             INPUT #fileNum%, CEnv.XAxis.ScaleTitle.TitleFont, CEnv.XAxis.Scal

             INPUT #fileNum%, CEnv.YAxis.Grid, CEnv.YAxis.GridStyle, CEnv.YAxi
             INPUT #fileNum%, CEnv.YAxis.AxisTitle.TitleFont, CEnv.YAxis.AxisT
             INPUT #fileNum%, CEnv.YAxis.RangeType, CEnv.YAxis.LogBase, CEnv.Y
             INPUT #fileNum%, CEnv.YAxis.ScaleMax, CEnv.YAxis.ScaleFactor, CEn
             INPUT #fileNum%, CEnv.YAxis.ScaleTitle.title
             INPUT #fileNum%, CEnv.YAxis.ScaleTitle.TitleFont, CEnv.YAxis.Scal

             INPUT #fileNum%, CEnv.Legend.Legend, CEnv.Legend.Place, CEnv.Lege
             INPUT #fileNum%, CEnv.Legend.LegendWindow.X1, CEnv.Legend.LegendW
             INPUT #fileNum%, CEnv.Legend.LegendWindow.Background, CEnv.Legend
         ELSE
             GOSUB LoadError
         END IF
     LOOP

     ' close the file
     CLOSE fileNum%

     ' clear any font pointers that don't map to current fonts
     ClearFonts

     ' initialize color list depending on newly loaded screen mode
     InitColors

     EXIT SUB

 ' handle any file format errors
 LoadError:

     IF ERR THEN
         ShowError ERR
     ELSE
         PrintError "Invalid file format.  Can't continue loading."
     END IF

     CLOSE fileNum%                              ' close and exit
     EXIT SUB

 RESUME NEXT

 END SUB

 '
 ' Sub Name: OpenChart
 '
 ' Description: Handles both the "New" and "Open" operations from the
 '              "File" menu title.
 '
 ' Arguments: newFlag - flag for determining which operation (New or Open)
 '                      to perform.
 '
 SUB OpenChart (newFlag)
 SHARED saveFile$

     ' allow user to save current chart if necessary
     IF chartChanged THEN
         a$ = "|"
         a$ = a$ + "Current chart has not been saved.  Save now?"

         status = Alert(4, a$, 8, 15, 12, 65, "Yes", "No", "Cancel")

         ' save current chart
         IF status = OK THEN
             status = SaveChart(saveFile$, FALSE)
         END IF
     ELSE
         status = OK
     END IF

     IF status <> CANCEL THEN
         ' New option chosen so clear existing data, leave chart settings alon
         IF newFlag = TRUE THEN
             MenuItemToggle GALLERYTITLE, CEnv.ChartType
             IF CEnv.ChartType = cPie THEN
                 MenuSetState CHARTTITLE, 4, 1
                 MenuSetState CHARTTITLE, 5, 1
                 MenuSetState TITLETITLE, 3, 1
                 MenuSetState TITLETITLE, 4, 1
             END IF
             InitChart
             saveFile$ = ""
         ' Open operation chosen so get file and load data
         ELSE
             fileNum% = GetLoadFile(saveFile$)
             ' if no errors opening file and operation not canceled then load
             IF fileNum <> 0 THEN
                 ' reset menu bar to nothing selected
                 MenuItemToggle GALLERYTITLE, CEnv.ChartType
                 IF CEnv.ChartType = cPie THEN
                     MenuSetState CHARTTITLE, 4, 1
                     MenuSetState CHARTTITLE, 5, 1
                     MenuSetState TITLETITLE, 3, 1
                     MenuSetState TITLETITLE, 4, 1
                 END IF

                 ClearData                       'clear current data

                 setNum = 0
                 LoadChart fileNum%             ' load the data

                 ' set menu bar according to new chart settings
                 MenuItemToggle GALLERYTITLE, CEnv.ChartType
                 IF CEnv.ChartType = cPie THEN
                     MenuSetState CHARTTITLE, 4, 0
                     MenuSetState CHARTTITLE, 5, 0
                     MenuSetState TITLETITLE, 3, 0
                     MenuSetState TITLETITLE, 4, 0
                 END IF

                 ' new chart not changed
                 chartChanged = FALSE

                 ' chart data exists so allow user to view chart
                 IF setNum > 0 THEN
                     MenuSetState VIEWTITLE, 2, 1
                 END IF
             END IF
         END IF
     END IF

 END SUB

 '
 ' Sub Name: PrintError
 '
 ' Description: Prints error messages on the screen in an Alert box.
 '
 ' Arguments: text$ - error message
 '
 SUB PrintError (text$)

     textLen = LEN(text$) + 2
     lefCol = ((80 - textLen) / 2) - 1
     a$ = "| " + text$
     junk = Alert(4, a$, 8, lefCol, 12, textLen + lefCol, "", "", "")

 END SUB

 '
 ' Func Name: SaveChart
 '
 ' Description: Performs both the "Save" and "Save AS" operations from
 '              the "File" menu title.  If "Save As" was chosen or if
 '              "Save" was chosen and no save file has been previously
 '              specified, it prompts the user for a new file in
 '              which to save the current chart.  Also returns the status of
 '              save operation for use in other routines
 '
 ' Arguments: fileName$ - name of previously specified save file (may be nil)
 '            saveAsFlag - flag for invoking the "Save As" operation.
 '
 FUNCTION SaveChart% (FileName$, saveAsFlag)
 SHARED Cat$(), catLen AS INTEGER
 SHARED setLen() AS INTEGER, setName$(), setVal!()
 SHARED screenMode AS INTEGER

 ON LOCAL ERROR GOTO SaveError                   ' handle file errors

     ' get new file name if necessary
     IF FileName$ = "" OR saveAsFlag THEN
         fileNum% = GetSaveFile(FileName$)
     ' otherwise just open the file
     ELSE
         fileNum% = FREEFILE
         OPEN FileName$ FOR OUTPUT AS fileNum%
     END IF

     ' quit save if cancel chosen above or error occurred during open.
     IF fileNum% = 0 THEN
         SaveChart% = CANCEL                     ' return status
         EXIT FUNCTION
     END IF

     ' save category data
     IF catLen > 0 THEN
         PRINT #fileNum%, "C"
         PRINT #fileNum%, catLen

         FOR i% = 1 TO catLen
             PRINT #fileNum%, Cat$(i%)
         NEXT i%
     END IF

     ' save value data
     IF setNum > 0 THEN
         FOR j% = 1 TO setNum
             PRINT #fileNum%, "V"
             PRINT #fileNum%, setName$(j%)
             PRINT #fileNum%, setLen(j%)

             FOR i% = 1 TO setLen(j%)
                 PRINT #fileNum%, setVal!(i%, j%)
             NEXT i%
         NEXT j%
     END IF

     ' save titles
     PRINT #fileNum%, "T"
     PRINT #fileNum%, CEnv.MainTitle.title
     PRINT #fileNum%, CEnv.SubTitle.title
     PRINT #fileNum%, CEnv.XAxis.AxisTitle.title
     PRINT #fileNum%, CEnv.YAxis.AxisTitle.title

     'save chart settings
     PRINT #fileNum%, "S"
     PRINT #fileNum%, screenMode

     PRINT #fileNum%, CEnv.ChartType, CEnv.ChartStyle, CEnv.DataFont

     PRINT #fileNum%, CEnv.ChartWindow.X1, CEnv.ChartWindow.Y1, CEnv.ChartWind
     PRINT #fileNum%, CEnv.ChartWindow.Background, CEnv.ChartWindow.border, CE
     PRINT #fileNum%, CEnv.DataWindow.X1, CEnv.DataWindow.Y1, CEnv.DataWindow.
     PRINT #fileNum%, CEnv.DataWindow.Background, CEnv.DataWindow.border, CEnv

     PRINT #fileNum%, CEnv.MainTitle.TitleFont, CEnv.MainTitle.TitleColor, CEn
     PRINT #fileNum%, CEnv.SubTitle.TitleFont, CEnv.SubTitle.TitleColor, CEnv.

     PRINT #fileNum%, CEnv.XAxis.Grid, CEnv.XAxis.GridStyle, CEnv.XAxis.AxisCo
     PRINT #fileNum%, CEnv.XAxis.AxisTitle.TitleFont, CEnv.XAxis.AxisTitle.Tit
     PRINT #fileNum%, CEnv.XAxis.RangeType, CEnv.XAxis.LogBase, CEnv.XAxis.Aut
     PRINT #fileNum%, CEnv.XAxis.ScaleMax, CEnv.XAxis.ScaleFactor, CEnv.XAxis.
     PRINT #fileNum%, CEnv.XAxis.ScaleTitle.title
     PRINT #fileNum%, CEnv.XAxis.ScaleTitle.TitleFont, CEnv.XAxis.ScaleTitle.T

     PRINT #fileNum%, CEnv.YAxis.Grid, CEnv.YAxis.GridStyle, CEnv.YAxis.AxisCo
     PRINT #fileNum%, CEnv.YAxis.AxisTitle.TitleFont, CEnv.YAxis.AxisTitle.Tit
     PRINT #fileNum%, CEnv.YAxis.RangeType, CEnv.YAxis.LogBase, CEnv.YAxis.Aut
     PRINT #fileNum%, CEnv.YAxis.ScaleMax, CEnv.YAxis.ScaleFactor, CEnv.YAxis.
     PRINT #fileNum%, CEnv.YAxis.ScaleTitle.title
     PRINT #fileNum%, CEnv.YAxis.ScaleTitle.TitleFont, CEnv.YAxis.ScaleTitle.T

     PRINT #fileNum%, CEnv.Legend.Legend, CEnv.Legend.Place, CEnv.Legend.TextC
     PRINT #fileNum%, CEnv.Legend.LegendWindow.X1, CEnv.Legend.LegendWindow.Y1
     PRINT #fileNum%, CEnv.Legend.LegendWindow.Background, CEnv.Legend.LegendW

     CLOSE fileNum%

     SaveChart% = OK                             ' return status

     chartChanged = FALSE                        ' reset global change flag

     EXIT FUNCTION

 ' local error handler
 SaveError:
       SaveChart% = CANCEL                       ' return cancel status
       CLOSE fileNum%

       ShowError ERR                             ' display error message

       EXIT FUNCTION                             ' exit on error
 RESUME NEXT

 END FUNCTION

 '
 ' Sub Name: ShowError
 '
 ' Description: Displays an appropriate error message for the given error
 '
 ' Arguments: errorNum - error number
 '
 SUB ShowError (errorNum)
       SELECT CASE errorNum
         CASE 6:                                 ' overflow
             PrintError "Overflow occurred."
         CASE 14:                                ' out of space
             PrintError "Out of string space.  Please restart."
         CASE 53:                                ' file not found
             PrintError "File not found."
         CASE 62:                                ' input past end of file
             PrintError "Invalid file format. Can't continue loading."
         CASE 64:                                ' bad file name
             PrintError "Invalid file name."
         CASE 68:                                ' device unavailable
             PrintError "Selected device unavailable."
         CASE 71:                                ' disk not ready
             PrintError "Disk not ready."
         CASE 75:                                ' path access error
             PrintError "Invalid path."
         CASE 76:                                ' path not found
             PrintError "Path not found."
         CASE ELSE                               ' catch all
             PrintError "BASIC error #" + LTRIM$(STR$(ERR)) + " occurred."
      END SELECT


 END SUB

 '
 ' Sub Name: ViewData
 '
 ' Description: Displays the current chart data and allows the user to
 '              modify, delete or add to that data.
 '
 ' Arguments: none
 '
 SUB ViewData
 SHARED setVal!(), setLen()  AS INTEGER, setName$()
 SHARED Cat$(), catLen AS INTEGER
 SHARED GloEdit() AS EditFieldType

     ' temporary data storage that allows user to cancel all changes and
     ' restore original data
     DIM tsetVal$(1 TO 15, 1 TO 15), tCat$(1 TO 15), tsetName$(1 TO 15)
     DIM tsetNum AS INTEGER
     DIM tsetLen(1 TO 15) AS INTEGER
     DIM tcatLen  AS INTEGER

     ON LOCAL ERROR GOTO ViewDatError

     ' fill out temp data
     FOR i = 1 TO cMaxSets
         tsetName$(i) = setName$(i)
         tCat$(i) = Cat$(i)
         tsetLen(i) = setLen(i)
         FOR j = 1 TO tsetLen(i)
             tsetVal$(j, i) = LTRIM$(STR$(setVal!(j, i)))
         NEXT j
         FOR j = tsetLen(i) + 1 TO cMaxValues
             tsetVal$(j, i) = ""
         NEXT j
     NEXT i
     tsetNum = setNum
     tcatLen = catLen

     ' set up window
     winRow = 4
     winCol = 8
     WindowOpen 1, winRow, winCol, 23, 74, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE
     WindowLocate 1, 2
     WindowPrint 2, "Series Name:"
     WindowBox 2, 2, 18, 24
     WindowLocate 1, 26
     WindowPrint 2, "Categories:"
     WindowBox 2, 26, 18, 48
     WindowLocate 1, 50
     WindowPrint 2, "Values:"
     WindowBox 2, 50, 18, 66
     WindowLine 19

     ' display chart data
     FOR i = 1 TO 15
         IF i < 10 THEN
             a$ = " "
         ELSE
             a$ = ""
         END IF
         a$ = a$ + LTRIM$(STR$(i)) + ". "
         WindowLocate i + 2, 3
         WindowPrint 2, a$ + tsetName$(i)
         WindowLocate i + 2, 27
         WindowPrint 2, a$ + tCat$(i)
         WindowLocate i + 2, 51
         WindowPrint 2, a$ + MID$(tsetVal$(i, 1), 1, 10)
     NEXT i
     ' highlight first set name
     EditFieldOpen 1, tsetName$(1), 3, 7, 7, 0, 17, 16

     IF tsetNum < cMaxSets THEN tsetNum = tsetNum + 1
     IF tcatLen < cMaxValues THEN tcatLen = tcatLen + 1
     IF tsetLen(1) < cMaxValues THEN tsetLen(1) = tsetLen(1) + 1

     ' area buttons
     ButtonOpen 1, 1, "", 3, 3, 17, 23, 4
     ButtonOpen 2, 1, "", 3, 27, 17, 47, 4
     ButtonOpen 3, 1, "", 3, 51, 17, 65, 4

     ' command buttons
     ButtonOpen 4, 1, "OK", 20, 15, 0, 0, 1
     ButtonOpen 5, 1, "Cancel", 20, 45, 0, 0, 1

     ' start with cursor in first set name edit field
     currButton = 1
     prevButton = 1
     currRow = 1
     currEditField = 1
     currCat = 1
     currVal = 1
     currSet = 1

     IF CEnv.ChartType = cPie THEN
         a$ = " Pie chart information||"
         a$ = a$ + " Only data values from the first series are plotted in pie
         a$ = a$ + " Data values from the second series are used in determinin
         a$ = a$ + " or not pie pieces are exploded.  Non-zero values in this
         a$ = a$ + " will cause corresponding pie pieces to be exploded.  All
         a$ = a$ + "  series will be ignored.

         junk = Alert(4, a$, 8, 7, 17, 75, "", "", "")
     END IF

     ' window control loop
     finished = FALSE
     WHILE NOT finished
         WindowDo currButton, currEditField

         SELECT CASE Dialog(0)
             CASE 1                                      ' button pressed
                 currButton = Dialog(1)
                 SELECT CASE currButton
                     CASE 1, 2, 3
                         currRow = Dialog(17)
                     CASE 4, 5
                         finished = TRUE
                 END SELECT
                 GOSUB UpdateEdit
             CASE 2                                      ' Edit Field
                 currEditField = Dialog(2)
             CASE 6, 11                                  ' enter, down arrow
                 IF currButton > 3 AND Dialog(0) = 6 THEN
                     finished = TRUE
                 ELSE
                     currRow = currRow + 1
                     GOSUB UpdateEdit
                 END IF
             CASE 7                                      'tab
                 SELECT CASE currButton
                     CASE 1:
                         currButton = 2
                         currRow = currCat
                         GOSUB UpdateEdit
                     CASE 2:
                         currButton = 3
                         currRow = currVal
                         GOSUB UpdateEdit
                     CASE 3:
                         currButton = 4
                         ButtonToggle 4
                         GOSUB UpdateEdit
                     CASE 4:
                         currButton = 5
                         ButtonToggle 4
                         ButtonToggle 5
                     CASE 5:
                         currButton = 1
                         currRow = currSet
                         ButtonToggle 5
                         GOSUB UpdateEdit
                 END SELECT
             CASE 8                                      'back tab
                 SELECT CASE currButton
                     CASE 1:
                         currButton = 5
                         ButtonToggle 5
                         GOSUB UpdateEdit
                     CASE 2:
                         currButton = 1
                         currRow = currSet
                         GOSUB UpdateEdit
                     CASE 3:
                         currButton = 2
                         currRow = currCat
                         GOSUB UpdateEdit
                     CASE 4:
                         currButton = 3
                         currRow = currVal
                         ButtonToggle 4
                         GOSUB UpdateEdit
                     CASE 5:
                         currButton = 4
                         ButtonToggle 5
                         ButtonToggle 4
                 END SELECT
             CASE 9                                      'escape
                 currButton = 5
                 finished = TRUE
             CASE 10:                                    'up arrow
                 IF currButton < 4 THEN
                     currRow = currRow - 1
                     GOSUB UpdateEdit
                 END IF
             CASE 14                                     'space
                 IF currButton > 3 THEN finished = TRUE
         END SELECT

         ' give delete warning before exit
         IF finished = TRUE AND currButton = 4 THEN
             temp = FALSE
             FOR i = 1 TO tsetNum
                 IF tsetName$(i) = "" AND tsetLen(i) > 0 AND NOT (tsetLen(i) =
             NEXT i
             IF temp = TRUE THEN
                 a$ = "|"
                 a$ = a$ + "Series without names will be deleted upon exit."
                 reply = Alert(4, a$, 8, 10, 12, 70, "OK", "Cancel", "")
                 IF reply <> 1 THEN finished = FALSE
             END IF
         END IF
     WEND

     ' finished so save new data
     IF currButton = 4 THEN
         ClearData                                       ' clear existing data

         ' copy temporary values to permanent locations
         indx = 0
         FOR i = 1 TO tsetNum
             IF tsetName$(i) <> "" THEN
                 indx = indx + 1
                 setName$(indx) = tsetName$(i)              ' store set names
                 indx2 = 0
                 FOR j = 1 TO tsetLen(i)
                     IF tsetVal$(j, i) <> "" THEN
                         indx2 = indx2 + 1
                         setVal!(indx2, i) = VAL(tsetVal$(j, i))   ' store set
                     END IF
                 NEXT j
                 setLen(indx) = indx2                     ' get set lengths
             END IF
         NEXT i
         setNum = indx

         ' clear leftover names and set lengths
         FOR i = setNum + 1 TO cMaxSets
             setName$(i) = ""
             setLen(i) = 0
         NEXT i

         ' store category names
         FOR i = 1 TO tcatLen
             Cat$(i) = tCat$(i)
         NEXT i
         catLen = tcatLen

         FOR i = tcatLen TO 1 STEP -1
             IF Cat$(i) = "" THEN
                 catLen = catLen - 1
                 IF catLen <= 0 THEN EXIT FOR
             ELSE
                 EXIT FOR
             END IF
         NEXT i

         ' clear leftover category names
         FOR i = catLen + 1 TO cMaxValues
             Cat$(i) = ""
         NEXT i

         ' update active menu titles based on current data
         IF setNum > 0 THEN
             MenuSetState VIEWTITLE, 2, 1
             chartChanged = TRUE
         ELSE
             MenuSetState VIEWTITLE, 2, 0
         END IF
     END IF
     WindowClose 1


     EXIT SUB

 ViewDatError:
     PrintError "BASIC error #" + LTRIM$(STR$(ERR)) + " occurred."
 RESUME NEXT

 ' redraws the value edit column so it displays the current set's values
 ResetVal:
     ' display new values
     FOR i = 1 TO cMaxValues
         WindowLocate i + 2, 55
         WindowPrint 2, tsetVal$(i, currSet) + STRING$(10 - LEN(tsetVal$(i, cu
     NEXT i

     IF tsetLen(currSet) = 0 THEN
         tsetLen(currSet) = tsetLen(currSet) + 1
     ELSEIF tsetLen(currSet) < cMaxValues AND tsetVal$(tsetLen(currSet), currS
         tsetLen(currSet) = tsetLen(currSet) + 1
     END IF

     currVal = 31

 RETURN

 UpdateEdit:
     IF prevButton < 4 THEN GOSUB ClosePrevEdit

     SELECT CASE currButton
         CASE 1:
             IF currRow <= 0 THEN
                 currRow = tsetNum
             ELSEIF currRow > 15 THEN
                 currRow = 1
             ELSEIF currRow = tsetNum + 1 AND tsetName$(tsetNum) <> "" THEN
                 tsetNum = tsetNum + 1
             ELSEIF currRow > tsetNum THEN
                 currRow = 1
             END IF
             WindowColor 0, 7
             WindowLocate currSet + 2, 7
             WindowPrint 2, tsetName$(currSet) + STRING$(17 - LEN(tsetName$(cu

             FG = 7
             BG = 0
             vislen = 17
             totlen = 16
             currSet = currRow
             currCol = 7
             temp$ = tsetName$(currSet)
             IF prevButton = 1 THEN GOSUB ResetVal
         CASE 2:
             IF currRow <= 0 THEN
                 currRow = tcatLen
             ELSEIF currRow > 15 THEN
                 currRow = 1
             ELSEIF currRow > tcatLen THEN
                 tcatLen = currRow
             END IF
             FG = 0
             BG = 7
             vislen = 17
             totlen = 16
             currCat = currRow
             currCol = 31
             temp$ = tCat$(currCat)
         CASE 3:
             IF currRow <= 0 THEN
                 currRow = tsetLen(currSet)
             ELSEIF currRow > 15 THEN
                 currRow = 1
             ELSEIF currRow = tsetLen(currSet) + 1 AND tsetVal$(tsetLen(currSe
                 tsetLen(currSet) = tsetLen(currSet) + 1
             ELSEIF currRow > tsetLen(currSet) THEN
                 currRow = 1
             END IF
             FG = 0
             BG = 7
             vislen = 11
             totlen = 20
             currVal = currRow
             currCol = 55
             temp$ = tsetVal$(currVal, currSet)
         CASE ELSE
             prevButton = currButton
             RETURN
     END SELECT

     EditFieldOpen 1, temp$, currRow + 2, currCol, FG, BG, vislen, totlen
     currEditField = 1
     prevButton = currButton
 RETURN

 ClosePrevEdit:
     temp$ = RTRIM$(EditFieldInquire$(1))
     EditFieldClose 1
     currEditField = 0
     IF prevButton = 1 THEN
         WindowColor 7, 0
     ELSE
         WindowColor 0, 7
     END IF

     SELECT CASE prevButton
         CASE 1:
             tsetName$(currSet) = temp$
             temp$ = temp$ + STRING$(17 - LEN(temp$), " ")
             editRow = currSet + 2
             editCol = 7
         CASE 2:
             tCat$(currCat) = temp$
             editRow = currCat + 2
             editCol = 31
         CASE 3:
             tsetVal$(currVal, currSet) = temp$
             tval# = VAL(temp$)
             IF tval# = 0 AND temp$ <> "0" AND LEN(RTRIM$(temp$)) <> 0 THEN
                 PrintError "Warning: Non-numeric values will default to zero
             END IF
             temp$ = MID$(temp$, 1, 10)
             editRow = currVal + 2
             editCol = 55
     END SELECT

     WindowLocate editRow, editCol
     WindowPrint 2, temp$
     WindowColor 0, 7
 RETURN

 END SUB



 COLORS.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\COLORS.BAS

 SCREEN 1

 Esc$ = CHR$(27)
 ' Draw three boxes and paint the interior
 ' of each box with a different color:
 FOR ColorVal = 1 TO 3
    LINE (X, Y) -STEP(60, 50), ColorVal, BF
    X = X + 61
    Y = Y + 51
 NEXT ColorVal

 LOCATE 21, 1
 PRINT "Press ESC to end."
 PRINT "Press any other key to continue."

 ' Restrict additional printed output to the 23rd line:
 VIEW PRINT 23 TO 23
 DO
    PaletteVal = 1
    DO

       ' PaletteVal is either 1 or 0:
       PaletteVal = 1 - PaletteVal

       ' Set the background color and choose the palette:
       COLOR BackGroundVal, PaletteVal
       PRINT "Background ="; BackGroundVal;
       PRINT "Palette ="; PaletteVal;

       Pause$ = INPUT$(1)        ' Wait for a keystroke.
       PRINT
    ' Exit the loop if both palettes have been shown,
    ' or if the user pressed the ESC key:
    LOOP UNTIL PaletteVal = 1 OR Pause$ = Esc$

    BackGroundVal = BackGroundVal + 1

 ' Exit this loop if all 16 background colors have
 ' been shown, or if the user pressed the ESC key:
 LOOP UNTIL BackGroundVal > 15 OR Pause$ = Esc$

 SCREEN 0                     ' Restore text mode and
 WIDTH 80                     ' 80-column screen width.



 CRLF.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\CRLF.BAS

 DEFINT A-Z             ' Default variable type is integer.

 ' The Backup$ FUNCTION makes a backup file with
 ' the same base as FileName$ plus a .BAK extension:
 DECLARE FUNCTION Backup$ (FileName$)

 ' Initialize symbolic constants and variables:
 CONST FALSE = 0, TRUE = NOT FALSE

 CarReturn$ = CHR$(13)
 LineFeed$ = CHR$(10)

 DO
    CLS

    ' Input the name of the file to change:
    INPUT "Which file do you want to convert"; OutFile$

    InFile$ = Backup$(OutFile$)  ' Get backup file's name.

    ON ERROR GOTO ErrorHandler   ' Turn on error trapping.

    NAME OutFile$ AS InFile$     ' Rename input file as
                                 ' backup file.

    ON ERROR GOTO 0              ' Turn off error trapping.

    ' Open backup file for input and old file for output:
    OPEN InFile$ FOR INPUT AS #1
    OPEN OutFile$ FOR OUTPUT AS #2

    ' The PrevCarReturn variable is a flag set to TRUE
    ' whenever the program reads a carriage-return character:
    PrevCarReturn = FALSE
 ' Read from input file until reaching end of file:
    DO UNTIL EOF(1)

       ' This is not end of file, so read a character:
       FileChar$ = INPUT$(1, #1)

       SELECT CASE FileChar$

          CASE CarReturn$        ' The character is a CR.

             ' If the previous character was also a
             ' CR, put a LF before the character:
             IF PrevCarReturn THEN
                 FileChar$ = LineFeed$ + FileChar$
             END IF

             ' In any case, set the PrevCarReturn
             ' variable to TRUE:
             PrevCarReturn = TRUE

          CASE LineFeed$         ' The character is a LF.

             ' If the previous character was not a
             ' CR, put a CR before the character:
             IF NOT PrevCarReturn THEN
                 FileChar$ = CarReturn$ + FileChar$
             END IF

             ' Set the PrevCarReturn variable to FALSE:
             PrevCarReturn = FALSE

          CASE ELSE              ' Neither a CR nor a LF.

             ' If the previous character was a CR,
             ' set the PrevCarReturn variable to FALSE
             ' and put a LF before the current character:
             IF PrevCarReturn THEN
                PrevCarReturn = FALSE
                FileChar$ = LineFeed$ + FileChar$
             END IF

       END SELECT

       ' Write the character(s) to the new file:
       PRINT #2, FileChar$;
    LOOP

    ' Write a LF if the last character in the file was a CR:
    IF PrevCarReturn THEN PRINT #2, LineFeed$;
 CLOSE                        ' Close both files.
    PRINT "Another file (Y/N)?"  ' Prompt to continue.

    ' Change the input to uppercase (capital letter):
    More$ = UCASE$(INPUT$(1))

 ' Continue the program if the user entered a "Y" or a "Y":
 LOOP WHILE More$ = "Y"
 END

 ErrorHandler:           ' Error-handling routine
    CONST NOFILE = 53, FILEEXISTS = 58

    ' The ERR function returns the error code for last error:
    SELECT CASE ERR
       CASE NOFILE       ' Program couldn't find file
                         ' with input name.

          PRINT "No such file in current directory."
          INPUT "Enter new name: ", OutFile$
          InFile$ = Backup$(OutFile$)
          RESUME
       CASE FILEEXISTS   ' There is already a file named
                         ' <filename>.BAK in this directory:
                         ' remove it, then continue.
          KILL InFile$
          RESUME
       CASE ELSE         ' An unanticipated error occurred:
                         ' stop the program.
          ON ERROR GOTO 0
    END SELECT

 ' ======================== BACKUP$ =========================
 '   This procedure returns a file name that consists of the
 '   base name of the input file (everything before the ".")
 '   plus the extension ".BAK"
 ' ==========================================================

 FUNCTION Backup$ (FileName$) STATIC

    ' Look for a period:
    Extension = INSTR(FileName$, ".")

    ' If there is a period, add .BAK to the base:
    IF Extension > 0 THEN
       Backup$ = LEFT$(FileName$, Extension - 1) + ".BAK"
    ' Otherwise, add .BAK to the whole name:
    ELSE
       Backup$ = FileName$ + ".BAK"
    END IF
 END FUNCTION



 CUBE.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\CUBE.BAS

 ' Define the macro string used to draw the cube
 ' and paint its sides:
 One$ =        "BR30 BU25 C1 R54 U45 L54 D45 BE20 P1,1        G20 C2 G20"
 Two$ =        "R54 E20 L54 BD5 P2,2 U5 C4 G20 U45 E20 D45 BL5 P4,4"
 Plot$ = One$ + Two$

 APage% = 1        ' Initialize values for the active and visual
 VPage% = 0        ' pages as well as the angle of rotation.
 Angle% = 0

 DO
    SCREEN 7, , APage%, VPage% ' Draw to the active page
                                  ' while showing the visual page.

    CLS 1                      ' Clear the active page.

    ' Rotate the        cube "Angle%" degrees:
    DRAW        "TA" + STR$(Angle%) + Plot$

    ' Angle% is some multiple of        15 degrees:
    Angle% = (Angle% + 15) MOD 360

    ' Drawing is complete, so make the cube visible in its
    ' new position by switching the active and visual pages:
    SWAP        APage%,        VPage%

 LOOP WHILE INKEY$ = ""              ' A keystroke ends the program.

 END



 EDPAT.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\EDPAT.BAS

 DECLARE SUB DrawPattern ()
 DECLARE SUB EditPattern ()
 DECLARE SUB Initialize ()
 DECLARE SUB ShowPattern (OK$)

 DIM Bit%(0 TO 7), Pattern$, PatternSize%
 DO
    Initialize
    EditPattern
    ShowPattern OK$
 LOOP WHILE OK$ = "Y"

 END
 ' ======================= DRAWPATTERN ====================
 '  Draws a patterned rectangle on the right side of screen
 ' ========================================================

 ' ======================= EDITPATTERN =====================
 '                  Edits a tile-byte pattern
 ' =========================================================


 ' ======================= INITIALIZE ======================
 '             Sets up starting pattern and screen
 ' =========================================================

 ' ======================== SHOWPATTERN ====================
 '   Prints the CHR$ values used by PAINT to make pattern
 ' =========================================================

 SUB DrawPattern STATIC
 SHARED Pattern$
    VIEW (320, 24)-(622, 160), 0, 1  ' Set view to rectangle.
    PAINT (1, 1), Pattern$       ' Use PAINT to fill it.
    VIEW                 ' Set view to full screen.

 END SUB

 SUB EditPattern STATIC
 SHARED Pattern$, Bit%(), PatternSize%

    ByteNum% = 1     ' Starting position.
    BitNum% = 7
    Null$ = CHR$(0)  ' CHR$(0) is the first byte of the
                                         ' two-byte string returned when a
                                         ' direction key such as UP or DOWN is
                                         ' pressed.
    DO

           ' Calculate starting location on screen of this bit:
           X% = ((7 - BitNum%) * 16) + 80
           Y% = (ByteNum% + 2) * 8

           ' Wait for a key press (flash cursor each 3/10 second):
           State% = 0
           RefTime = 0
           DO

          ' Check timer and switch cursor state if 3/10 second:
          IF ABS(TIMER - RefTime) > .3 THEN
                 RefTime = TIMER
                 State% = 1 - State%

                 ' Turn the  border of bit on and off:
                 LINE (X% - 1, Y% - 1)-STEP(15, 8), State%, B
          END IF

          Check$ = INKEY$    ' Check for keystroke.

           LOOP WHILE Check$ = ""    ' Loop until a key is pressed.

           ' Erase cursor:
           LINE (X% - 1, Y% - 1)-STEP(15, 8), 0, B

           SELECT CASE Check$    ' Respond to keystroke.

           CASE CHR$(27)     ' ESC key pressed:
                  EXIT SUB       ' exit this subprogram.
           CASE CHR$(32)     ' SPACEBAR pressed:
                                                 ' reset state of bit.

                  ' Invert bit in pattern string:
                  CurrentByte% = ASC(MID$(Pattern$, ByteNum%, 1))
                  CurrentByte% = CurrentByte% XOR Bit%(BitNum%)
                  MID$(Pattern$, ByteNum%) = CHR$(CurrentByte%)

                  ' Redraw bit on screen:
                  IF (CurrentByte% AND Bit%(BitNum%)) <> 0 THEN
                          CurrentColor% = 1
                  ELSE
                          CurrentColor% = 0
                  END IF
                  LINE (X% + 1, Y% + 1)-STEP(11, 4), CurrentColor%, BF

           CASE CHR$(13)      ' ENTER key pressed: draw
                  DrawPattern         ' pattern in box on right.

           CASE Null$ + CHR$(75)  ' LEFT key: move cursor left.

                  BitNum% = BitNum% + 1
                  IF BitNum% > 7 THEN BitNum% = 0

           CASE Null$ + CHR$(77)  ' RIGHT key: move cursor right.

                  BitNum% = BitNum% - 1
                  IF BitNum% < 0 THEN BitNum% = 7

           CASE Null$ + CHR$(72)  ' UP key: move cursor up.

                  ByteNum% = ByteNum% - 1
                  IF ByteNum% < 1 THEN ByteNum% = PatternSize%

           CASE Null$ + CHR$(80)  ' DOWN key: move cursor down.

                  ByteNum% = ByteNum% + 1
                  IF ByteNum% > PatternSize% THEN ByteNum% = 1
           END SELECT
    LOOP
 END SUB

 SUB Initialize STATIC
 SHARED Pattern$, Bit%(), PatternSize%

    ' Set up an array holding bits in positions 0 to 7:
    FOR I% = 0 TO 7
           Bit%(I%) = 2 ^ I%
    NEXT I%

    CLS

    ' Input the pattern size (in number of bytes):
    LOCATE 5, 5
    PRINT "Enter pattern size (1-16 rows):";
    DO
           LOCATE 5, 38
           PRINT "         ";
           LOCATE 5, 38
           INPUT "", PatternSize%
    LOOP WHILE PatternSize% < 1 OR PatternSize% > 16

    ' Set initial pattern to all bits set:
    Pattern$ = STRING$(PatternSize%, 255)

    SCREEN 2     ' 640 x 200 monochrome graphics mode

    ' Draw dividing lines:
    LINE (0, 10)-(635, 10), 1
    LINE (300, 0)-(300, 199)
    LINE (302, 0)-(302, 199)

    ' Print titles:
    LOCATE 1, 13: PRINT "Pattern Bytes"
    LOCATE 1, 53: PRINT "Pattern View"


 ' Draw editing screen for pattern:
    FOR I% = 1 TO PatternSize%

           ' Print label on left of each line:
           LOCATE I% + 3, 8
           PRINT USING "##:"; I%

           ' Draw "bit" boxes:
           X% = 80
           Y% = (I% + 2) * 8
           FOR J% = 1 TO 8
                 LINE (X%, Y%)-STEP(13, 6), 1, BF
                 X% = X% + 16
           NEXT J%
    NEXT I%

    DrawPattern      ' Draw  "Pattern View" box.

    LOCATE 21, 1
    PRINT "DIRECTION keys........Move cursor"
    PRINT "SPACEBAR............Changes point"
    PRINT "ENTER............Displays pattern"
    PRINT "ESC.........................Quits";

 END SUB

 SUB ShowPattern (OK$) STATIC
 SHARED Pattern$, PatternSize%

    ' Return screen to 80-column text mode:
    SCREEN 0, 0
    WIDTH 80

    PRINT "The following characters make up your pattern:"
    PRINT

    ' Print out the value for each pattern byte:
    FOR I% = 1 TO PatternSize%
           PatternByte% = ASC(MID$(Pattern$, I%, 1))
           PRINT "CHR$("; LTRIM$(STR$(PatternByte%)); ")"
    NEXT I%
    PRINT
    LOCATE , , 1
    PRINT "New pattern? ";
    OK$ = UCASE$(INPUT$(1))
 END SUB



 ENTAB.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\ENTAB.BAS

 ' ENTAB.BAS
 '
 ' Replace runs of spaces in a file with tabs.
 '
 DECLARE SUB SetTabPos ()
 DECLARE SUB StripCommand (CLine$)


 DEFINT A-Z
 DECLARE FUNCTION ThisIsATab (Column AS INTEGER)

 CONST MAXLINE = 255
 CONST TABSPACE = 8
 CONST NO = 0, YES = NOT NO

 DIM SHARED TabStops(MAXLINE) AS INTEGER

 StripCommand (COMMAND$)

 ' Set the tab positions (uses the global array TabStops).
 SetTabPos

 LastColumn = 1

 DO

    CurrentColumn = LastColumn

 ' Replace a run of blanks with a tab when you reach a tab
 ' column. CurrentColumn is the current column read.
 ' LastColumn is the last column that was printed.
    DO
       C$ = INPUT$(1,#1)
       IF C$ <> " " AND C$ <> CHR$(9) THEN EXIT DO
       CurrentColumn = CurrentColumn + 1
       IF C$=CHR$(9) OR ThisIsATab(CurrentColumn) THEN
          ' Go to a tab column if we have a tab and this
          ' is not a tab column.
          DO WHILE NOT ThisIsATab(CurrentColumn)
             CurrentColumn=CurrentColumn+1
          LOOP
          PRINT #2, CHR$(9);
          LastColumn = CurrentColumn
       END IF
    LOOP

 ' Print out any blanks left over.
    DO WHILE LastColumn < CurrentColumn
       PRINT #2, " ";
       LastColumn = LastColumn + 1
    LOOP

 ' Print the non-blank character.
    PRINT #2, C$;

 ' Reset the column position if this is the end of a line.
    IF C$ = CHR$(10) THEN
       LastColumn = 1
    ELSE
       LastColumn = LastColumn + 1
    END IF

 LOOP UNTIL EOF(1)
 CLOSE #1, #2
 END

 '------------------SUB SetTabPos-------------------------
 ' Set the tab positions in the array TabStops.
 '
 SUB SetTabPos STATIC
    FOR I = 1 TO 255
       TabStops(I) = ((I MOD TABSPACE) = 1)
    NEXT I
 END SUB
 '
 '------------------SUB StripCommand----------------------
 '
 SUB StripCommand (CommandLine$) STATIC
    IF CommandLine$ = "" THEN
       INPUT "File to entab:   ", InFileName$
       INPUT "Store entabbed file in:   ", OutFileName$
    ELSE
       SpacePos = INSTR(CommandLine$, " ")
       IF SpacePos > 0 THEN
          InFileName$ = LEFT$(CommandLine$, SpacePos - 1)
          OutFileName$ = LTRIM$(MID$(CommandLine$, SpacePos))
       ELSE
          InFileName$ = CommandLine$
          INPUT "Store entabbed file in:   ", OutFileName$
       END IF
    END IF
    OPEN InFileName$ FOR INPUT AS #1
    OPEN OutFileName$ FOR OUTPUT AS #2
 END SUB
 '---------------FUNCTION ThisIsATab----------------------
 ' Answer the question, "Is this a tab position?"
 '
 FUNCTION ThisIsATab (LastColumn AS INTEGER) STATIC
    IF LastColumn > MAXLINE THEN
       ThisIsATab = YES
    ELSE
       ThisIsATab = TabStops(LastColumn)
    END IF
 END FUNCTION


 FLPT.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\FLPT.BAS

 '
 ' FLPT.BAS
 '
 ' Displays how a given real value is stored in memory.
 '
 '
 DEFINT A-Z
 DECLARE FUNCTION MHex$ (X AS INTEGER)
 DIM Bytes(3)

 CLS
 PRINT "Internal format of IEEE number (all values in hexadecimal)"
 PRINT
 DO

    ' Get the value and calculate the address of the variable.
    INPUT "Enter a real number (or END to quit): ", A$
    IF UCASE$(A$) = "END" THEN EXIT DO
    RealValue! = VAL(A$)
    ' Convert the real value to a long without changing any of
    ' the bits.
    AsLong& = CVL(MKS$(RealValue!))
    ' Make a string of hex digits, and add leading zeroes.
    Strout$ = HEX$(AsLong&)
    Strout$ = STRING$(8 - LEN(Strout$), "0") + Strout$

    ' Save the sign bit, and then eliminate it so it doesn't
    ' affect breaking out the bytes
    SignBit& = AsLong& AND &H80000000
    AsLong& = AsLong& AND &H7FFFFFFF
    ' Split the real value into four separate bytes
    ' --the AND removes unwanted bits; dividing by 256 shifts
    ' the value right 8 bit positions.
    FOR I = 0 TO 3
       Bytes(I) = AsLong& AND &HFF&
       AsLong& = AsLong& \ 256&
    NEXT I
    ' Display how the value appears in memory.
    PRINT
    PRINT "Bytes in Memory"
    PRINT " High    Low"
    FOR I = 1 TO 7 STEP 2
       PRINT " "; MID$(Strout$, I, 2);
    NEXT I
    PRINT : PRINT

    ' Set the value displayed for the sign bit.
    Sign = ABS(SignBit& <> 0)

    ' The exponent is the right seven bits of byte 3 and the
    ' leftmost bit of byte 2. Multiplying by 2 shifts left and
    ' makes room for the additional bit from byte 2.
    Exponent = Bytes(3) * 2 + Bytes(2) \ 128

    ' The first part of the mantissa is the right seven bits
    ' of byte 2.  The OR operation makes sure the implied bit
    ' is displayed by setting the leftmost bit.
    Mant1 = (Bytes(2) OR &H80)
    PRINT " Bit 31    Bits 30-23  Implied Bit & Bits 22-0"
    PRINT "Sign Bit  Exponent Bits     Mantissa Bits"
    PRINT TAB(4); Sign; TAB(17); MHex$(Exponent);
    PRINT TAB(33); MHex$(Mant1); MHex$(Bytes(1)); MHex$(Bytes(0))
    PRINT

 LOOP

 ' MHex$ makes sure we always get two hex digits.
 FUNCTION MHex$ (X AS INTEGER) STATIC
    D$ = HEX$(X)
    IF LEN(D$) < 2 THEN D$ = "0" + D$
    MHex$ = D$
 END FUNCTION



 FONTASM.ASM
 CD-ROM Disc Path:   \SAMPCODE\BASIC\FONTASM.ASM

 .MODEL        MEDIUM
 ;************************************************************
 ; FONTASM.ASM - assembly lang routines for Font Toolbox
 ;
 ;  Copyright (C) 1989 Microsoft Corporation, All Rights Reserved
 ;
 ;   fl_SetBltDir    - Sets bltchar direction increments
 ;   fl_SetBltColor  - Sets color parameter for bltchar
 ;   fl_SetBltParams - Sets font related parameters for bltchar
 ;   fl_BltChar            - Character output routine
 ;
 ;   fl_MovMem            - Moves memory
 ;   fl_ansi            - Maps IBM chars to Windows ANSI;
 ;
 ;************************************************************

 ; BltChar data block
 .DATA

 ; These are set by fl_SetBltParams
 HdrLen            dw            0            ;length of windows font file hea
 CharHeight  dw            0            ;character height
 FirstChar   dw            0            ;first character defined in font
 LastChar    dw            0            ;last character defined in font
 DefaultChar dw            0            ;default character to use

 ; This is set by fl_SetBltColor
 CharColor   dw            0            ;current character color

 ; These are set by fl_SetBltDir
 XPixInc     dw            1            ;x inc for each pixel in character bit
 YPixInc     dw            0            ;y inc for each pixel in character bit
 XRowInc     dw            0            ;x inc for each row in character bitma
 YRowInc     dw            1            ;y inc for each row in character bitma
 XColInc     dw            8            ;x inc for each column (8 bits) in cha
 YColInc     dw            0            ;y inc for each column (8 bits) in cha

 .CODE
 ;********************************************************************
 ; fl_SetBltDir - Sets pixel, row, and column step values for bltchar
 ;
 ;   BASIC CALL:
 ;        fl.SetBltDir XPixInc%, YPixInc%, XRowInc%, YRowInc%
 ;
 ;   Comments:
 ;        When bltchar is blt-ing a bitmap to allow the different
 ;        directions to be output it uses preset counter increments
 ;        for moving a pixel, to the next row, and to the next column
 ;        of the bitmap. The pixel and row increments are input to this
 ;        routine. The column increments are calculates as 8 times the
 ;        pixel increment.
 ;
 ;********************************************************************

 ; Parameters
 pXPixInc    equ     WORD PTR [bp+12]
 pYPixInc    equ     WORD PTR [bp+10]
 pXRowInc    equ     WORD PTR [bp+8]
 pYRowInc    equ     WORD PTR [bp+6]

             PUBLIC  fl_SetBltDir
 fl_SetBltDir PROC

             push    bp                ;Entry
             mov     bp,sp

             mov     ax,pXRowInc ;Save input parameters
             mov     XRowInc,ax
             mov     ax,pYRowInc
             mov     YRowInc,ax

             mov     ax,pXPixInc
             mov     XPixInc,ax
             mov     cl,3
             shl     ax,cl
             mov     XColInc,ax        ;Column increment = Pix Inc * 8

             mov     ax,pYPixInc
             mov     YPixInc,ax
             mov     cl,3
             shl     ax,cl
             mov     YColInc,ax        ;Column increment = Pix Inc * 8

             pop     bp                ;Exit
             ret     8
 fl_SetBltDir ENDP

 ;********************************************************************
 ; fl_SetBltColor - Sets the color of blt-ed characters
 ;
 ;   BASIC CALL:
 ;        fl.SetBltColor color
 ;
 ;********************************************************************

 ; Parameters
 pColor            EQU     WORD PTR [bp+6]

             PUBLIC  fl_SetBltColor
 fl_SetBltColor PROC

             push    bp                    ;Entry
             mov     bp,sp

             mov     ax,pColor            ;Save color in data block
             mov     CharColor,ax

             pop     bp                    ;Exit
             ret     2

 fl_SetBltColor        ENDP

 ;********************************************************************
 ; fl_SetBltParams - Sets font-related params for bltchar
 ;
 ;   BASIC CALL:
 ;        fl.SetBltParams HdrLen%, CharHgt%, FirstChar%, LastChar%, DefChar%
 ;
 ;********************************************************************

 ; Parameters
 pHdrLen     equ     WORD PTR [bp+14]
 pCharHgt    equ     WORD PTR [bp+12]
 pFirstChar  equ     WORD PTR [bp+10]
 pLastChar   equ     WORD PTR [bp+8]
 pDefChar    equ     WORD PTR [bp+6]

             PUBLIC  fl_SetBltParams
 fl_SetBltParams PROC

             push    bp                    ;Entry
             mov     bp,sp

             mov     ax,pHdrLen
             mov     HdrLen,ax

             mov     ax,pCharHgt
             mov     CharHeight,ax

             mov     ax,pFirstChar
             mov     FirstChar,ax

             mov     ax,pLastChar
             mov     LastChar,ax

             mov     ax,pDefChar
             mov     DefaultChar,ax

             pop     bp                    ;Exit
             ret     10

 fl_SetBltParams ENDP

 ;********************************************************************
 ; fl_BltChar - Outputs a character's bitmap to the screen
 ;
 ;   BASIC CALL:
 ;        fl.BltChar FontAddr(far), Char%, X%, Y%
 ;
 ;********************************************************************

 ; BASIC Procedures
 EXTRN            B$N1I2:far, B$PSTC:far

 ; Parameters
 pFASeg            equ     WORD PTR [bp+14]
 pFAOffset   equ     WORD PTR [bp+12]
 pChar            equ     WORD PTR [bp+10]
 pX            equ     WORD PTR [bp+8]
 pY            equ     WORD PTR [bp+6]

 ; Local Variables
 .RowX            equ     WORD PTR [bp-2]
 .RowY            equ     WORD PTR [bp-4]
 .CharWid    equ     WORD PTR [bp-6]
 .ColWid     equ     WORD PTR [bp-8]

             PUBLIC  fl_BltChar
 fl_BltChar  PROC

             push    bp                    ;Entry
             mov     bp,sp
             sub     sp,8            ;Make room for local variables
             push    di
             push    si

             ;Normalize font address (make offset as small as possible)
             mov     ax,pFAOffset
             mov     bx,pFASeg
             push    ax
             mov     cl,4
             shr     ax,cl            ;offset = offset div 16
             add     bx,ax            ;seg = seg + offset
             pop     ax
             and     ax,0Fh            ;offset = original offset mod 16
             mov     si,ax
             mov     es,bx

             ;Calculate character number
             mov     bx,pChar
             cmp     bx,LastChar
             ja            usedefchar            ;Char is > last char, use def
             sub     bx,FirstChar
             jnc     getsize            ;Char is > first char, is OK
 usedefchar: mov     bx,DefaultChar

             ;Get character width from character table in font
 getsize:    shl     bx,1
             shl     bx,1            ;char = char * 4
             add     bx,si            ;offset into char table
             mov     cx,es:[bx]            ;cx = character width
             mov     .CharWid,cx

             ;Calculate character bitmap address
             inc     bx                    ;move to next two bytes in char tab
             inc     bx
             mov     cx,es:[bx]
             add     si,cx            ;add bitmap offset into font index
             sub     si,HdrLen            ;subtract length of header
             dec     si                    ;decrement for use in output algori

             ;Blt character
             mov     cx,pX            ;cx = x coord
             mov     dx,pY            ;dx = y coord

             mov     bx,.CharWid

 colloop:    mov     .RowX,cx            ;save coordinates of this row
             mov     .RowY,dx
             push    bx                    ;save remaining bits in character
             cmp     bx,8            ;limit to 8 for this column
             jle     colloop2
             mov     bx,8

 colloop2:   mov     .ColWid,bx            ;save width of this column for othe
             mov     ax,CharHeight   ;counter for number of rows

 rowloop:    push    ax
             inc     si                    ;increment bitmap pointer
             mov     al,es:[si]            ;get byte from bitmap

 pixloop:    shl     al,1            ;check next bit (from left to right)
             jnc     nextpixel            ;skip this pixel

             push    ax                    ;save registers
             push    bx
             push    cx
             push    dx
             push    es
             push    si

             mov     ax,CharColor    ;set up params for pset call
             push    ax                    ;color
             push    cx                    ;x-coordinate
             push    dx                    ;y-coordinate
             call    B$N1I2            ;set graphics cursor location
             call    B$PSTC            ;call PSET

             pop     si                    ;restore registers
             pop     es
             pop     dx
             pop     cx
             pop     bx
             pop     ax

 nextpixel:  jz            nextrow            ;skip remaining zero bits
             add     cx,XPixInc            ;increment x and y coordinates
             add     dx,YPixInc
             dec     bx                    ;check for end of byte
             jnz     pixloop            ;go for another pixel

 nextrow:    mov     cx,.RowX            ;retrieve the start coord of this row
             mov     dx,.RowY
             add     cx,XRowInc            ;increment counters for next row
             add     dx,YRowInc
             mov     .RowX,cx            ;save 'em back again
             mov     .RowY,dx
             mov     bx,.ColWid            ;reset the column width
             pop     ax                    ;check for the end of this column
             dec     ax
             jnz     rowloop            ;repeat for another row

 nextcol:    mov     cx,pX            ;retrieve the start coord of this column
             mov     dx,pY
             add     cx,XColInc            ;increment coordinates for next col
             add     dx,YColInc
             mov     pX,cx            ;save coordinates to use after next colu
             mov     pY,dx
             pop     bx                    ;check for end of the bitmap
             sub     bx,8
             ja            colloop            ;repeat for another column

             ;Done
             mov     ax,.CharWid     ;return value

             pop     si                    ;Exit
             pop     di
             mov     sp,bp
             pop     bp
             ret     10
 fl_BltChar  ENDP

 ;********************************************************************
 ; fl_MovMem - Moves memory bytes
 ;
 ;   BASIC CALL:
 ;        fl.MovMem source, dest, nbytes
 ;
 ;********************************************************************
             PUBLIC  fl_MovMem
 fl_MovMem   PROC
             push    bp
             mov     bp,sp
             push    si
             push    ds
             push    di

             les     di,[bp+12]
             lds     si,[bp+8]
             mov     cx,[bp+6]
             rep            movsb

             pop     di
             pop     ds
             pop     si
             pop     bp
             ret     10
 fl_MovMem   ENDP

 ;********************************************************************
 ; fl_ansi - Converts IBM char to Windows ANSI mapping
 ;
 ;   BASIC CALL:
 ;        ansi_byte = fl_ansi (ibm_char%)
 ;
 ;********************************************************************
 .CODE
             PUBLIC  fl_ansi
 fl_ansi     PROC
             push    bp
             mov     bp,sp

             xor     ax,ax            ; zero ax
             mov     al,[bp+6]            ; move input byte to ax
             mov     bx,ax            ; copy byte to bx
             and     al,7FH            ; mask off high bit
             test    bl,80H            ; test bx to see it high bit set
             jz            fl_a_2            ; if so then byte < 128, no trans

             mov     bx,OFFSET _OemToAnsiTable
             xlat

 fl_a_2:     pop     bp
             ret     2
 fl_ansi     ENDP


 ;***************************************************************************
 ;   USA OEM/ANSI translation tables.                                       *
 ;***************************************************************************
 ;

 ; This translation table is used by U.S.A. and some European countries.
 ; The original IBM extended character set is now addressed as Code Page 437.
 ; With DOS 3.3 or later, IBM introduced Code Page 850 as the preeminent
 ; multilingual character set.

 ; this translates Oem codes >= 128 to ANSI.
 ; there are 128 entries.

 .DATA
 _OemToAnsiTable  label   byte

         db   0C7H     ; 80h  C cedilla
         db   0FCh     ; 81h  u umlaut
         db   0E9h     ; 82h  e acute
         db   0E2h     ; 83h  a circumflex
         db   0E4h     ; 84h  a umlaut
         db   0E0h     ; 85h  a grave
         db   0E5h     ; 86h  a ring
         db   0E7h     ; 87h  c cedilla
         db   0EAh     ; 88h  e circumflex
         db   0EBh     ; 89h  e umlaut
         db   0E8h     ; 8Ah  e grave
         db   0EFh     ; 8Bh  i umlaut
         db   0EEh     ; 8Ch  i circumflex
         db   0ECh     ; 8Dh  i grave
         db   0C4h     ; 8Eh  A umlaut
         db   0C5h     ; 8Fh  A ring

         db   0C9h     ; 90h  E acute
         db   0E6h     ; 91h  ae
         db   0C6h     ; 92h  AE
         db   0F4h     ; 93h  o circumflex
         db   0F6h     ; 94h  o umlaut
         db   0F2h     ; 95h  o grave
         db   0FBh     ; 96h  u circumflex
         db   0F9h     ; 97h  u grave
         db   0FFh     ; 98h  y umlaut
         db   0D6h     ; 99h  O umlaut
         db   0DCh     ; 9Ah  U umlaut
         db   0A2h     ; 9Bh  cent
         db   0A3h     ; 9Ch  british pound
         db   0A5h     ; 9Dh  yen
         db   070h     ; 9Eh  Pesetas
         db   066h     ; 9Fh  florin (dutch)

         db   0E1h     ; A0h  a acute
         db   0EDh     ; A1h  i acute
         db   0F3h     ; A2h  o acute
         db   0FAh     ; A3h  u acute
         db   0F1h     ; A4h  n tilde
         db   0D1h     ; A5h  N tilde
         db   0AAh     ; A6h  a underlined superscript
         db   0BAh     ; A7h  o underlined superscript
         db   0BFh     ; A8h  inverted question mark
         db   05Fh     ; A9h  left top corner
         db   0ACh     ; AAh  right top corner
         db   0BDh     ; ABh  1/2
         db   0BCh     ; ACh  1/4
         db   0A1h     ; ADh  inverted point
         db   0ABh     ; AEh  <<
         db   0BBh     ; AFh  >>

         db   05Fh     ; B0h  here begins semigraphic characters
         db   05Fh     ; B1h
         db   05Fh     ; B2h
         db   0A6h     ; B3h  Vertical bar
         db   05Fh     ; B4h
         db   05Fh     ; B5h
         db   05Fh     ; B6h
         db   05Fh     ; B7h
         db   05Fh     ; B8h
         db   05Fh     ; B9h
         db   05Fh     ; BAh
         db   05Fh     ; BBh
         db   05Fh     ; BCh
         db   05Fh     ; BDh
         db   05Fh     ; BEh
         db   05Fh     ; BFh

         db   05Fh     ; C0h
         db   05Fh     ; C1h
         db   05Fh     ; C2h
         db   05Fh     ; C3h
         db   05Fh     ; C4h
         db   05Fh     ; C5h
         db   05Fh     ; C6h
         db   05Fh     ; C7h
         db   05Fh     ; C8h
         db   05Fh     ; C9h
         db   05Fh     ; CAh
         db   05Fh     ; CBh
         db   05Fh     ; CCh
         db   05Fh     ; CDh
         db   05Fh     ; CEh
         db   05Fh     ; CFh

         db   05Fh     ; D0h
         db   05Fh     ; D1h
         db   05Fh     ; D2h
         db   05Fh     ; D3h
         db   05Fh     ; D4h
         db   05Fh     ; D5h
         db   05Fh     ; D6h
         db   05Fh     ; D7h
         db   05Fh     ; D8h
         db   05Fh     ; D9h
         db   05Fh     ; DAh
         db   05Fh     ; DBh
         db   05Fh     ; DCh
         db   05Fh     ; DDh
         db   05Fh     ; DEh
         db   05Fh     ; DFh  end of semigraphic characters

         db   05Fh     ; E0h  alpha
         db   0DFh     ; E1h  german sharp S or greek beta
         db   05Fh     ; E2h  lambda
         db   0B6h     ; E3h  pi
         db   05Fh     ; E4h  sigma uc
         db   05Fh     ; E5h  sigma lc
         db   0B5h     ; E6h  mu
         db   05Fh     ; E7h  tau
         db   05Fh     ; E8h  phi uc
         db   05Fh     ; E9h  theta
         db   05Fh     ; EAh  omega
         db   05Fh     ; EBh  delta
         db   05Fh     ; ECh  infinite
         db   0D8h     ; EDh  math empty set or phi lc
         db   05Fh     ; EEh  math own sign
         db   05Fh     ; EFh  math include sign

         db   05Fh     ; F0h  math equivalence sign
         db   0B1h     ; F1h  + underlined
         db   05Fh     ; F2h  greater equal
         db   05Fh     ; F3h  less equal
         db   05Fh     ; F4h  math integral upper part
         db   05Fh     ; F5h  math integral lower part
         db   05Fh     ; F6h  math divide
         db   05Fh     ; F7h  math approximately (~)
         db   0B0h     ; F8h  degree
         db   0B7h     ; F9h  period accent (bold)
         db   0B7h     ; FAh  period accent
         db   05Fh     ; FBh  math root
         db   06Eh     ; FCh  n superscript
         db   0B2h     ; FDh  2 superscript
         db   05Fh     ; FEh
         db   05Fh     ; FFh  blank

         END


 FONTB.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\FONTB.BAS

 '*** FONTB.BAS - Font Routines for the Presentation Graphics Toolbox in
 '           Microsoft BASIC 7.0, Professional Development System
 '              Copyright (C) 1987-1989, Microsoft Corporation
 '
 '  NOTE:  This sample source code toolbox is intended to demonstrate some
 '  of the extended capabilities of Microsoft BASIC 7.0 Professional Developme
 '  system that can help to leverage the professional developer's time more
 '  effectively.  While you are free to use, modify, or distribute the routine
 '  in this module in any way you find useful, it should be noted that these a
 '  examples only and should not be relied upon as a fully-tested "add-on"
 '  library.
 '
 '  PURPOSE:  These are the toolbox routines to handle graphics text using
 '            Windows format raster font files:
 '
 '  To create a library and QuickLib containing the font routines found
 '  in this file, follow these steps:
 '       BC /X/FS fontb.bas
 '       LIB fontb.lib + fontb + fontasm + qbx.lib;
 '       LINK /Q fontb.lib, fontb.qlb,,qbxqlb.lib;
 '  If you are going to use this FONTB.QLB QuickLib in conjunction with
 '  the charting source code (CHRTB.BAS) or the UI toobox source code
 '  (GENERAL.BAS, WINDOW.BAS, MENU.BAS and MOUSE.BAS), you need to
 '  include the assembly code routines referenced in these files.  For the
 '  charting routines, create FONTB.LIB as follows before you create the
 '  QuickLib:
 '       LIB fontb.lib + fontb + fontasm + chrtasm + qbx.lib;
 '  For the UI toolbox routines, create the library as follows:
 '       LIB fontb.lib + fontb + fontasm + uiasm + qbx.lib;
 '**************************************************************************

 ' $INCLUDE: 'QBX.BI'
 ' $INCLUDE: 'FONTB.BI'

 CONST cFALSE = 0              ' Logical False
 CONST cTRUE = NOT cFALSE      ' Logical True

 CONST cDefaultColor = 15      ' Default character color (white in all modes)
 CONST cDefaultDir = 0         ' Default character direction
 CONST cDefaultFont = 1        ' Default font selected in LoadFont

 CONST cMaxFaceName = 32       ' Maximum length of a font name
 CONST cMaxFileName = 66       ' Maximum length of a font file name
 CONST cFontResource = &H8008  ' Identifies a font resource
 CONST cBitMapType = 0         ' Bitmap font type

 CONST cFileFont = 0           ' Font comes from file
 CONST cMemFont = 1            ' Font comes from memory

 CONST cSizeFontHeader = 118   ' Size of Windows font header

 ' *********************************************************************
 ' Data Types:

 ' Some global variables used:
 TYPE GlobalParams
         MaxRegistered     AS INTEGER     ' Max number of registered fonts all
         MaxLoaded         AS INTEGER     ' Max number of loaded fonts allowed
         TotalRegistered   AS INTEGER     ' Number of fonts actually registere
         TotalLoaded       AS INTEGER     ' Number of fonts actually loaded

         NextDataBlock     AS INTEGER     ' Next available block in font buffe

         CurrentFont       AS INTEGER     ' Current font number in loaded font
         CHeight           AS INTEGER     ' Character height of current font
         FChar             AS INTEGER     ' First char in font
         LChar             AS INTEGER     ' Last char in font
         DChar             AS INTEGER     ' Default char for font
         DSeg              AS INTEGER     ' Segment of current font
         DOffset           AS INTEGER     ' Offset of current font
         FontSource        AS INTEGER     ' Source of current font (File or Me

         CharColorInit     AS INTEGER     ' cFALSE (0) means color not initial
         CharColor         AS INTEGER     ' Character color
         CharDirInit       AS INTEGER     ' cFALSE (0) means dir not initializ
         CharDir           AS INTEGER     ' Character direction
         CharSet           AS INTEGER     ' Character mappings to use

         XPixInc           AS INTEGER     ' X increment direction (0, 1, -1)
         YPixInc           AS INTEGER     ' Y increment direction (0, 1, -1)

         WindowSet         AS INTEGER     ' cTRUE if GTextWindow has been call
         WX1               AS SINGLE      ' Minimum WINDOW X
         WY1               AS SINGLE      ' Minimum WINDOW Y
         WX2               AS SINGLE      ' Maximum WINDOW X
         WY2               AS SINGLE      ' Maximum WINDOW Y
         WScrn             AS INTEGER     ' cTRUE means Y increases top to bot

 END TYPE

 ' The following 3 types are needed to read .FON files. They are documented
 ' in chapter 7 of the MS Windows Programmer's Reference:

 ' Windows font file header:
 TYPE WFHeader
         dfVersion         AS INTEGER
         dfSize            AS LONG
         dfCopyright       AS STRING * 60
         dfType            AS INTEGER
         dfPoints          AS INTEGER
         dfVertRes         AS INTEGER
         dfHorizRes        AS INTEGER
         dfAscent          AS INTEGER
         dfInternalLeading AS INTEGER
         dfExternalLeading AS INTEGER
         dfItalic          AS STRING * 1
         dfUnderline       AS STRING * 1
         dfStrikeOut       AS STRING * 1
         dfWeight          AS INTEGER
         dfCharSet         AS STRING * 1
         dfPixWidth        AS INTEGER
         dfPixHeight       AS INTEGER
         dfPitchAndFamily  AS STRING * 1
         dfAvgWidth        AS INTEGER
         dfMaxWidth        AS INTEGER
         dfFirstChar       AS STRING * 1
         dfLastChar        AS STRING * 1
         dfDefaultChar     AS STRING * 1
         dfBreakChar       AS STRING * 1
         dfWidthBytes      AS INTEGER
         dfDevice          AS LONG
         dfFace            AS LONG
         dfBitsPointer     AS LONG
         dfBitsOffset      AS LONG
         pad               AS STRING * 1  ' To ensure word boundry
 END TYPE

 ' Structure for reading resource type and number from a resource
 ' table:
 TYPE ResType
         TypeID            AS INTEGER
         NumResource       AS INTEGER
         Reserved          AS LONG
 END TYPE

 ' Structure for reading an actual resource entry:
 TYPE ResEntry
         AddrOffset        AS INTEGER
         Length            AS INTEGER
         ResourceKeywd     AS INTEGER
         ResID             AS INTEGER
         Reserved1         AS LONG
 END TYPE

 ' Internal font header data type:
 TYPE IFontInfo
         Status            AS INTEGER  ' Processing status. 0=unproc. else <>0
         FontHeader        AS WFHeader ' The Windows font header
         FaceName          AS STRING * cMaxFaceName   ' Font name
         FileName          AS STRING * cMaxFileName   ' File name
         FontSource        AS INTEGER  ' 0=file, 1=memory
         FileLoc           AS LONG     ' Location in resource file of font fil
         DataSeg           AS INTEGER  ' FontData index or Segment address of
         DataOffset        AS INTEGER  ' Offset  address of font if in memory
         BitsOffset        AS INTEGER  ' Offset from beginning of data to bitm
 END TYPE

 ' Type for selecting registered fonts via LoadFont:
 TYPE FontSpec
         FaceName    AS STRING * cMaxFaceName
         Pitch       AS STRING * 1
         PointSize   AS INTEGER     ' Fonts point size
         HorizRes    AS INTEGER     ' Horizontal resolution of font
         VertRes     AS INTEGER     ' Vertical resolution of font
         ScrnMode    AS INTEGER     ' Screen mode
         Height      AS INTEGER     ' Pixel height of font

         Best        AS INTEGER     ' "Best" flag (true/false)

         RegNum      AS INTEGER     ' Number of font in registered list

         InMemory    AS INTEGER     ' Whether font is in memory (true/false)
         HdrSeg      AS INTEGER     ' Segment of font in memory
         HdrOff      AS INTEGER     ' Offset of font in segment
         DataSeg     AS INTEGER     ' Segment of data in memory
         DataOff     AS INTEGER     ' Offset of data in segment
 END TYPE

 ' *********************************************************************
 ' Routine Declarations:

 DECLARE SUB flSetFontErr (ErrNum AS INTEGER)
 DECLARE SUB flClearFontErr ()
 DECLARE SUB flRegisterFont (FileName$, FileNum%)
 DECLARE SUB flReadFont (I%)
 DECLARE SUB flSizeFontBuffer (NFonts%)
 DECLARE SUB flInitSpec (Spec AS ANY)
 DECLARE SUB flClearFontStatus ()
 DECLARE SUB flGetCurrentScrnSize (XPixels%, YPixels%)
 DECLARE SUB flGetBASICScrnSize (ScrnMode%, XPixels%, YPixels%)
 DECLARE SUB flInitMask ()
 DECLARE SUB flPSET (X%, Y%, Colr%)
 DECLARE SUB flChkMax ()

 DECLARE FUNCTION flGetFonts! (NFonts%)
 DECLARE FUNCTION flMatchFont! (FSpec AS ANY)
 DECLARE FUNCTION flGetNum! (Txt$, ChPos%, Default!, ErrV!)
 DECLARE FUNCTION flGetNextSpec! (SpecTxt$, ChPos%, Spec AS ANY)
 DECLARE FUNCTION flDoNextResource! (Align%, FileName$, FileNum%)
 DECLARE FUNCTION flOutGChar% (X%, Y%, ChVal%)

 ' -- Assembly language routines
 DECLARE SUB flMovMem ALIAS "fl_MovMem" (SEG dest AS ANY, BYVAL SrcSeg AS INTE
 DECLARE FUNCTION flANSI% ALIAS "fl_ansi" (BYVAL I%)

 DECLARE SUB flSetBltDir ALIAS "fl_SetBltDir" (BYVAL XPixInc%, BYVAL YPixInc%,
 DECLARE SUB flSetBltColor ALIAS "fl_SetBltColor" (BYVAL CharColor%)
 DECLARE SUB flSetBltParams ALIAS "fl_SetBltParams" (BYVAL HdrLen%, BYVAL Char
 DECLARE FUNCTION flbltchar% ALIAS "fl_BltChar" (BYVAL FASeg%, BYVAL FAOffset%

 ' *********************************************************************
 ' Variable Definitions:

 ' The following arrays hold font headers and font data as fonts are
 ' registered and loaded. They are dynamically allocated so they can be
 ' changed in size to accomodate the number of fonts a program will be
 ' using:

 ' $DYNAMIC

 ' Array to hold header information for registered fonts:
 DIM SHARED FontHdrReg(1 TO 10)  AS IFontInfo

 ' Arrays to hold header information and registered font numbers
 ' for loaded fonts:
 DIM SHARED FontHdrLoaded(1 TO 10) AS IFontInfo
 DIM SHARED FontLoadList(1 TO 10) AS INTEGER

 ' Array to hold font data information:
 DIM SHARED FontData(1 TO 1) AS FontDataBlock

 ' $STATIC

 ' Structure holding global parameters:
 DIM SHARED FGP AS GlobalParams

 ' Error handler for flChkMax so these arrays will be dimensioned
 ' to 10 by default:
 SetMax:
         REDIM FontHdrLoaded(1 TO 10) AS IFontInfo
         REDIM FontHdrReg(1 TO 10) AS IFontInfo
         REDIM FontLoadList(1 TO 10) AS INTEGER
         RESUME

 ' Error handler for out of memory error:
 MemErr:
         flSetFontErr cNoFontMem
         RESUME NEXT

 ' Error handler for unexpected errors:
 UnexpectedErr:
         flSetFontErr cFLUnexpectedErr + ERR
         RESUME NEXT

 ' File not found error: RegisterFonts
 NoFileErr:
         flSetFontErr cFileNotFound
         RESUME NEXT

 '=== flChkMax - Makes sure that max font settings are correct and
 '                enforces default of 10 for max loaded and registered
 '
 '  Arguments:
 '     none
 '
 '  Return Values:
 '     none
 '
 '=================================================================
 SUB flChkMax STATIC
 SHARED FontHdrLoaded() AS IFontInfo
 SHARED FontHdrReg() AS IFontInfo
 SHARED FGP AS GlobalParams

 ' Make sure that GP.MaxLoaded and GP.MaxRegistered match array dimensions
 ' this will only happen if user hasn't used SetMaxFonts and allows Fontlib
 ' to set a default of 10 since that is what the arrays are first DIM'd
 ' to:

 ON ERROR GOTO SetMax
 FGP.MaxLoaded = UBOUND(FontHdrLoaded)
 FGP.MaxRegistered = UBOUND(FontHdrReg)
 ON ERROR GOTO UnexpectedErr

 END SUB

 '=== flClearFontErr - Sets the FontErr variable to 0
 '
 '  Arguments:
 '     none
 '
 '  Return Values:
 '     none
 '
 '=================================================================
 SUB flClearFontErr STATIC

         FontErr = 0

 END SUB

 '=== flClearFontStatus - Clears the status field in the registered font list
 '
 '  Arguments:
 '     none
 '
 '=================================================================
 SUB flClearFontStatus STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrReg() AS IFontInfo

 FOR I% = 1 TO FGP.TotalRegistered
         FontHdrReg(I%).Status = 0
 NEXT I%

 END SUB

 '=== flDoNextResource - Processes resource from resource table:
 '
 '  Arguments:
 '     Align%      - Alignment shift count for finding resource data
 '
 '     FileName$   - Name of font file (passed to routine that actually
 '                   registers resource entry)
 '
 '     FileNum%    - File number for reading
 '
 '  Return Value:
 '     The number of fonts actually registered
 '
 '=================================================================
 FUNCTION flDoNextResource (Align%, FileName$, FileNum%) STATIC
 DIM ResID AS ResType, Entry AS ResEntry

 ' Get the first few bytes identifying the resource type and the number
 ' of this type:
 GET FileNum%, , ResID

 ' If this is not the last resource then process it:
 IF ResID.TypeID <> 0 THEN

         ' Loop through the entries of this resource and if an entry happens t
         ' a font resource then register it. The file location must be saved
         ' for each entry in the resource table since the flRegisterFont
         ' routine may go to some other part of the file to read the resource:
         FOR ResourceEntry = 1 TO ResID.NumResource

                 GET FileNum%, , Entry
                 NextResLoc# = SEEK(FileNum%)
                 IF ResID.TypeID = cFontResource THEN

                         ' Seek to font information, register it, then seek ba
                         ' the next resource table entry:
                         SEEK FileNum%, Entry.AddrOffset * 2 ^ Align% + 1
                         flRegisterFont FileName$, FileNum%
                         SEEK FileNum%, NextResLoc#
                         IF FontErr <> 0 THEN EXIT FUNCTION

                 END IF

         NEXT ResourceEntry
 END IF

 ' Return the current resource type so that RegisterFonts knows when the
 ' last resource has been read:
 flDoNextResource = ResID.TypeID

 END FUNCTION

 '=== flGetBASICScrnSize - Returns screen size for specified BASIC screen mode
 '
 '  Arguments:
 '
 '     ScrnMode%   -  BASIC screen mode
 '
 '     XPixels%    -  Number of pixels in horizontal direction
 '
 '     YPixels%    -  Number of pixels in vertical direction
 '
 '=================================================================
 SUB flGetBASICScrnSize (ScrnMode%, XPixels%, YPixels%) STATIC
         SELECT CASE ScrnMode%
                 CASE 1: XPixels% = 320: YPixels% = 200
                 CASE 2: XPixels% = 640: YPixels% = 200
                 CASE 3: XPixels% = 720: YPixels% = 348
                 CASE 4: XPixels% = 640: YPixels% = 400
                 CASE 7: XPixels% = 320: YPixels% = 200
                 CASE 8: XPixels% = 640: YPixels% = 200
                 CASE 9: XPixels% = 640: YPixels% = 350
                 CASE 10: XPixels% = 640: YPixels% = 350
                 CASE 11: XPixels% = 640: YPixels% = 480
                 CASE 12: XPixels% = 640: YPixels% = 480
                 CASE 13: XPixels% = 320: YPixels% = 200
                 CASE ELSE: XPixels% = 0: YPixels% = 0
         END SELECT
 END SUB

 '=== flGetCurrentScrnSize - Returns screen size for current screen mode
 '
 '  Arguments:
 '
 '     XPixels%    -  Number of pixels in horizontal direction
 '
 '     YPixels%    -  Number of pixels in vertical direction
 '
 '=================================================================
 SUB flGetCurrentScrnSize (XPixels%, YPixels%) STATIC
 DIM Regs AS RegType

 ' Use DOS interrupt to get current video display mode:
 Regs.ax = &HF00
 CALL INTERRUPT(&H10, Regs, Regs)

 ' Set screen size based on mode:
 SELECT CASE Regs.ax MOD 256
         CASE &H4: XPixels% = 320: YPixels% = 200
         CASE &H5: XPixels% = 320: YPixels% = 200
         CASE &H6: XPixels% = 640: YPixels% = 200
         CASE &H7: XPixels% = 720: YPixels% = 350
         CASE &H8: XPixels% = 720: YPixels% = 348     ' Hercules
         CASE &HD: XPixels% = 320: YPixels% = 200
         CASE &HE: XPixels% = 640: YPixels% = 200
         CASE &HF: XPixels% = 640: YPixels% = 350
         CASE &H10: XPixels% = 640: YPixels% = 350
         CASE &H11: XPixels% = 640: YPixels% = 480
         CASE &H12: XPixels% = 640: YPixels% = 480
         CASE &H13: XPixels% = 320: YPixels% = 200
         CASE &H40: XPixels% = 640: YPixels% = 400    ' Olivetti
         CASE ELSE: XPixels% = 0: YPixels = 0
 END SELECT
 END SUB

 '=== flGetFonts - Gets fonts specified in FontLoadList
 '
 '  Arguments:
 '     NFonts%  -  Number of fonts to load
 '
 '  Return Values:
 '     Number of fonts successfully loaded
 '
 '=================================================================
 FUNCTION flGetFonts (NFonts%) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrReg() AS IFontInfo
 SHARED FontHdrLoaded() AS IFontInfo
 SHARED FontLoadList() AS INTEGER

 ' Re-dimension font data buffer to fit all the fonts:
 flSizeFontBuffer (NFonts%)
 IF FontErr = cNoFontMem THEN EXIT FUNCTION

 ' Clear the font status variables then load the fonts (the status variable
 ' is used to record which ones have already been loaded so they aren't
 ' loaded more than once):
 flClearFontStatus
 FOR Font% = 1 TO NFonts%
         FontNum% = FontLoadList(Font%)

         ' If font already loaded then just copy the already-filled-out header
         ' to the new slot:
         IF FontHdrReg(FontNum%).Status <> 0 THEN
                 FontHdrLoaded(Font%) = FontHdrLoaded(FontHdrReg(FontNum%).Sta

         ' Otherwise, read the font and update status in registered version
         ' to point to the first slot it was loaded into (so we can go get
         ' an already-filled-out header from there):
         ELSE
                 FontHdrLoaded(Font%) = FontHdrReg(FontNum%)

                 ' Hold any existing errors:
                 HoldErr% = FontErr
                 flClearFontErr

                 flReadFont Font%

                 ' If there was an error in reading font, exit. Otherwise,
                 ' reset the error to what it was before and continue:
                 IF FontErr <> 0 THEN
                         flGetFonts = FontNum% - 1
                         EXIT FUNCTION
                 ELSE
                         flSetFontErr HoldErr%
                 END IF

                 FontHdrReg(FontNum%).Status = Font%
         END IF
 NEXT Font%

 flGetFonts = NFonts%
 END FUNCTION

 '=== flGetNextSpec - Parses the next spec from the spec string
 '
 '  Arguments:
 '     SpecTxt$ -  String containing font specifications
 '
 '     ChPos%   -  Current position in string (updated in this routine)
 '
 '     Spec     -  Structure to contain parsed values
 '
 '
 '  Return Values:
 '     0    -  Spec was found
 '
 '     1    -  No spec found
 '
 '     2    -  Invalid spec found
 '=================================================================
 FUNCTION flGetNextSpec (SpecTxt$, ChPos%, Spec AS FontSpec) STATIC

 ' Initialize some things:
 SpecErr = cFALSE
 SpecLen% = LEN(SpecTxt$)

 ' If character pos starts past end of spec then we're done:
 IF ChPos% > SpecLen% THEN
         flGetNextSpec = 1
         EXIT FUNCTION
 END IF

 DO UNTIL ChPos% > SpecLen%

         Param$ = UCASE$(MID$(SpecTxt$, ChPos%, 1))
         ChPos% = ChPos% + 1

         SELECT CASE Param$

                 ' Skip blanks:
                 CASE " ":

                 ' Font title:
                 CASE "T":

                         ' Scan for font title until blank or end of string:
                         StartPos% = ChPos%
                         DO UNTIL ChPos% > SpecLen%
                                 Char$ = MID$(SpecTxt$, ChPos%, 1)
                                 ChPos% = ChPos% + 1
                         LOOP

                         ' Extract the title:
                         TitleLen% = ChPos% - StartPos%
                         IF TitleLen% <= 0 THEN
                                 SpecErr = cTRUE
                         ELSE
                                 Spec.FaceName = MID$(SpecTxt$, StartPos%, Tit
                         END IF

                 ' Fixed or Proportional font:
                 CASE "F", "P":
                         Spec.Pitch = Param$

                 ' Font Size (default to 12 points):
                 CASE "S":
                         Spec.PointSize = flGetNum(SpecTxt$, ChPos%, 12, SpecE

                 ' Screen Mode:
                 CASE "M":
                         Spec.ScrnMode = flGetNum(SpecTxt$, ChPos%, -1, SpecEr

                 ' Pixel Height:
                 CASE "H":
                         Spec.Height = flGetNum(SpecTxt$, ChPos%, 0, SpecErr)

                 ' Best fit:
                 CASE "B":
                         Spec.Best = cTRUE

                 ' Registered font number:
                 CASE "N":
                         Spec.RegNum = flGetNum(SpecTxt$, ChPos%, 0, SpecErr)

                 ' Font in memory:
                 CASE "R":
                         Spec.InMemory = cTRUE

                 ' Spec separator:
                 CASE "/":
                         EXIT DO

                 ' Anything else is an error:
                 CASE ELSE:
                         SpecErr = cTRUE
                         ChPos% = ChPos% + 1
         END SELECT
 LOOP

 ' Spec is parsed, make sure a valid screen mode has been specified and
 ' adjust point sizes for 320x200 screens if necessary:
 IF Spec.PointSize <> 0 THEN

         ' Get screen size for specified mode (with "M" param) or current
         ' screen mode:
         IF Spec.ScrnMode < 0 THEN
                 flGetCurrentScrnSize XPixels%, YPixels%
         ELSE
                 flGetBASICScrnSize Spec.ScrnMode, XPixels%, YPixels%
         END IF

         ' If this isn't a graphics mode then set an error and skip the rest:
         IF XPixels% = 0 THEN
                 SpecErr = cTRUE
                 Spec.PointSize = 0

         ' If this is a 320x200 screen mode adjust point sizes to the
         ' equivalent EGA font point sizes. Also set the horizontal
         ' a vertical resolutions to search for in fonts (horizontal is
         ' 96 for all modes, vertical varies):
         ELSE

                 ' Use a horizontal resolution of 96 for all screens:
                 Spec.HorizRes = 96

                 IF XPixels% = 320 THEN
                         Spec.VertRes = 72

                         ' In a 320x200 mode scale point sizes to their equiva
                         ' EGA fonts (special case 14 and 24 point fonts to ma
                         ' to the closest EGA font otherwise multiply point si
                         ' 2/3:
                         SELECT CASE Spec.PointSize
                                 CASE 14: Spec.PointSize = 10
                                 CASE 24: Spec.PointSize = 18
                                 CASE ELSE: Spec.PointSize = Spec.PointSize *
                         END SELECT

                 ELSE

                         ' Other screen modes vary only in vertical resolution
                         SELECT CASE YPixels%
                                 CASE 200: Spec.VertRes = 48
                                 CASE 350: Spec.VertRes = 72
                                 CASE 480: Spec.VertRes = 96
                         END SELECT
                 END IF
         END IF
 END IF

 ' If an error was found somewhere then pass it on and set-up to load
 ' first font:
 IF SpecErr THEN
         flGetNextSpec = 2
         Spec.RegNum = 1
 ELSE
         flGetNextSpec = 0
 END IF

 END FUNCTION

 '=== flGetNum - Parses number from string
 '
 '  Arguments:
 '     Txt$     -  String from which to parse number
 '
 '     ChPos%   -  Character position on which to start
 '
 '     Default  -  Default value if number not found
 '
 '     ErrV     -  Returns error as cTrue or cFalse
 '
 '  Return Values:
 '     Returns value found or default
 '
 '  Notes:
 '     Simple state machine:
 '        state 0: Looking for first char
 '        state 1: Found start (+, -, or digit)
 '        state 2: Done
 '        state 3: Error
 '
 '=================================================================
 FUNCTION flGetNum (Txt$, ChPos%, Default, ErrV) STATIC

 ' Start in state 0
 State = 0

 ' Loop until done
 DO
         Char$ = MID$(Txt$, ChPos%, 1)
         SELECT CASE Char$

                 ' Plus and minus are only OK at the beginning:
                 CASE "+", "-":
                         SELECT CASE State
                                 CASE 0: Start% = ChPos%: State = 1
                                 CASE ELSE: State = 3
                         END SELECT

                 ' Digits are OK at the beginning of after plus and minus:
                 CASE "0" TO "9":
                         SELECT CASE State
                                 CASE 0: Start% = ChPos%: State = 1
                                 CASE ELSE:
                         END SELECT

                 ' Spaces are skipped:
                 CASE " ":

                 ' Anything else is an error at the beginning or marks the end
                 CASE ELSE:
                         SELECT CASE State
                                 CASE 0: State = 3
                                 CASE 1: State = 2
                         END SELECT
         END SELECT

         ' Go to next character:
         ChPos% = ChPos% + 1
 LOOP UNTIL State = 2 OR State = 3

 ' Scanning is complete; adjust ChPos% to mark last character processed:
 ChPos% = ChPos% - 1

 ' If error then set default number:
 IF State = 3 THEN
         flGetNum = Default
         ErrV = cTRUE

 ' Otherwise, extract number and get its value:
 ELSE
         EndPos% = ChPos% - 1
         flGetNum = VAL(MID$(Txt$, Start%, EndPos%))
         ErrV = cFALSE
 END IF
 END FUNCTION

 '=== flInitSpec - Initializes font specification structure
 '
 '  Arguments:
 '     Spec     -  FontSpec variable to initialize
 '
 '=================================================================
 SUB flInitSpec (Spec AS FontSpec) STATIC

         Spec.FaceName = ""
         Spec.Pitch = ""
         Spec.PointSize = 0
         Spec.ScrnMode = -1
         Spec.Height = 0
         Spec.Best = cFALSE
         Spec.RegNum = 0
         Spec.InMemory = cFALSE

 END SUB

 '=== flMatchFont - Finds first registered font that matches FontSpec
 '
 '  Arguments:
 '     FSpec -  FontSpec variable containing specification to match
 '
 '  Return Values:
 '     Number of registered font matched, -1 if no match.
 '
 '=================================================================
 FUNCTION flMatchFont (FSpec AS FontSpec) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrReg() AS IFontInfo

 ' Match a specific registered font:
 IF FSpec.RegNum > 0 AND FSpec.RegNum <= FGP.TotalRegistered THEN
         flMatchFont = FSpec.RegNum
         EXIT FUNCTION
 END IF

 ' If this is an invalid spec. then no fonts matched:
 IF FontErr <> 0 THEN
         flMatchFont = -1
         EXIT FUNCTION
 END IF

 ' Scan font for first one that matches the rest of the specs:
 SelectedFont% = -1
 BestSizeDiff = 3.402823E+38
 BestFontNum% = -1
 FOR FontNum% = 1 TO FGP.TotalRegistered

         ' Match a font from memory:
         MemOK% = cTRUE
         IF FSpec.InMemory AND FontHdrReg(FontNum%).FontSource <> cMemFont THE
                 MemOK% = cFALSE
         END IF

         ' Match name:
         IF FSpec.FaceName = FontHdrReg(FontNum%).FaceName OR LTRIM$(FSpec.Fac
                 NameOK% = cTRUE
         ELSE
                 NameOK% = cFALSE
         END IF

         ' Match pitch (fixed or proportional):
         Pitch$ = "F"
         IF FontHdrReg(FontNum%).FontHeader.dfPixWidth = 0 THEN Pitch$ = "P"
         IF FSpec.Pitch = Pitch$ OR FSpec.Pitch = " " THEN
                 PitchOK% = cTRUE
         ELSE
                 PitchOK% = cFALSE
         END IF

         ' Match font size (if neither point or pixel size specified then
         ' this font is OK):
         IF FSpec.PointSize = 0 AND FSpec.Height = 0 THEN
                 SizeOK% = cTRUE

         ' Otherwise, if point size specified (note that point size overrides
         ' the pixel height if they were both specified)...
         ELSEIF FSpec.PointSize <> 0 THEN

                 ' Make sure the font resolution matches the screen resolution
                 ' (pass over this font if not):
                 IF FSpec.HorizRes <> FontHdrReg(FontNum%).FontHeader.dfHorizR
                         SizeOK% = cFALSE
                 ELSEIF FSpec.VertRes <> FontHdrReg(FontNum%).FontHeader.dfVer
                         SizeOK% = cFALSE

                 ' Font has made it past the resolution check, now try to matc
                 ELSE
                         SizeDiff = ABS(FSpec.PointSize - FontHdrReg(FontNum%)
                         IF SizeDiff = 0 THEN
                                 SizeOK% = cTRUE
                         ELSE
                                 SizeOK% = cFALSE
                         END IF
                 END IF


         ' Now, the case where height was specified and not point size:
         ELSEIF FSpec.Height <> 0 THEN
                 SizeDiff = ABS(FSpec.Height - FontHdrReg(FontNum%).FontHeader
                 IF SizeDiff = 0 THEN
                         SizeOK% = cTRUE
                 ELSE
                         SizeOK% = cFALSE
                 END IF
         END IF

         ' Do record keeping if best-fit was specified:
         IF NOT SizeOK% AND PitchOK% AND FSpec.Best AND SizeDiff < BestSizeDif
                 BestSizeDiff = SizeDiff
                 BestFontNum% = FontNum%
         END IF

         ' See if this font is OK:
         IF MemOK% AND NameOK% AND PitchOK% AND SizeOK% THEN
                 SelectedFont% = FontNum%
                 EXIT FOR
         END IF
 NEXT FontNum%

 ' If no font was matched and best-fit was specified then select the
 ' best font:
 IF SelectedFont% < 0 AND FSpec.Best THEN SelectedFont% = BestFontNum%

 ' Return the font matched:
 flMatchFont = SelectedFont%

 END FUNCTION

 '=== flReadFont - Reads font data and sets up font header
 '
 '  Arguments:
 '     I%    -  Slot in loaded fonts to process
 '
 '=================================================================
 SUB flReadFont (I%) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrLoaded() AS IFontInfo
 SHARED FontData() AS FontDataBlock

 ON ERROR GOTO UnexpectedErr

 ' If memory font then it's already in memory:
 IF FontHdrLoaded(I%).FontSource = cMemFont THEN
         EXIT SUB

 ' For a font from a file, read it in:
 ELSE
         DataSize# = FontHdrLoaded(I%).FontHeader.dfSize - cSizeFontHeader
         NumBlocks% = -INT(-DataSize# / cFontBlockSize)
         FontHdrLoaded(I%).DataSeg = FGP.NextDataBlock

         ' Get next available file number and open file:
         FileNum% = FREEFILE
         OPEN FontHdrLoaded(I%).FileName FOR BINARY AS FileNum%

         ' Read blocks from the font file:
         DataLoc# = FontHdrLoaded(I%).FileLoc + cSizeFontHeader
         SEEK FileNum%, DataLoc#
         FOR BlockNum% = 0 TO NumBlocks% - 1
                 GET FileNum%, , FontData(FGP.NextDataBlock + BlockNum%)
         NEXT BlockNum%

         ' Close the file:
         CLOSE FileNum%

         ' Update the next data block pointer:
         FGP.NextDataBlock = FGP.NextDataBlock + NumBlocks%
 END IF

 END SUB

 '=== flRegisterFont - Actually registers a font resource:
 '
 '  Arguments:
 '     FileName$   - Name of font file (passed to routine that actually
 '                   registers resource entry)
 '
 '     FileNum%    - File number for reading
 '
 '=================================================================
 SUB flRegisterFont (FileName$, FileNum%) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrReg() AS IFontInfo

 DIM Byte AS STRING * 1, FontHeader AS WFHeader

 ' Read the font header:
 FontLoc# = SEEK(FileNum%)
 GET FileNum%, , FontHeader

 ' Only register vector fonts:
 IF FontHeader.dfType AND &H1 <> cBitMapType THEN EXIT SUB

 ' See that we're still within MaxRegistered limits:
 IF FGP.TotalRegistered >= FGP.MaxRegistered THEN
         flSetFontErr cTooManyFonts
         EXIT SUB
 END IF

 ' Go to next "registered" font slot:
 FGP.TotalRegistered = FGP.TotalRegistered + 1

 ' Set font source and save the header and file location:
 FontHdrReg(FGP.TotalRegistered).FontSource = cFileFont
 FontHdrReg(FGP.TotalRegistered).FontHeader = FontHeader
 FontHdrReg(FGP.TotalRegistered).FileLoc = FontLoc#

 ' Get the face name (scan characters until zero byte):
 SEEK FileNum%, FontLoc# + FontHeader.dfFace
 FaceName$ = ""
 FOR Char% = 0 TO cMaxFaceName - 1
         GET FileNum%, , Byte
         IF ASC(Byte) = 0 THEN EXIT FOR
         FaceName$ = FaceName$ + Byte
 NEXT Char%
 FontHdrReg(FGP.TotalRegistered).FaceName = FaceName$

 ' Finally, save the file name:
 FontHdrReg(FGP.TotalRegistered).FileName = FileName$

 END SUB

 '=== flSetFontErr - Sets the FontErr variable to an error value:
 '
 '  Arguments:
 '     ErrNum   -  The error number to set FontErr variable to
 '
 '=================================================================
 SUB flSetFontErr (ErrNum AS INTEGER) STATIC

          FontErr = ErrNum

 END SUB

 '=== flSizeFontBuffer - Calculate the FontBuffer size required for all fonts
 '
 '  Arguments:
 '     NFonts%  -  Number of font to be loaded
 '
 '  Notes:
 '     The use of -INT(-N) in the following code rounds N to the next
 '     larger integer
 '
 '=================================================================
 SUB flSizeFontBuffer (NFonts%) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrReg() AS IFontInfo
 SHARED FontLoadList() AS INTEGER
 SHARED FontData() AS FontDataBlock


 ON ERROR GOTO UnexpectedErr
 IF NFonts% = 0 THEN EXIT SUB

 ' Clear font status variables so we know what has been processed:
 flClearFontStatus

 ' Add sizes of all unique fonts together to get total size (each font
 ' begins on a new font block so the size of each font is calculated in
 ' terms of the number of font blocks it will take up):
 Size = 0
 FOR I% = 1 TO NFonts%
         FontNum% = FontLoadList(I%)
         IF FontHdrReg(FontNum%).Status = 0 THEN
                 FontSize = FontHdrReg(FontNum%).FontHeader.dfSize - cSizeFont
                 Size = Size - INT(-FontSize / cFontBlockSize)
                 FontHdrReg(FontNum%).Status = 1
         END IF
 NEXT I%

 ' Dimension the FontData array to hold everything:
 ON ERROR GOTO MemErr
 REDIM FontData(1 TO Size) AS FontDataBlock
 ON ERROR GOTO UnexpectedErr

 ' Set the next font block to the start for when flReadFont begins
 ' putting data in the font buffer:
 FGP.NextDataBlock = 1

 END SUB

 '=== GetFontInfo - Returns useful information about current font
 '
 '  Arguments:
 '     FI    -  FontInfo type variable to receive info
 '
 '=================================================================
 SUB GetFontInfo (FI AS FontInfo) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrLoaded() AS IFontInfo

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 ' Check that some fonts are loaded:
 IF FGP.TotalLoaded <= 0 THEN
         flSetFontErr cNoFonts
         EXIT SUB
 END IF

 ' All OK, assign values from internal font header:
 FI.FontNum = FGP.CurrentFont
 FI.Ascent = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfAscent
 FI.Points = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPoints
 FI.PixWidth = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPixWidth
 FI.PixHeight = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPixHeight
 FI.Leading = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfInternalLeading
 FI.MaxWidth = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfMaxWidth
 FI.AvgWidth = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfAvgWidth
 FI.FileName = FontHdrLoaded(FGP.CurrentFont).FileName
 FI.FaceName = FontHdrLoaded(FGP.CurrentFont).FaceName

 END SUB

 '=== GetGTextLen - Returns bit length of string
 '
 '  Arguments:
 '     Text$ -  String for which to return length
 '
 '  Return Values:
 '     -1    -  Error (No fonts loaded, probably)
 '
 '     >=0   -  Length of string
 '
 '=================================================================
 FUNCTION GetGTextLen% (Text$) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrLoaded() AS IFontInfo
 SHARED FontData() AS FontDataBlock

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 ' Make sure some fonts are loaded:
 IF FGP.TotalLoaded <= 0 THEN
         flSetFontErr cNoFonts
         GetGTextLen = -1
         EXIT FUNCTION
 END IF

 ' Assume this is a memory font (may override this later):
 CharTblPtr% = FontHdrLoaded(FGP.CurrentFont).DataOffset
 CharTblSeg% = FontHdrLoaded(FGP.CurrentFont).DataSeg

 ' Index into font data array:
 CharTable% = FontHdrLoaded(FGP.CurrentFont).DataSeg

 ' Add together the character lengths from the character table:
 TextLen% = 0
 FOR I% = 1 TO LEN(Text$)

         ' Get character code and translate to Ansi if IBM char set is specifi
         ChVal% = ASC(MID$(Text$, I%, 1))
         IF FGP.CharSet = cIBMChars THEN ChVal% = flANSI(ChVal%)

         ' Convert to default char if out of range:
         IF ChVal% < FGP.FChar OR ChVal% > FGP.LChar THEN ChVal% = FGP.DChar%

         ' Offset into character table for length word:
         CharOffset% = (ChVal% - FGP.FChar) * 4

         ' Peek the data and add it to the text length:
         IF FontHdrLoaded(FGP.CurrentFont).FontSource = cFileFont THEN
                 CharTblPtr% = VARPTR(FontData(CharTable%))
                 CharTblSeg% = VARSEG(FontData(CharTable%))
         END IF
         DEF SEG = CharTblSeg%
         CharLen% = PEEK(CharTblPtr% + CharOffset%) + PEEK(CharTblPtr% + CharO
         TextLen% = TextLen% + CharLen%
 NEXT I%

 GetGTextLen = TextLen%

 END FUNCTION

 '=== GetMaxFonts - Gets the maximum number of fonts that can be registered
 '                  and loaded by the font library:
 '
 '  Arguments:
 '     Registered  -  The maximum number of fonts that can be registered
 '                    by the font library
 '
 '     Loaded      -  The maximum number of fonts that can be loaded by
 '                    by the font library
 '
 '=================================================================
 SUB GetMaxFonts (Registered AS INTEGER, Loaded AS INTEGER)
 SHARED FGP AS GlobalParams

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 ' If SetMaxFonts hasn't been called then make sure the default is
 ' correct:
 flChkMax

 ' Simply return the values of the internal variables for maximum
 ' fonts registered and loaded:
 Registered = FGP.MaxRegistered
 Loaded = FGP.MaxLoaded

 END SUB

 '=== GetFontInfo - Returns useful information about current font
 '
 '  Arguments:
 '     Font  -  Font number (in list of registered fonts) on which to get
 '              information
 '
 '     FI    -  FontInfo type variable to receive info
 '
 '=================================================================
 SUB GetRFontInfo (Font AS INTEGER, FI AS FontInfo) STATIC
 SHARED FontHdrReg() AS IFontInfo

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 ' See that they've specified a valid font:
 IF Font < 0 OR Font > FGP.TotalRegistered THEN
         flSetFontErr cBadFontNumber
         EXIT SUB
 END IF

 ' All OK, assign values from internal font header:
 FI.FontNum = Font
 FI.Ascent = FontHdrReg(Font).FontHeader.dfAscent
 FI.Points = FontHdrReg(Font).FontHeader.dfPoints
 FI.PixWidth = FontHdrReg(Font).FontHeader.dfPixWidth
 FI.PixHeight = FontHdrReg(Font).FontHeader.dfPixHeight
 FI.Leading = FontHdrReg(Font).FontHeader.dfInternalLeading
 FI.MaxWidth = FontHdrReg(Font).FontHeader.dfMaxWidth
 FI.AvgWidth = FontHdrReg(Font).FontHeader.dfAvgWidth
 FI.FileName = FontHdrReg(Font).FileName
 FI.FaceName = FontHdrReg(Font).FaceName

 END SUB

 '=== GetTotalFonts - Gets the total number of fonts that currently registered
 '                    and loaded by the font library:
 '
 '  Arguments:
 '     Registered  -  The total number of fonts registered by the font
 '                    library
 '
 '     Loaded      -  The total number of fonts loaded by the font library
 '
 '=================================================================
 SUB GetTotalFonts (Registered AS INTEGER, Loaded AS INTEGER)
 SHARED FGP AS GlobalParams

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 ' Simply return the values of internal variables:
 Registered = FGP.TotalRegistered
 Loaded = FGP.TotalLoaded

 END SUB

 '=== GTextWindow - Communicates the current WINDOW to fontlib
 '
 '  Arguments:
 '     X1    -  Minimum X value
 '
 '     Y1    -  Minimum Y value
 '
 '     X2    -  Maximum X value
 '
 '     Y2    -  Maximum Y value
 '
 '     Scrn% -  cTRUE means that window Y values increase top to bottom
 '
 '  Remarks:
 '     Calling this with X1=X2 or Y1=Y2 will clear the current
 '     window.
 '
 '=================================================================
 SUB GTextWindow (X1 AS SINGLE, Y1 AS SINGLE, X2 AS SINGLE, Y2 AS SINGLE, Scrn
 SHARED FGP AS GlobalParams

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 ' Save the window values in global variable:
 FGP.WX1 = X1
 FGP.WY1 = Y1
 FGP.WX2 = X2
 FGP.WY2 = Y2
 FGP.WScrn = Scrn%

 ' If window is valid then flag it as set:
 FGP.WindowSet = ((X2 - X1) <> 0) AND ((Y2 - Y1) <> 0)

 END SUB

 '=== LoadFont - Loads one or more fonts according to specification string
 '
 '  Arguments:
 '     SpecTxt$ -  String containing parameters specifying one or more
 '                 fonts to load (see notes below)
 '
 '  Return Values:
 '     The number of fonts loaded
 '
 '  Notes:
 '     A spec. can contain the following parameters in any order.
 '     Parameters are each one character immediately followed by a value
 '     if called for. Multiple specifications may be entered separated
 '     by slash (/) characters. Loadfont will search for the FIRST font in
 '     the list of registered fonts that matches each spec. and load it. If
 '     no font matches a specification registered font number one will be
 '     used. If a given font is selected by more than one spec in the list
 '     it will only be loaded once. When this routine is called all
 '     previous fonts will be discarded:
 '
 '        T  -  followed by a blank-terminated name loads font by
 '              specified name
 '
 '        F  -  No value. Selects only fixed pitch fonts
 '
 '        P  -  No value. Selects only proportional fonts
 '
 '        S  -  Followed by number specifies desired point size
 '
 '        M  -  Followed by number specifies the screen mode font will be
 '              used on. This is used in conjunction with the "S" parameter
 '              above to select appropriately sized font.
 '
 '        H  -  Followed by number specifies the pixel height of
 '              font to select. "S" overrides this.
 '
 '        N  -  Followed by number selects specific font number
 '              from the list of currently registered fonts.
 '
 '        R  -  Selects font stored in RAM memory
 '
 '=================================================================
 FUNCTION LoadFont% (SpecTxt$) STATIC
 SHARED FGP AS GlobalParams
 DIM FSpec AS FontSpec

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding errors and check for valid max limits:
 flClearFontErr

 flChkMax

 ' Make sure there's room to load a font:
 IF FGP.TotalLoaded >= FGP.MaxLoaded THEN
         flSetFontErr cTooManyFonts
         EXIT FUNCTION
 END IF

 ' Make sure there are some registered fonts to look through:
 IF FGP.TotalRegistered <= 0 THEN
         flSetFontErr cNoFonts
         EXIT FUNCTION
 END IF

 ' Process each spec in the spec string:
 Slot% = 1
 ChPos% = 1
 DO UNTIL Slot% > FGP.MaxLoaded

         ' Initialize the spec structure:
         flInitSpec FSpec

         ' Get next spec from string (Found will be false if no spec found):
         SpecStatus% = flGetNextSpec(SpecTxt$, ChPos%, FSpec)
         SELECT CASE SpecStatus%
                 CASE 0:
                 CASE 1: EXIT DO
                 CASE 2: flSetFontErr cBadFontSpec
         END SELECT

         ' Try to match font. Set font to one if none match:
         FontNum% = flMatchFont(FSpec)
         IF FontNum% < 1 THEN
                 flSetFontErr cFontNotFound
                 FontNum% = 1
         END IF

         ' Record font in font load list:
         FontLoadList(Slot%) = FontNum%
         Slot% = Slot% + 1
 LOOP

 ' Now actually get the fonts in the load list:
 FGP.TotalLoaded = flGetFonts(Slot% - 1)
 FGP.CurrentFont = 1

 ' Select the first font by default (pass outstanding font errors around
 ' it):
 HoldErr% = FontErr
 SelectFont cDefaultFont
 IF HoldErr% <> 0 THEN flSetFontErr HoldErr%

 LoadFont = FGP.TotalLoaded

 END FUNCTION

 '=== OutGText - Outputs graphics text to the screen
 '
 '  Arguments:
 '     X        -  X location of upper left of char box
 '
 '     Y        -  Y location of upper left of char box
 '
 '     Text$    -  Text string to output
 '
 '  Return Values:
 '     Length of text output, Values of X and Y are updated
 '
 '=================================================================
 FUNCTION OutGText% (X AS SINGLE, Y AS SINGLE, Text$) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrLoaded() AS IFontInfo

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 ' Make sure fonts are loaded:
 IF FGP.TotalLoaded <= 0 THEN
         flSetFontErr cNoFonts
         EXIT FUNCTION
 END IF

 IF NOT FGP.CharColorInit THEN SetGTextColor cDefaultColor
 IF NOT FGP.CharDirInit THEN SetGTextDir cDefaultDir

 ' Make sure a graphic mode is set:
 flGetCurrentScrnSize XP%, YP%
 IF XP% = 0 THEN EXIT FUNCTION

 ' Save input location to working variables and erase any window setting:
 IX% = PMAP(X, 0)
 IY% = PMAP(Y, 1)
 WINDOW

 ' Map chars to valid ones and output them adding their lengths:
 TextLen% = 0
 FOR Char% = 1 TO LEN(Text$)
         ChVal% = ASC(MID$(Text$, Char%, 1))
         IF FGP.CharSet = cIBMChars THEN ChVal% = flANSI(ChVal%)

         IF FGP.FontSource = cFileFont THEN
                 BitMapPtr% = VARPTR(FontData(FGP.DSeg))
                 BitMapSeg% = VARSEG(FontData(FGP.DSeg))
         ELSE
                 BitMapPtr% = FGP.DOffset
                 BitMapSeg% = FGP.DSeg
         END IF

         CharLen% = flbltchar%(BitMapSeg%, BitMapPtr%, ChVal%, IX%, IY%)

         IX% = IX% + FGP.XPixInc * CharLen%
         IY% = IY% + FGP.YPixInc * CharLen%

         TextLen% = TextLen% + CharLen%
 NEXT Char%

 ' Reset window:
 IF FGP.WindowSet THEN
         IF FGP.WScrn% THEN
                 WINDOW SCREEN (FGP.WX1, FGP.WY1)-(FGP.WX2, FGP.WY2)
         ELSE
                 WINDOW (FGP.WX1, FGP.WY1)-(FGP.WX2, FGP.WY2)
         END IF
 END IF

 ' Update locations
 X = PMAP(IX%, 2)
 Y = PMAP(IY%, 3)

 ' Return total character length:
 OutGText = TextLen%

 END FUNCTION

 '=== RegisterFonts - Loads header information from font resources:
 '
 '  Arguments:
 '     FileName$   -  Path name for font file to register
 '
 '  Return Value:
 '     The number of fonts actually registered
 '
 '  Notes:
 '     Offsets documented in Windows document assume the file's first
 '     byte is byte 0 (zero) and GET assumes the first byte is byte 1 so
 '     many GET locations are expressed in the following code as
 '     a documented offset + 1.
 '
 '=================================================================
 FUNCTION RegisterFonts% (FileName$) STATIC
 SHARED FGP AS GlobalParams
 DIM Byte AS STRING * 1

 ON ERROR GOTO UnexpectedErr

 ' Clear errors and make sure things are initialized:
 flClearFontErr

 flChkMax

 ' Get next available file number:
 FileNum% = FREEFILE

 ' Try to open the file for input first to make sure the file exists. This
 ' is done to avoid creating a zero length file if the file doesn't exist.
 ON ERROR GOTO NoFileErr
 OPEN FileName$ FOR INPUT AS FileNum%
 ON ERROR GOTO UnexpectedErr
 IF FontErr <> 0 THEN
         RegisterFonts = 0
         EXIT FUNCTION
 END IF
 CLOSE FileNum%

 ' File seems to exist, so open it in binary mode:
 OPEN FileName$ FOR BINARY ACCESS READ AS FileNum%

 ' Get the byte that indicates whether this file has a new-style
 ' header on it. If not, then error:
 GET FileNum%, &H18 + 1, Byte
 IF ASC(Byte) <> &H40 THEN
         flSetFontErr cBadFontFile
         CLOSE FileNum%
         EXIT FUNCTION
 END IF

 ' Save the number of fonts currently registered for use later in
 ' calculating the number of fonts registered by this call:
 OldTotal = FGP.TotalRegistered

 ' Get the pointer to the new-style header:
 GET FileNum%, &H3C + 1, Word%
 NewHdr% = Word%

 ' Get pointer to resource table:
 GET FileNum%, Word% + &H22 + 1, Word%
 ResourceEntry# = NewHdr% + Word% + 1

 ' Get the alignment shift count from beginning of table:
 GET FileNum%, ResourceEntry#, Align%

 ' Loop, registering font resources until they have run out:
 DO
         ResType% = flDoNextResource(Align%, FileName$, FileNum%)
         IF FontErr <> 0 THEN EXIT DO
 LOOP UNTIL ResType% = 0

 CLOSE FileNum%

 ' Finally, return number of fonts actually registered:
 RegisterFonts = FGP.TotalRegistered - OldTotal

 END FUNCTION

 '=== RegisterMemFont - Loads header information from a memory-resident font
 '
 '  Arguments:
 '     FontSeg%    -  Segment address of font to register
 '
 '     FontOffset% -  Offset address of font to register
 '
 '  Return Value:
 '     The number of fonts actually registered (0 or 1)
 '
 '  Notes:
 '     Memory resident fonts cannot be stored in BASIC relocatable data
 '     structures (like arrays or non-fixed strings).
 '
 '=================================================================
 FUNCTION RegisterMemFont% (FontSeg AS INTEGER, FontOffset AS INTEGER) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrReg() AS IFontInfo
 DIM FontHeader AS WFHeader

 ON ERROR GOTO UnexpectedErr

 ' Clear error and check max limits:
 flClearFontErr
 flChkMax

 ' Get the font header:
 flMovMem FontHeader, FontSeg, FontOffset, cSizeFontHeader

 ' Only register vector fonts:
 IF FontHeader.dfType AND &H1 <> cBitMapType THEN
         flSetFontErr cBadFontType
         RegisterMemFont = 0
         EXIT FUNCTION
 END IF

 ' See that we're still within MaxRegistered limits:
 IF FGP.TotalRegistered >= FGP.MaxRegistered THEN
         flSetFontErr cTooManyFonts
         RegisterMemFont = 0
         EXIT FUNCTION
 END IF

 ' Go to next "registered" font slot:
 FGP.TotalRegistered = FGP.TotalRegistered + 1

 ' Set font source and save the header:
 FontHdrReg(FGP.TotalRegistered).FontSource = cMemFont
 FontHdrReg(FGP.TotalRegistered).FontHeader = FontHeader

 ' Set font location in memory:
 FontHdrReg(FGP.TotalRegistered).DataSeg = FontSeg
 FontHdrReg(FGP.TotalRegistered).DataOffset = FontOffset + cSizeFontHeader

 ' Get the face name (scan characters until zero byte):
 FaceLoc% = FontOffset + FontHeader.dfFace
 FaceName$ = ""
 DEF SEG = FontSeg
 FOR Char% = 0 TO cMaxFaceName - 1
         Byte% = PEEK(FaceLoc% + Char%)
         IF Byte% = 0 THEN EXIT FOR
         FaceName$ = FaceName$ + CHR$(Byte%)
 NEXT Char%
 FontHdrReg(FGP.TotalRegistered).FaceName = FaceName$

 ' Finally, return number of fonts actually registered:
 RegisterMemFont = 1

 END FUNCTION

 '=== SelectFont - Selects current font from among loaded fonts
 '
 '  Arguments:
 '     FontNum% -  Font number to select
 '
 '=================================================================
 SUB SelectFont (FontNum AS INTEGER) STATIC
 SHARED FGP AS GlobalParams

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 ' If no fonts are loaded then error:
 IF FGP.TotalLoaded <= 0 THEN
         flSetFontErr cNoFonts
         EXIT SUB
 END IF

 ' Now, map the font number to an acceptable one and select it:
 IF FontNum <= 0 THEN
         FGP.CurrentFont = 1
 ELSE
         FGP.CurrentFont = (ABS(FontNum - 1) MOD (FGP.TotalLoaded)) + 1
 END IF

 ' Get First, Last and Default character params from header:
 FGP.FChar = ASC(FontHdrLoaded(FGP.CurrentFont).FontHeader.dfFirstChar)
 FGP.LChar = ASC(FontHdrLoaded(FGP.CurrentFont).FontHeader.dfLastChar)
 FGP.DChar = ASC(FontHdrLoaded(FGP.CurrentFont).FontHeader.dfDefaultChar)
 FGP.CHeight = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPixHeight
 flSetBltParams cSizeFontHeader, FGP.CHeight, FGP.FChar, FGP.LChar, FGP.DChar

 ' Set some other commonly used elements of font info:
 FGP.DSeg = FontHdrLoaded(FGP.CurrentFont).DataSeg
 FGP.DOffset = FontHdrLoaded(FGP.CurrentFont).DataOffset
 FGP.FontSource = FontHdrLoaded(FGP.CurrentFont).FontSource

 END SUB

 '=== SetGCharset - Specifies IBM or Windows char set
 '
 '  Arguments:
 '     Charset%    -  cIBMChars for IBM character mappings
 '                    cWindowsChars for Windows character mappings
 '
 '=================================================================
 SUB SetGCharset (CharSet AS INTEGER) STATIC
 SHARED FGP AS GlobalParams

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 IF CharSet = cWindowsChars THEN
         FGP.CharSet = cWindowsChars
 ELSE
         FGP.CharSet = cIBMChars
 END IF

 END SUB

 '=== SetGTextColor - Sets color for drawing characters
 '
 '  Arguments:
 '     FColor   -  Color number
 '
 '=================================================================
 SUB SetGTextColor (FColor AS INTEGER) STATIC
 SHARED FGP AS GlobalParams

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 FGP.CharColor = ABS(FColor)
 flSetBltColor FGP.CharColor
 FGP.CharColorInit = cTRUE

 END SUB

 '=== SetGTextDir - Sets character direction for OutGText
 '
 '  Arguments:
 '     Dir   -  Character direction:
 '              0 = Horizontal-Right
 '              1 = Vertical-Up
 '              2 = Horizontal-Left
 '              3 = Vertical-Down
 '
 '=================================================================
 SUB SetGTextDir (Dir AS INTEGER) STATIC
 SHARED FGP AS GlobalParams

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 SELECT CASE Dir

         ' Vertical - up
         CASE 1:  FGP.XPixInc% = 0
                                 FGP.YPixInc% = -1
                                 XRowInc% = 1
                                 YRowInc% = 0
                                 FGP.CharDir = 1

         ' Horizontal -left
         CASE 2:  FGP.XPixInc% = -1
                                 FGP.YPixInc% = 0
                                 XRowInc% = 0
                                 YRowInc% = -1
                                 FGP.CharDir = 2

         ' Vertical - down
         CASE 3:  FGP.XPixInc% = 0
                                 FGP.YPixInc% = 1
                                 XRowInc% = -1
                                 YRowInc% = 0
                                 FGP.CharDir = 3

         ' Horizontal - right
         CASE ELSE:  FGP.XPixInc% = 1
                                         FGP.YPixInc% = 0
                                         XRowInc% = 0
                                         YRowInc% = 1
                                         FGP.CharDir = 0
         END SELECT

         ' Call routine to set these increments in the char output routine
         flSetBltDir FGP.XPixInc%, FGP.YPixInc%, XRowInc%, YRowInc%
         FGP.CharDirInit = cTRUE

 END SUB

 '=== SetMaxFonts - Sets the maximum number of fonts that can be registered
 '                  and loaded by the font library:
 '
 '  Arguments:
 '     Registered  -  The maximum number of fonts that can be registered
 '                    by the font library
 '
 '     Loaded      -  The maximum number of fonts that can be loaded by
 '                    by the font library
 '
 '  Return Values:
 '     Sets error if values are not positive. Adjusts MaxReg and MaxLoad
 '     internal values and resets the length of FontHdrReg and FontHdrLoad
 '     arrays if the new value is different from previous one
 '
 '=================================================================
 SUB SetMaxFonts (Registered AS INTEGER, Loaded AS INTEGER) STATIC
 SHARED FGP AS GlobalParams
 SHARED FontHdrReg() AS IFontInfo
 SHARED FontHdrLoaded() AS IFontInfo
 SHARED FontLoadList() AS INTEGER
 SHARED FontData() AS FontDataBlock

 ON ERROR GOTO UnexpectedErr

 ' Clear errors:
 flClearFontErr

 ' Check to see that values are within range:
 IF Registered <= 0 OR Loaded <= 0 THEN
         flSetFontErr cBadFontLimit
         EXIT SUB
 END IF

 ' Values are ostensibly OK. Reset values and redimension arrays:
 ' Reset values for registered fonts:
 FGP.TotalRegistered = 0
 FGP.MaxRegistered = Registered

 ON ERROR GOTO MemErr
 REDIM FontHdrReg(1 TO FGP.MaxRegistered) AS IFontInfo
 ON ERROR GOTO UnexpectedErr

 ' Reset values for loaded fonts:
 FGP.TotalLoaded = 0
 FGP.MaxLoaded = Loaded

 ON ERROR GOTO MemErr
 REDIM FontLoadList(1 TO FGP.MaxLoaded) AS INTEGER
 REDIM FontHdrLoaded(1 TO FGP.MaxLoaded) AS IFontInfo
 ON ERROR GOTO UnexpectedErr

 ' Clear font data array:
 ERASE FontData

 END SUB

 '=== UnRegisterFonts - Erases registered font header array and resets
 '                      total registered fonts to 0:
 '
 '  Arguments:
 '     ErrNum   -  The error number to set FontErr variable to
 '
 '=================================================================
 SUB UnRegisterFonts STATIC
 SHARED FontHdrReg() AS IFontInfo, FGP AS GlobalParams

 ON ERROR GOTO UnexpectedErr

 ' Clear outstanding font errors:
 flClearFontErr

 REDIM FontHdrReg(1 TO 1)  AS IFontInfo
 FGP.MaxRegistered = UBOUND(FontHdrReg, 1)
 FGP.TotalRegistered = 0

 END SUB



 FONTDEMO.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\FONTDEMO.BAS

 '       FONTDEMO.BAS - FONTB demonstration program.
 '
 '  Copyright (C) 1989 Microsoft Corporation, All Rights Reserved
 '
 '  This program demonstrates some of the capabilities of the fonts
 '  toolbox.  It loads font files found in the current directory and
 '  and allows you to select a font for display.
 '
 '  The following font files are provided with BASIC 7.0:
 '     - Raster fonts designed for screen resolution of 640x200
 '           COURA.FON
 '           HELVA.FON
 '           TMSRA.FON
 '     - Raster fonts designed for screen resolution of 640x350
 '           COURB.FON
 '           HELVB.FON
 '           TMSRB.FON
 '     - Raster fonts designed for screen resolution of 640x480
 '           COURE.FON
 '           HELVE.FON
 '           TMSRE.FON
 '
 ' $INCLUDE: 'FONTB.BI'
 CONST TRUE = -1
 CONST FALSE = 0
 DECLARE SUB DriveScreen ()
 DECLARE SUB GetFiles ()
 DECLARE SUB GetModes ()
 DECLARE SUB ShowScreen ()

 DIM SHARED FI AS FontInfo
 DIM SHARED totalmodes AS INTEGER
 DIM SHARED modes(1 TO 13) AS INTEGER
 DIM SHARED fontfiles(1 TO 18) AS STRING
 DIM SHARED totalfonts AS INTEGER
 DIM SHARED currentfont AS INTEGER
 DIM SHARED currentmode AS INTEGER
 GetModes
 GetFiles
 currentfont = 1
 DO
     DriveScreen
     ShowScreen
 LOOP
 END

 '
 'DriveScreen displays the lists of available fonts and screen modes and
 'scrolls through them with arrow keys.
 '
 SUB DriveScreen STATIC
 IF init% = 0 THEN
     set$ = "f"
     max% = totalfonts
     posit% = currentfont
     modedim$ = "320x200640x200720x348640x400              320x200"
     modedim$ = modedim$ + "640x200640x350640x350640x480640x480320x200"

     'Check if monitor supports color or mono.

     SELECT CASE modes(1)
         CASE 13, 9, 8, 7
             mode$ = "color"
         CASE 3, 4, 10
             mode$ = "mono"
         CASE 2
             IF modes(2) = 1 THEN
                 mode$ = "color"
             ELSE
                 mode$ = "mono"
             END IF
     END SELECT
     FOR i% = 1 TO totalmodes
         IF modes(i%) = 4 THEN mode$ = "mono"
     NEXT i%

     'Set colors based on type of monitor.

     SELECT CASE mode$
         CASE "color"
             listfore% = 7
             listback% = 0
             titleon% = 15
             titleoff% = 7
             titleback% = 1
             back% = 1
             high% = 15
         CASE "mono"
             listfore% = 7
             listback% = 0
             titleon% = 0
             titleoff% = 2
             titleback% = 7
             back% = 0
             high% = 7
     END SELECT
     init% = 1
 END IF

 'Display the screen with the current selections.

 SCREEN 0
 WIDTH 80, 25
 LOCATE , , 0: COLOR 0, back%
 PRINT SPACE$(1920)
 LOCATE 2, 1: COLOR high%, back%
 PRINT "  Font Toolbox Demo"
 COLOR titleoff%, back%
 PRINT "  Copyright (C) 1989 Microsoft Corporation"
 LOCATE 22, 1: COLOR titleoff%, back%
 PRINT SPC(55); "<CR> to view fontfile"
 PRINT SPC(55); "ESC to exit"

 GOSUB swaptitles
 GOSUB swaptitles
 FOR i% = 1 TO totalfonts
     LOCATE 5 + i%, 20
     COLOR listfore%, listback%
     PRINT LEFT$(fontfiles(i%) + "       ", 12)
 NEXT i%
 LOCATE 5 + currentfont, 20
 COLOR listback%, listfore%
 PRINT LEFT$(fontfiles(currentfont) + "       ", 12)

 FOR i% = 1 TO totalmodes
     LOCATE 5 + i%, 50
     COLOR listfore%, listback%
     PRINT LEFT$(STR$(modes(i%)) + "   ", 4) + MID$(modedim$, 7 * modes(i%) -
 NEXT i%
 LOCATE 5 + currentmode, 50
 COLOR listback%, listfore%
 PRINT LEFT$(STR$(modes(currentmode)) + "   ", 4) + MID$(modedim$, 7 * modes(c

 'Scroll through choices

 DO
     SELECT CASE INKEY$
         CASE CHR$(0) + CHR$(72)
             GOSUB upone
         CASE CHR$(0) + CHR$(80)
             GOSUB downone
         CASE CHR$(9), CHR$(0) + CHR$(15), CHR$(0) + CHR$(75), CHR$(0) + CHR$(
             GOSUB swaptitles
         CASE CHR$(13), CHR$(32): EXIT DO
         CASE CHR$(27)
           COLOR 15, 0
           CLS
           END
     END SELECT
 LOOP
 EXIT SUB

 swaptitles:
     IF set$ = "f" THEN
         set$ = "m"
         max% = totalmodes
         posit% = currentmode
         LOCATE 5, 20: COLOR titleoff%, back%
         PRINT "Font files:"
         LOCATE 5, 50: COLOR titleon%, titleback%
         PRINT "Screen Modes:"
     ELSEIF set$ = "m" THEN
         set$ = "f"
         max% = totalfonts
         posit% = currentfont
         LOCATE 5, 20: COLOR titleon%, titleback%
         PRINT "Font files:"
         LOCATE 5, 50: COLOR titleoff%, back%
         PRINT "Screen Modes:"
     END IF
 RETURN

 upone:
     oldpos% = posit%
     posit% = (posit% + max% - 2) MOD max% + 1
     GOSUB redraw
 RETURN

 downone:
     oldpos% = posit%
     posit% = posit% MOD max% + 1
     GOSUB redraw
 RETURN

 redraw:
     IF set$ = "f" THEN
         LOCATE 5 + oldpos%, 20
         COLOR listfore%, listback%
         PRINT LEFT$(fontfiles(oldpos%) + "       ", 12)
         LOCATE 5 + posit%, 20
         COLOR listback%, listfore%
         PRINT LEFT$(fontfiles(posit%) + "       ", 12)
         currentfont = posit%
     ELSE
         LOCATE 5 + oldpos%, 50
         COLOR listfore%, listback%
         PRINT LEFT$(STR$(modes(oldpos%)) + "   ", 4) + MID$(modedim$, 7 * mod
         LOCATE 5 + posit%, 50
         COLOR listback%, listfore%
         PRINT LEFT$(STR$(modes(posit%)) + "   ", 4) + MID$(modedim$, 7 * mode
         currentmode = posit%
     END IF
 RETURN

 END SUB

 '
 'GetFiles finds all *.fon files in the current working directory and checks
 'if they are legitimate.  If the files are ok, they are added to files list.
 '
 SUB GetFiles
 SCREEN 0
 WIDTH 80, 25
 tryagain:
 CLS
 PRINT "Checking fontfiles..."
 totalfonts = 0
 X$ = DIR$("*.fon")
 IF X$ = "" THEN
     PRINT "No font files found in current directory."
     PRINT "Push a shell to change directories? [yn]"
     try$ = "a"
     DO UNTIL INSTR(1, "NYny", try$)
         try$ = INPUT$(1)
     LOOP
     SELECT CASE UCASE$(try$)
         CASE "Y"
             PRINT "Type 'EXIT' to return to demo."
             SHELL
             GOTO tryagain
         CASE "N"
             END
     END SELECT
 ELSE
     DO WHILE X$ <> ""
         PRINT "   "; UCASE$(X$); "--";
         SetMaxFonts 10, 10
         Reg% = RegisterFonts(X$)
         IF Reg% = 0 THEN
             PRINT "bad font file"
         ELSE
             totalfonts = totalfonts + 1
             fontfiles(totalfonts) = UCASE$(X$)
             PRINT "OK"
             IF totalfonts = 18 THEN EXIT DO
         END IF
         X$ = DIR$
     LOOP
 END IF
 SLEEP 1
 END SUB

 '
 'GetModes tries all screen modes from 1-13 to see if they are supported.
 'If a mode is supported, it is added to the list of available modes.
 '
 SUB GetModes
 ON LOCAL ERROR GOTO badmode
 nextactive% = 1
 totalmodes = 0
 FOR i% = 13 TO 1 STEP -1
     good% = TRUE
     SCREEN i%
     IF good% THEN
         modes(nextactive%) = i%
         nextactive% = nextactive% + 1
         totalmodes = totalmodes + 1
     END IF
 NEXT i%
 IF totalmodes = 0 THEN
     PRINT "No graphics modes available"
     END
 END IF

 IF modes(1) = 13 THEN
     currentmode = 2
 ELSE
     currentmode = 1
 END IF
 EXIT SUB
 badmode:
     good% = FALSE
     RESUME NEXT
 END SUB

 '
 'ShowScreen displays all the fonts in the current font file and current
 'graphics mode.
 '
 SUB ShowScreen
     SetMaxFonts 10, 10
     TotalReg% = RegisterFonts(fontfiles(currentfont))
     SCREEN modes(currentmode)
     PRINT "Please wait..."

     IF FontErr THEN
         CLS
         PRINT "Unable to continue, FontErr ="; FontErr
         C$ = INPUT$(1)
         EXIT SUB
     END IF
     IF TotalReg% > 10 THEN TotalReg% = 10

     StrLen% = TotalReg% * 3 - 1
     IF TotalReg% > 9 THEN StrLen% = StrLen% + TotalReg% - 9
     LoadStr$ = LEFT$("N1/N2/N3/N4/N5/N6/N7/N8/N9/N10", StrLen%)
     TotalLoad% = LoadFont(LoadStr$)

     SELECT CASE modes(currentmode)
         CASE 1: XS% = 160: YS% = 100
         CASE 2: XS% = 320: YS% = 100
         CASE 3: XS% = 360: YS% = 174
         CASE 4: XS% = 320: YS% = 200
         CASE 7: XS% = 160: YS% = 100
         CASE 8: XS% = 320: YS% = 100
         CASE 9: XS% = 320: YS% = 175
         CASE 10: XS% = 320: YS% = 175
         CASE 11: XS% = 320: YS% = 240
         CASE 12: XS% = 320: YS% = 240
         CASE 13: XS% = 160: YS% = 100
     END SELECT

     prompt$ = "Press any key."
     FOR i% = 1 TO TotalLoad%
         CLS
         SelectFont INT(i%)
         GetFontInfo FI
         SetGTextDir 0
         SetGTextColor 14
         Length% = OutGText(1, 1, RTRIM$(FI.FaceName))
         Length% = OutGText(1, 1 + FI.PixHeight, LTRIM$(STR$(FI.Points) + " Po
         FOR Dir% = 0 TO 3
             SetGTextDir Dir%
             SetGTextColor 15 - Dir%
             SELECT CASE Dir%
                 CASE 0: X% = XS%: Y% = YS% - FI.PixHeight
                 CASE 1: X% = XS% - FI.PixHeight: Y% = YS%
                 CASE 2: X% = XS%: Y% = YS% + FI.PixHeight
                 CASE 3: X% = XS% + FI.PixHeight: Y% = YS%
             END SELECT
             Length% = OutGText(CSNG(X%), CSNG(Y%), "Microsoft")
         NEXT Dir%
         SelectFont 2
         GetFontInfo FI
         SetGTextColor 14
         SetGTextDir 0
         IF i% = TotalLoad% THEN prompt$ = "Press ESC to go on."
         Length% = GetGTextLen(prompt$)
         Length% = OutGText(2 * XS% - Length% - 10, 2 * YS% - FI.PixHeight - 1
         IF i% = TotalLoad% THEN
             DO UNTIL INKEY$ = CHR$(27): LOOP
         ELSE
             a$ = INPUT$(1)
         END IF
     NEXT i%
 END SUB



 GENERAL.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\GENERAL.BAS

 '============================================================================
 '
 '     GENERAL.BAS - General Routines for the User Interface Toolbox in
 '           Microsoft BASIC 7.0, Professional Development System
 '              Copyright (C) 1987-1989, Microsoft Corporation
 '
 '  NOTE:    This sample source code toolbox is intended to demonstrate some
 '           of the extended capabilities of Microsoft BASIC 7.0 Professional
 '           Development system that can help to leverage the professional
 '           developer's time more effectively.  While you are free to use,
 '           modify, or distribute the routines in this module in any way you
 '           find useful, it should be noted that these are examples only and
 '           should not be relied upon as a fully-tested "add-on" library.
 '
 '  PURPOSE: These are the general purpose routines needed by the other
 '           modules in the user interface toolbox.
 '
 '  To create a library and QuickLib containing the routines found
 '  in this file, follow these steps:
 '       BC /X/FS general.bas
 '       LIB general.lib + general + uiasm + qbx.lib;
 '       LINK /Q general.lib, general.qlb,,qbxqlb.lib;
 '  Creating a library and QuickLib for any of the other UI toolbox files
 '  (WINDOW.BAS, MENU.BAS and MOUSE.BAS) is done this way also.
 '
 '  To create a library and QuickLib containing all routines from
 '  the User Interface toolbox follow these steps:
 '       BC /X/FS general.bas
 '       BC /X/FS window.bas
 '       BC /X/FS mouse.bas
 '       BC /X/FS menu.bas
 '       LIB uitb.lib + general + window + mouse + menu + uiasm + qbx.lib;
 '       LINK /Q uitb.lib, uitb.qlb,,qbxqlb.lib;
 '  If you are going to use this QuickLib in conjunction with the font source
 '  code (FONTB.BAS) or the charting source code (CHRTB.BAS), you need to
 '  include the assembly code routines referenced in these files.  For the fon
 '  routines, perform the following LIB command after creating the library but
 '  before creating the QuickLib as described above:
 '       LIB uitb.lib + fontasm;
 '  For the charting routines, perform the following LIB command after creatin
 '  the library but before creating the QuickLib as described above:
 '       LIB uitb.lib + chrtasm;
 '
 '============================================================================

 DEFINT A-Z

 '$INCLUDE: 'general.bi'
 '$INCLUDE: 'mouse.bi'

 FUNCTION AltToASCII$ (kbd$)
     ' =======================================================================
     ' Converts Alt+A to A,Alt+B to B, etc.  You send it a string.  The right
     ' most character is compared to the string below, and is converted to
     ' the proper character.
     ' =======================================================================
     index = INSTR("xyz{|}~Çü !" + CHR$(34) + "#$%&,-./012éâ", RI

     IF index = 0 THEN
         AltToASCII = ""
     ELSE
         AltToASCII = MID$("1234567890QWERTYUIOPASDFGHJKLZXCVBNM-=", index, 1)
     END IF

 END FUNCTION

 SUB Box (row1, col1, row2, col2, fore, back, border$, fillFlag) STATIC

     '=======================================================================
     '  Use default border if an illegal border$ is passed
     '=======================================================================

     IF LEN(border$) < 9 THEN
         t$ = "┌─┐│ │└─┘"
     ELSE
         t$ = border$
     END IF

     ' =======================================================================
     ' Check coordinates for validity, then draw box
     ' =======================================================================

     IF col1 <= (col2 - 2) AND row1 <= (row2 - 2) AND col1 >= MINCOL AND row1
         MouseHide
         BoxWidth = col2 - col1 + 1
         BoxHeight = row2 - row1 + 1
         LOCATE row1, col1
         COLOR fore, back
         PRINT LEFT$(t$, 1); STRING$(BoxWidth - 2, MID$(t$, 2, 1)); MID$(t$, 3
         LOCATE row2, col1
         PRINT MID$(t$, 7, 1); STRING$(BoxWidth - 2, MID$(t$, 8, 1)); MID$(t$,

         FOR a = row1 + 1 TO row1 + BoxHeight - 2
             LOCATE a, col1
             PRINT MID$(t$, 4, 1);

             IF fillFlag THEN
                 PRINT STRING$(BoxWidth - 2, MID$(t$, 5, 1));
             ELSE
                 LOCATE a, col1 + BoxWidth - 1
             END IF

             PRINT MID$(t$, 6, 1);
         NEXT a
         LOCATE row1 + 1, col1 + 1
         MouseShow
     END IF

 END SUB

 SUB GetBackground (row1, col1, row2, col2, buffer$) STATIC

     ' =======================================================================
     ' Create enough space in buffer$ to hold the screen info behind the box
     ' Then, call GetCopyBox to store the background in buffer$
     ' =======================================================================

     IF row1 >= 1 AND row2 <= MAXROW AND col1 >= 1 AND col2 <= MAXCOL THEN
         Wid = col2 - col1 + 1
         Hei = row2 - row1 + 1
         size = 4 + (2 * Wid * Hei)
         buffer$ = SPACE$(size)

         CALL GetCopyBox(row1, col1, row2, col2, buffer$)
     END IF

 END SUB

 FUNCTION GetShiftState (bit)

     ' =======================================================================
     ' Returns the shift state after calling interrupt 22
     '    bit 0 : right shift
     '        1 : left shift
     '        2 : ctrl key
     '        3 : alt key
     '        4 : scroll lock
     '        5 : num lock
     '        6 : caps lock
     '        7 : insert state
     ' =======================================================================

     IF bit >= 0 AND bit <= 7 THEN
         DIM regs AS RegType
         regs.ax = 2 * 256
         INTERRUPT 22, regs, regs

         IF regs.ax AND 2 ^ bit THEN
             GetShiftState = TRUE
         ELSE
             GetShiftState = FALSE
         END IF
     ELSE
         GetShiftState = FALSE
     END IF

 END FUNCTION

 SUB PutBackground (row, col, buffer$)

     ' =======================================================================
     ' This sub checks the boundries before executing the put command
     ' =======================================================================

     IF row >= 1 AND row <= MAXROW AND col >= 1 AND col <= MAXCOL THEN
         CALL PutCopyBox(row, col, buffer$)
     END IF

 END SUB

 SUB scroll (row1, col1, row2, col2, lines, attr)

     ' =======================================================================
     ' Make sure coordinates are in proper order
     ' =======================================================================

     IF row1 > row2 THEN
         SWAP row1, row2
     END IF

     IF col1 > col2 THEN
         SWAP col1, col2
     END IF

      ' ======================================================================
      ' If coordinates are valid, prepare registers, and call interrupt
      ' ======================================================================

     IF row1 >= MINROW AND row2 <= MAXROW AND col1 >= MINCOL AND col2 <= MAXCO
         DIM regs AS RegType

         IF lines < 0 THEN
             regs.ax = 256 * 7 + (-lines)
             regs.bx = 256 * attr
             regs.cx = 256 * (row1 - 1) + (col1 - 1)
             regs.dx = 256 * (row2 - 1) + (col2 - 1)
         ELSE
             regs.ax = 256 * 6 + lines
             regs.bx = 256 * (attr MOD 8) * 16
             regs.cx = 256 * (row1 - 1) + (col1 - 1)
             regs.dx = 256 * (row2 - 1) + (col2 - 1)
         END IF

         INTERRUPT 16, regs, regs
     END IF

 END SUB



 INDEX.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\INDEX.BAS

 DEFINT A-Z

 ' Define the symbolic constants used globally in the program:
 CONST FALSE = 0, TRUE = NOT FALSE

 ' Define a record structure for random-file records:
 TYPE StockItem
         PartNumber AS STRING * 6
         Description AS STRING * 20
         UnitPrice AS SINGLE
         Quantity AS INTEGER
 END TYPE

 ' Define a record structure for each element of the index:
 TYPE IndexType
         RecordNumber AS INTEGER
         PartNumber AS STRING * 6
 END TYPE

 ' Declare procedures that will be called:
 DECLARE FUNCTION Filter$ (Prompt$)
 DECLARE FUNCTION FindRecord% (PartNumber$, RecordVar AS StockItem)

 DECLARE SUB AddRecord (RecordVar AS StockItem)
 DECLARE SUB InputRecord (RecordVar AS StockItem)
 DECLARE SUB PrintRecord (RecordVar AS StockItem)
 DECLARE SUB SortIndex ()
 DECLARE SUB ShowPartNumbers ()
 ' Define a buffer (using the StockItem type)
 ' and define and dimension the index array:
 DIM StockRecord AS StockItem, index(1 TO 100) AS IndexType

 ' Open the random-access file:
 OPEN "STOCK.DAT" FOR RANDOM AS #1 LEN = LEN(StockRecord)

 ' Calculate number of records in the file:
 NumberOfRecords = LOF(1) \ LEN(StockRecord)

 ' If there are records, read them and build the index:
 IF NumberOfRecords <> 0 THEN
         FOR RecordNumber = 1 TO NumberOfRecords

                 ' Read the data from a new record in the file:
                 GET #1, RecordNumber, StockRecord

                 ' Place part number and record number in index:
                 index(RecordNumber).RecordNumber = RecordNumber
                 index(RecordNumber).PartNumber = StockRecord.PartNumber
         NEXT

         SortIndex            ' Sort index in part-number order.
 END IF

 DO                      ' Main-menu loop.
         CLS
         PRINT "(A)dd records."
         PRINT "(L)ook up records."
         PRINT "(Q)uit program."
         PRINT
         LOCATE , , 1
         PRINT "Type your choice (A, L, or Q) here: ";

         ' Loop until user presses, A, L, or Q:
         DO
                 Choice$ = UCASE$(INPUT$(1))
         LOOP WHILE INSTR("ALQ", Choice$) = 0

         ' Branch according to choice:
         SELECT CASE Choice$
                 CASE "A"
          AddRecord StockRecord
                 CASE "L"
          IF NumberOfRecords = 0 THEN
                  PRINT : PRINT "No records in file yet. ";
                  PRINT "Press any key to continue.";
                  Pause$ = INPUT$(1)
          ELSE
                  InputRecord StockRecord
          END IF
                 CASE "Q"          ' End program.
         END SELECT
 LOOP UNTIL Choice$ = "Q"

 CLOSE #1                ' All done, close file and end.
 END
 ' ======================== ADDRECORD ======================
 ' Adds records to the file from input typed at the keyboard
 ' =========================================================
 ' ========================= FILTER ========================
 '       Filters all non-numeric characters from a string
 '       and returns the filtered string
 ' =========================================================
 ' ======================= FINDRECORD ===================
 '  Uses a binary search to locate a record in the index
 ' ======================================================
 ' ======================= PRINTRECORD =====================
 '                Prints a record on the screen
 ' =========================================================
 ' ===================== SHOWPARTNUMBERS ===================
 ' Prints an index of all the part numbers in the upper part
 ' of the screen
 ' =========================================================
 ' ========================= SORTINDEX =====================
 '                Sorts the index by part number
 ' =========================================================


 SUB AddRecord (RecordVar AS StockItem) STATIC
         SHARED index() AS IndexType, NumberOfRecords
         DO
                 CLS
                 INPUT "Part Number: ", RecordVar.PartNumber
                 INPUT "Description: ", RecordVar.Description

                 ' Call the Filter$ FUNCTION to input price & quantity:
                 RecordVar.UnitPrice = VAL(Filter$("Unit Price : "))
                 RecordVar.Quantity = VAL(Filter$("Quantity   : "))

                 NumberOfRecords = NumberOfRecords + 1

                 PUT #1, NumberOfRecords, RecordVar

                 index(NumberOfRecords).RecordNumber = NumberOfRecords
                 index(NumberOfRecords).PartNumber = RecordVar.PartNumber
                 PRINT : PRINT "Add another? ";
                 OK$ = UCASE$(INPUT$(1))
         LOOP WHILE OK$ = "Y"

         SortIndex            ' Sort index file again.
 END SUB

 FUNCTION Filter$ (Prompt$) STATIC
         ValTemp2$ = ""
         PRINT Prompt$;                    ' Print the prompt passed.
         INPUT "", ValTemp1$               ' Input a number as

         StringLength = LEN(ValTemp1$)     ' Get the string's length.
         FOR I% = 1 TO StringLength        ' Go through the string,
                 Char$ = MID$(ValTemp1$, I%, 1) ' one character at a time.

                 ' Is the character a valid part of a number (i.e.,
                 ' a digit or a decimal point)?  If yes, add it to
                 ' the end of a new string:
                 IF INSTR(".0123456789", Char$) > 0 THEN
                         ValTemp2$ = ValTemp2$ + Char$

                 ' Otherwise, check to see if it's a lowercase "l",
                 ' since typewriter users may enter a one that way:
                 ELSEIF Char$ = "l" THEN
                         ValTemp2$ = ValTemp2$ + "1" ' Change the "l" to a "1"
                 END IF
         NEXT I%

         Filter$ = ValTemp2$               ' Return filtered string.

 END FUNCTION

 FUNCTION FindRecord% (Part$, RecordVar AS StockItem) STATIC
         SHARED index() AS IndexType, NumberOfRecords

         ' Set top and bottom bounds of search:
         TopRecord = NumberOfRecords
         BottomRecord = 1

         ' Search until top of range is less than bottom:
         DO UNTIL (TopRecord < BottomRecord)

                 ' Choose midpoint:
                 Midpoint = (TopRecord + BottomRecord) \ 2

                 ' Test to see if it's the one wanted (RTRIM$()
                 ' trims trailing blanks from a fixed string):
                 Test$ = RTRIM$(index(Midpoint).PartNumber)

                 ' If it is, exit loop:
                 IF Test$ = Part$ THEN
          EXIT DO

                 ' Otherwise, if what we're looking for is greater,
                 ' move bottom up:
                 ELSEIF Part$ > Test$ THEN
          BottomRecord = Midpoint + 1

                 ' Otherwise, move the top down:
                 ELSE
          TopRecord = Midpoint - 1
                 END IF
         LOOP

         ' If part was found, input record from file using
         ' pointer in index and set FindRecord% to TRUE:
         IF Test$ = Part$ THEN
                 GET #1, index(Midpoint).RecordNumber, RecordVar
                 FindRecord% = TRUE

         ' Otherwise, if part was not found, set FindRecord%
         ' to FALSE:
         ELSE
                 FindRecord% = FALSE
         END IF
 END FUNCTION

 ' ======================= INPUTRECORD =====================
 '    First, INPUTRECORD calls SHOWPARTNUMBERS, which prints
 '    a menu of part numbers on the top of the screen. Next,
 '    INPUTRECORD prompts the user to enter a part number.
 '    Finally, it calls the FINDRECORD and PRINTRECORD
 '    procedures to find and print the given record.
 ' =========================================================
 SUB InputRecord (RecordVar AS StockItem) STATIC
         CLS
         ShowPartNumbers      ' Call the ShowPartNumbers SUB.

         ' Print data from specified records
         ' on the bottom part of the screen:
         DO
                 PRINT "Type a part number listed above ";
                 INPUT "(or Q to quit) and press <ENTER>: ", Part$
                 IF UCASE$(Part$) <> "Q" THEN
          IF FindRecord(Part$, RecordVar) THEN
                  PrintRecord RecordVar
          ELSE
                  PRINT "Part not found."
          END IF
                 END IF
                 PRINT STRING$(40, "_")
         LOOP WHILE UCASE$(Part$) <> "Q"

         VIEW PRINT   ' Restore the text viewport to entire screen.
 END SUB

 SUB PrintRecord (RecordVar AS StockItem) STATIC
         PRINT "Part Number: "; RecordVar.PartNumber
         PRINT "Description: "; RecordVar.Description
         PRINT USING "Unit Price :$$###.##"; RecordVar.UnitPrice
         PRINT "Quantity   :"; RecordVar.Quantity
 END SUB

 SUB ShowPartNumbers STATIC
         SHARED index() AS IndexType, NumberOfRecords

         CONST NUMCOLS = 8, COLWIDTH = 80 \ NUMCOLS

         ' At the top of the screen, print a menu indexing all
         ' the part numbers for records in the file. This menu is
         ' printed in columns of equal length (except possibly the
         ' last column, which may be shorter than the others):
         ColumnLength = NumberOfRecords
         DO WHILE ColumnLength MOD NUMCOLS
                 ColumnLength = ColumnLength + 1
         LOOP
         ColumnLength = ColumnLength \ NUMCOLS
         Column = 1
         RecordNumber = 1
 DO UNTIL RecordNumber > NumberOfRecords
                 FOR Row = 1 TO ColumnLength
          LOCATE Row, Column
          PRINT index(RecordNumber).PartNumber
          RecordNumber = RecordNumber + 1
          IF RecordNumber > NumberOfRecords THEN EXIT FOR
                 NEXT Row
                 Column = Column + COLWIDTH
         LOOP

         LOCATE ColumnLength + 1, 1
         PRINT STRING$(80, "_")       ' Print separator line.

         ' Scroll information about records below the part-number
         ' menu (this way, the part numbers are not erased):
         VIEW PRINT ColumnLength + 2 TO 24
 END SUB

 SUB SortIndex STATIC
         SHARED index() AS IndexType, NumberOfRecords

         ' Set comparison offset to half the number of records
         ' in index:
         Offset = NumberOfRecords \ 2

         ' Loop until offset gets to zero:
         DO WHILE Offset > 0
                 Limit = NumberOfRecords - Offset
                 DO

          ' Assume no switches at this offset:
          Switch = FALSE

          ' Compare elements and switch ones out of order:
          FOR I = 1 TO Limit
                  IF index(I).PartNumber > index(I + Offset).PartNumber THEN
                          SWAP index(I), index(I + Offset)
                          Switch = I
                  END IF
          NEXT I

          ' Sort on next pass only to where
          ' last switch was made:
          Limit = Switch
                 LOOP WHILE Switch

                 ' No switches at last offset, try one half as big:
                 Offset = Offset \ 2
         LOOP
 END SUB



 MANDEL.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MANDEL.BAS

 DEFINT A-Z           ' Default variable type is integer.

 DECLARE        SUB ShiftPalette ()
 DECLARE        SUB WindowVals (WL%, WR%, WT%, WB%)
 DECLARE        SUB ScreenTest (EM%, CR%, VL%, VR%, VT%, VB%)

 CONST FALSE = 0, TRUE = NOT FALSE ' Boolean constants

 ' Set maximum number of iterations per point:
 CONST MAXLOOP =        30, MAXSIZE = 1000000

 DIM PaletteArray(15)
 FOR I =        0 TO 15: PaletteArray(I) = I: NEXT I

 ' Call WindowVals to get coordinates of window corners:
 WindowVals WLeft, WRight, WTop,        WBottom

 ' Call ScreenTest to find out if this is an EGA machine
 ' and get coordinates of viewport corners:
 ScreenTest EgaMode, ColorRange,        VLeft, VRight, VTop, VBottom

 ' Define viewport and corresponding window:
 VIEW (VLeft, VTop)-(VRight, VBottom), 0, ColorRange
 WINDOW (WLeft, WTop)-(WRight, WBottom)

 LOCATE 24, 10 : PRINT "Press any key to quit.";

 XLength        = VRight - VLeft
 YLength        = VBottom - VTop
 ColorWidth = MAXLOOP \ ColorRange

 ' Loop through each pixel in viewport and calculate
 ' whether or not it is in the Mandelbrot Set:
 FOR Y =        0 TO YLength           ' Loop through every line
                            ' in the viewport.
    LogicY = PMAP(Y, 3)           ' Get the pixel's view
                            ' y-coordinate.
    PSET        (WLeft,        LogicY)           ' Plot leftmost pixel in the
    OldColor = 0                   ' Start with background color.

    FOR X = 0 TO        XLength           ' Loop through every pixel
                            ' in the line.
       LogicX = PMAP(X, 2)  ' Get the pixel's view
                            ' x-coordinate.
       MandelX& = LogicX
       MandelY& = LogicY
       ' Do the calculations to see if this point
       ' is in the Mandelbrot Set:
       FOR I = 1        TO MAXLOOP
          RealNum& = MandelX& * MandelX&
          ImagNum& = MandelY& * MandelY&
          IF (RealNum& + ImagNum&) >= MAXSIZE THEN EXIT FOR
          MandelY& = (MandelX& * MandelY&) \ 250 + LogicY
          MandelX& = (RealNum& - ImagNum&) \ 500 + LogicX
       NEXT I

       '        Assign a color to the point:
       PColor = I \ ColorWidth

       '        If color has changed, draw a line from
       ' the last point referenced to the new point,
       '        using the old color:
       IF PColor        <> OldColor THEN
          LINE -(LogicX, LogicY), (ColorRange - OldColor)
          OldColor = PColor
       END IF

       IF INKEY$        <> "" THEN END
    NEXT        X

    ' Draw the last line        segment        to the right edge
    ' of the viewport:
    LINE        -(LogicX, LogicY), (ColorRange - OldColor)

    ' If        this is        an EGA machine,        shift the palette after
    ' drawing each line:
    IF EgaMode THEN ShiftPalette
 NEXT Y

 DO
    ' Continue shifting the palette
    ' until the user presses a key:
    IF EgaMode THEN ShiftPalette
 LOOP WHILE INKEY$ = ""

 SCREEN 0, 0                ' Restore the screen to text mode,
 WIDTH 80                ' 80 columns.
 END

 BadScreen:                ' Error handler that is invoked if
    EgaMode = FALSE        ' there is no EGA graphics card
    RESUME NEXT
 ' ====================== ShiftPalette =====================
 '    Rotates the palette by one each time it is called
 ' =========================================================

 SUB ShiftPalette STATIC
    SHARED PaletteArray(), ColorRange

    FOR I = 1 TO        ColorRange
       PaletteArray(I) =        (PaletteArray(I) MOD ColorRange) + 1
    NEXT        I
    PALETTE USING PaletteArray(0)

 END SUB
 ' ======================= ScreenTest ======================
 '    Uses a SCREEN 8 statement as a test to see if user has
 '    EGA hardware. If this causes an error, the EM flag is
 '    set to FALSE, and the screen is set with SCREEN 1.

 '    Also sets values for corners of viewport (VL = left,
 '    VR = right, VT = top, VB = bottom), scaled with the
 '    correct aspect ratio so viewport is a perfect square.
 ' =========================================================

 SUB ScreenTest (EM, CR,        VL, VR,        VT, VB) STATIC
    EM =        TRUE
    ON ERROR GOTO BadScreen
    SCREEN 8, 1
    ON ERROR GOTO 0

    IF EM THEN                        ' No error, SCREEN 8 is OK.
       VL = 110: VR = 529
       VT = 5: VB = 179
       CR = 15                        ' 16 colors (0 - 15)

    ELSE                                ' Error, so use SCREEN 1.
       SCREEN 1,        1
       VL = 55: VR = 264
       VT = 5: VB = 179
       CR = 3                        ' 4 colors (0 - 3)
    END IF

 END SUB
 ' ======================= WindowVals ======================
 '     Gets window corners as input from the user, or sets
 '     values for the corners if there is no input
 ' =========================================================

 SUB WindowVals (WL, WR,        WT, WB)        STATIC
    CLS
    PRINT "This program prints the graphic representation of"
    PRINT "the complete Mandelbrot Set. The default window"
    PRINT "is from (-1000,625) to (250,-625). To zoom in on"
    PRINT "part of the figure, input coordinates inside"
    PRINT "this window."
    PRINT "Press <ENTER> to see the default window or"
    PRINT "any other key to input window coordinates: ";
    LOCATE , , 1
    Resp$ = INPUT$(1)

    ' User didn't press ENTER, so input window corners:
    IF Resp$ <> CHR$(13)        THEN
       PRINT
       INPUT "x-coordinate of upper-left corner: ", WL
       DO
          INPUT "x-coordinate of lower-right corner: ", WR
          IF WR <= WL THEN
             PRINT "Right corner must be greater than left corner."
          END IF
       LOOP WHILE WR <= WL
       INPUT "y-coordinate of upper-left corner: ", WT
       DO
          INPUT "y-coordinate of lower-right corner: ", WB
          IF WB >= WT THEN
             PRINT "Bottom corner must be less than top corner."
          END IF
       LOOP WHILE WB >= WT

    ' User pressed ENTER, so set default values:
    ELSE
       WL = -1000
       WR = 250
       WT = 625
       WB = -625
    END IF
 END SUB



 MATB.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MATB.BAS

 '*** MATB.BAS - Matrix Math Routines for the Matrix Math Toolbox in
 '           Microsoft BASIC 7.0, Professional Development System
 '              Copyright (C) 1987-1989, Microsoft Corporation
 '
 '  NOTE:  This sample source code toolbox is intended to demonstrate some
 '  of the extended capabilities of Microsoft BASIC 7.0 Professional Developme
 '  system that can help to leverage the professional developer's time more
 '  effectively.  While you are free to use, modify, or distribute the routine
 '  in this module in any way you find useful, it should be noted that these a
 '  examples only and should not be relied upon as a fully-tested "add-on"
 '  library.
 '
 '  Purpose:
 'This toolbox contains routines which perform elementary operations on system
 'of linear equations represented as matrices.  The functions return integer
 'error codes in the name and results in the parameter list.  The functions
 'matbs?% and matlu?% found in this module are intended for internal use only.
 'Error codes returned:
 '     0  no error                     -1  matrix not invertible
 '    -2  matrix not square            -3  inner dimensions different
 '    -4  matrix dimensions different  -5  result matrix dimensioned incorrect
 '    any other codes returned are standard BASIC errors
 '
 '-------------------------------------------------------------------
 'MatDet, MatSEqn, and MatInv all use LU-decomposition to implement Gaussian
 'elimination.  A brief explanation of what is meant by an LU matrix is given
 'below, followed by simplified versions of the two internal routines used to
 'do all elimination.
 '
 'What is meant by an LU matrix:
 'An upper triangle matrix (one with all nonzero entries on or above the main
 'diagonal) can be solved immediately.  The goal of Gaussian elimination is to
 'transform a non upper triangle system into an equivalent triangular one.
 '
 'Given a system of equations represented in matrix form by Ax=b, we need a
 'linear transformation L such that LA=U where U is and upper triangular matri
 'Then Ux=LAx=Lb and Ux=Lb is an upper triangular system.
 '
 'This library explicitly calculates U, but L is never saved in its own array.
 'When we do a row operation to create a zero below the main diagonal, we no
 'longer need to save that value because we know it is zero.  This leaves the
 'space available to save the multiplier used in the row operation.  When
 'elimination is completed (ie, when the matrix is upper triangular), these
 'multipliers give us a complete record of what we did to A to make it upper
 'triangular.  This is equivalent to saying the multipliers represent L.  We n
 'have a U and an L stored in the same matrix!  This type of matrix will be
 'referred to as an LU matrix, or just LU.
 '
 'The following code fragments get LU and backsolve Ux=Lb.  The actual routine
 'used in the toolbox are much more involved because they implement total
 'pivoting and implicit row scaling to reduce round off errors.  However, all
 'extras (pivoting, scaling, error checking) are extraneous to the main routin
 'which total only 20 lines.  If you are unfamilar with this type of matrix ma
 'gaining an understanding of these 20 lines is a very good introduction.  Try
 'working through a 2x2 or 3x3 example by hand to see what is happening.  The
 'numerical techniques used to reduce round off error will not be discussed.
 '
 '-------------------------------------------------------------------
 'Given the coefficient matrix A(1 TO N, 1 TO N) and the vector b(1 TO N),
 'the following fragments will find x(1 TO N) satisfying Ax=b using Gaussian
 'elimination.
 '
 'matlu:
 'Perform row operations to get all zeroes below the main diagonal.
 'Define Rj(1 TO N) to be the vector corresponding to the jth row of A.
 'Let Rrow = Rrow + m*Rpvt where m = -Rrow(pvt)/Rpvt(pvt).
 'Then A(row, pvt)=0.
 '
 '** FOR pvt = 1 TO (N - 1)
 '**    FOR row = (pvt + 1) TO N
 '**       'Save m for later use in the space just made 0.
 '**       A(row, pvt) = -A(row, pvt) / A(pvt, pvt)
 '**       'Do the row operation.
 '**       FOR col = (pvt + 1) TO N
 '**          A(row, col) = A(row, col) + A(row, pvt) * A(pvt, col)
 '**       NEXT col
 '**    NEXT row
 '** NEXT pvt
 '
 'matbs:
 'Do the same row operations on b using the multipliers saved in A.
 '
 '** FOR pvt = 1 TO (N - 1)
 '**    FOR row = (pvt + 1) TO N
 '**       b(row) = b(row) + A(row, pvt) * b(pvt)
 '**    NEXT row
 '** NEXT pvt
 '
 'Backsolve Ux=Lb to find x.
 '                               N
 'For r = N to 1, x(r) = [b(r) - Σ (A(r,c)*x(c))]/A(r,r)
 '                              c=r+1
 '** FOR row = N TO 1 STEP -1
 '**    x(row) = b(row)
 '**    FOR col = (row + 1) TO N
 '**       x(row) = x(row) - A(row, col) * x(col)
 '**    NEXT col
 '**    x(row) = x(row) / A(row, row)
 '** NEXT row
 '
 '===================================================================
 '$INCLUDE: 'matb.bi'
 DECLARE FUNCTION matbsD% (A() AS DOUBLE, b() AS DOUBLE, x() AS DOUBLE)
 DECLARE FUNCTION matbsS% (A() AS SINGLE, b() AS SINGLE, x() AS SINGLE)
 DECLARE FUNCTION matluD% (A() AS DOUBLE)
 DECLARE FUNCTION matluS% (A() AS SINGLE)
 DIM SHARED lo AS INTEGER, up AS INTEGER
 DIM SHARED continue AS INTEGER, count AS INTEGER
 DIM SHARED rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 END

 '=======================MatAddC%====================================
 'MatAddC% adds two currency type matrices and places the sum in
 'the first.
 '
 'Parameters: matrices Alpha,Beta
 '
 'Returns: Alpha() = Alpha() + Beta()
 '===================================================================
 FUNCTION MatAddC% (Alpha() AS CURRENCY, Beta() AS CURRENCY)
 ON LOCAL ERROR GOTO cadderr: MatAddC% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and add elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)
    NEXT col%
 NEXT row%
 caddexit:
 EXIT FUNCTION
 cadderr:
    MatAddC% = (ERR + 5) MOD 200 - 5
    RESUME caddexit
 END FUNCTION

 '=======================MatAddD%====================================
 'MatAddD% adds two double precision matrices and places the sum in
 'the first.
 '
 'Parameters: matrices Alpha,Beta
 '
 'Returns: Alpha() = Alpha() + Beta()
 '===================================================================
 FUNCTION MatAddD% (Alpha() AS DOUBLE, Beta() AS DOUBLE)
 ON LOCAL ERROR GOTO dadderr: MatAddD% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and add elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)
    NEXT col%
 NEXT row%
 daddexit:
 EXIT FUNCTION
 dadderr:
    MatAddD% = (ERR + 5) MOD 200 - 5
    RESUME daddexit
 END FUNCTION

 '=======================MatAddI%====================================
 'MatAddI% adds two integer matrices and places the sum in
 'the first.
 '
 'Parameters: matrices Alpha,Beta
 '
 'Returns: Alpha() = Alpha() + Beta()
 '===================================================================
 FUNCTION MatAddI% (Alpha() AS INTEGER, Beta() AS INTEGER)
 ON LOCAL ERROR GOTO iadderr: MatAddI% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and add elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)
    NEXT col%
 NEXT row%
 iaddexit:
 EXIT FUNCTION
 iadderr:
    MatAddI% = (ERR + 5) MOD 200 - 5
    RESUME iaddexit
 END FUNCTION

 '=======================MatAddL%====================================
 'MatAddL% adds two long integer matrices and places the sum in
 'the first.
 '
 'Parameters: matrices Alpha,Beta
 '
 'Returns: Alpha() = Alpha() + Beta()
 '===================================================================
 FUNCTION MatAddL% (Alpha() AS LONG, Beta() AS LONG)
 ON LOCAL ERROR GOTO ladderr: MatAddL% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and add elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)
    NEXT col%
 NEXT row%
 laddexit:
 EXIT FUNCTION
 ladderr:
    MatAddL% = (ERR + 5) MOD 200 - 5
    RESUME laddexit
 END FUNCTION

 '=======================MatAddS%====================================
 'MatAddS% adds two single precision matrices and places the sum in
 'the first.
 '
 'Parameters: matrices Alpha,Beta
 '
 'Returns: Alpha() = Alpha() + Beta()
 '===================================================================
 FUNCTION MatAddS% (Alpha() AS SINGLE, Beta() AS SINGLE)
 ON LOCAL ERROR GOTO sadderr: MatAddS% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and add elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)
    NEXT col%
 NEXT row%
 saddexit:
 EXIT FUNCTION
 sadderr:
    MatAddS% = (ERR + 5) MOD 200 - 5
    RESUME saddexit
 END FUNCTION

 '========================matbsD=====================================
 'matbsD% takes a matrix in LU form, found by matluD%, and a vector b
 'and solves the system Ux=Lb for x. matrices A,b,x are double precision.
 '
 'Parameters: LU matrix in A, corresponding pivot vectors in rpvt and cpvt,
 '            right side in b
 '
 'Returns: solution in x, b is modified, rest unchanged
 '===================================================================
 FUNCTION matbsD% (A() AS DOUBLE, b() AS DOUBLE, x() AS DOUBLE)
 ON LOCAL ERROR GOTO dbserr: matbsD% = 0
 'do row operations on b using the multipliers in L to find Lb
 FOR pvt% = lo TO (up - 1)
    c% = cpvt(pvt%)
    FOR row% = (pvt% + 1) TO up
       r% = rpvt(row%)
       b(r%) = b(r%) + A(r%, c%) * b(rpvt(pvt%))
    NEXT row%
 NEXT pvt%
 'backsolve Ux=Lb to find x
 FOR row% = up TO lo STEP -1
    c% = cpvt(row%)
    r% = rpvt(row%)
    x(c%) = b(r%)
    FOR col% = (row% + 1) TO up
       x(c%) = x(c%) - A(r%, cpvt(col%)) * x(cpvt(col%))
    NEXT col%
    x(c%) = x(c%) / A(r%, c%)
 NEXT row%
 dbsexit:
 EXIT FUNCTION
 dbserr:
    matbsD% = ERR
    RESUME dbsexit
 END FUNCTION

 '========================matbsS=====================================
 'matbsS% takes a matrix in LU form, found by matluS%, and a vector b
 'and solves the system Ux=Lb for x. matrices A,b,x are single precision.
 '
 'Parameters: LU matrix in A, corresponding pivot vectors in rpvt and cpvt,
 '            right side in b
 '
 'Returns: solution in x, b is modified, rest unchanged
 '===================================================================
 FUNCTION matbsS% (A() AS SINGLE, b() AS SINGLE, x() AS SINGLE)
 ON LOCAL ERROR GOTO sbserr: matbsS% = 0
 'do row operations on b using the multipliers in L to find Lb
 FOR pvt% = lo TO (up - 1)
    c% = cpvt(pvt%)
    FOR row% = (pvt% + 1) TO up
       r% = rpvt(row%)
       b(r%) = b(r%) + A(r%, c%) * b(rpvt(pvt%))
    NEXT row%
 NEXT pvt%
 'backsolve Ux=Lb to find x
 FOR row% = up TO lo STEP -1
    c% = cpvt(row%)
    r% = rpvt(row%)
    x(c%) = b(r%)
    FOR col% = (row% + 1) TO up
       x(c%) = x(c%) - A(r%, cpvt(col%)) * x(cpvt(col%))
    NEXT col%
    x(c%) = x(c%) / A(r%, c%)
 NEXT row%
 sbsexit:
 EXIT FUNCTION
 sbserr:
    matbsS% = ERR
    RESUME sbsexit
 END FUNCTION

 '========================MatDetC%===================================
 'MatDetC% finds the determinant of a square, currency type matrix
 '
 'Parameters: A(n x n) matrix, det@ to return the determinant
 '
 'Returns: matrix A in LU form, determinant
 '===================================================================
 FUNCTION MatDetC% (A() AS CURRENCY, det@)
 ON LOCAL ERROR GOTO cdeterr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 'make temporary double precision matrix to find pivots
 DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS DOUBLE
 FOR row% = lo TO up
    FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)
       Tmp(row%, col%) = CDBL(A(row%, col%))
    NEXT col%
 NEXT row%
 errcode% = matluD%(Tmp())              'Get LU matrix
 IF NOT continue THEN
    IF errcode% = 199 THEN det@ = 0@
    ERROR errcode%
 ELSE
    detD# = 1#                          '+/- determinant = product of the pivo
    FOR pvt% = lo TO up
       detD# = detD# * Tmp(rpvt(pvt%), cpvt(pvt%))
    NEXT pvt%                           'count contains the total number of ro
    det@ = (-1@) ^ count * CCUR(detD#)  'and column switches due to pivoting.
    IF errcode% THEN ERROR errcode%     'multiply the determinant by -1 for
 END IF                                 'each switch.
 cdetexit:
 ERASE rpvt, cpvt, Tmp
 MatDetC% = errcode%
 EXIT FUNCTION
 cdeterr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME cdetexit
 END FUNCTION

 '========================MatDetD%===================================
 'MatDetD% finds the determinant of a square, double precision matrix
 '
 'Parameters: A(n x n) matrix, det# to return the determinant
 '
 'Returns: matrix A in LU form, determinant
 '===================================================================
 FUNCTION MatDetD% (A() AS DOUBLE, det#)
 ON LOCAL ERROR GOTO ddeterr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 errcode% = matluD%(A())             'Get LU matrix
 IF NOT continue THEN
    IF errcode% = 199 THEN det# = 0#
    ERROR errcode%
 ELSE
    det# = 1#                        '+/- determinant = product of the pivots
    FOR pvt% = lo TO up
       det# = det# * A(rpvt(pvt%), cpvt(pvt%))
    NEXT pvt%                         'count contains the total number of row
    det# = (-1) ^ count * det#        'and column switches due to pivoting.
    IF errcode% THEN ERROR errcode%   'multiply the determinant by -1 for
 END IF                               'each switch
 ddetexit:
 ERASE rpvt, cpvt
 MatDetD% = errcode%
 EXIT FUNCTION
 ddeterr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME ddetexit
 END FUNCTION

 '========================MatDetI%===================================
 'MatDetI% finds the determinant of a square, integer matrix
 '
 'Parameters: A(n x n) matrix, det% to return the determinant
 '
 'Returns: matrix A unchanged, determinant
 '===================================================================
 FUNCTION MatDetI% (A() AS INTEGER, det%)
 ON LOCAL ERROR GOTO ideterr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 'make temporary single precision matrix to find pivots
 DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS SINGLE
 FOR row% = lo TO up
    FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)
       Tmp(row%, col%) = CSNG(A(row%, col%))
    NEXT col%
 NEXT row%
 errcode% = matluS%(Tmp())              'Get LU matrix
 IF NOT continue THEN
    IF errcode% = 199 THEN det% = 0
    ERROR errcode%
 ELSE
    detS! = 1!                          '+/- determinant = product of the pivo
    FOR pvt% = lo TO up
       detS! = detS! * Tmp(rpvt(pvt%), cpvt(pvt%))
    NEXT pvt%                           'count contains the total number of ro
    det% = (-1) ^ count * CINT(detS!)   'and column switches due to pivoting.
    IF errcode% THEN ERROR errcode%     'multiply the determinant by -1 for
 END IF                                 'each switch
 idetexit:
 ERASE rpvt, cpvt, Tmp
 MatDetI% = errcode%
 EXIT FUNCTION
 ideterr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME idetexit
 END FUNCTION

 '========================MatDetL%===================================
 'MatDetL% finds the determinant of a square, long integer matrix
 '
 'Parameters: A(n x n) matrix, det& to return the determinant
 '
 'Returns: matrix A unchanged, determinant
 '===================================================================
 FUNCTION MatDetL% (A() AS LONG, det&)
 ON LOCAL ERROR GOTO ldeterr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 'make temporary double precision matrix to find pivots
 DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS DOUBLE
 FOR row% = lo TO up
    FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)
       Tmp(row%, col%) = CDBL(A(row%, col%))
    NEXT col%
 NEXT row%
 errcode% = matluD%(Tmp())              'Get LU matrix
 IF NOT continue THEN
    IF errcode% = 199 THEN det& = 0&
    ERROR errcode%
 ELSE
    detD# = 1#                          '+/- determinant = product of the pivo
    FOR pvt% = lo TO up
       detD# = detD# * Tmp(rpvt(pvt%), cpvt(pvt%))
    NEXT pvt%                           'count contains the total number of ro
    det& = (-1&) ^ count * CLNG(detD#)  'and column switches due to pivoting.
    IF errcode% THEN ERROR errcode%     'multiply the determinant by -1 for
 END IF                                 'each switch
 ldetexit:
 ERASE rpvt, cpvt, Tmp
 MatDetL% = errcode%
 EXIT FUNCTION
 ldeterr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME ldetexit
 END FUNCTION

 '========================MatDetS%===================================
 'MatDetS% finds the determinant of a square, single precision matrix
 '
 'Parameters: A(n x n) matrix, det! to return the determinant
 '
 'Returns: matrix A in LU form, determinant
 '===================================================================
 FUNCTION MatDetS% (A() AS SINGLE, det!)
 ON LOCAL ERROR GOTO sdeterr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 errcode% = matluS%(A())                'Get LU matrix
 IF NOT continue THEN
    IF errcode% = 199 THEN det! = 0!
    ERROR errcode%
 ELSE
    det! = 1!                           '+/- determinant = product of the pivo
    FOR pvt% = lo TO up
       det! = det! * A(rpvt(pvt%), cpvt(pvt%))
    NEXT pvt%                           'count contains the total number of ro
    det! = (-1) ^ count * det!          'and column switches due to pivoting.
    IF errcode% THEN ERROR errcode%     'multiply the determinant by -1 for
 END IF                                 'each switch
 sdetexit:
 ERASE rpvt, cpvt
 MatDetS% = errcode%
 EXIT FUNCTION
 sdeterr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME sdetexit
 END FUNCTION

 '========================MatInvC%===================================
 'MatInvC% uses the matluD% and matbsD procedures to invert a square, currency
 'type matrix.  Let e(N) contain all zeroes except for the jth position, which
 'is 1.  Then the jth column of A^-1 is x, where Ax=e.
 '
 'Parameters: A(n x n) matrix
 '
 'Returns: A^-1
 '===================================================================
 FUNCTION MatInvC% (A() AS CURRENCY)
 ON LOCAL ERROR GOTO cinverr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 'duplicate A() in a double precision work matrix, Tmp()
 DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS DOUBLE
 DIM e(lo TO up) AS DOUBLE, x(lo TO up) AS DOUBLE
 FOR row% = lo TO up
    FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)
       Tmp(row%, col%) = CDBL(A(row%, col%))
    NEXT col%
 NEXT row%
 errcode% = matluD%(Tmp())                    'Put LU in Tmp
 IF NOT continue THEN ERROR errcode%
 FOR col% = lo TO up                          'Find A^-1 one column at a time
    e(col%) = 1#
    bserrcode% = matbsD%(Tmp(), e(), x())
    IF bserrcode% THEN ERROR bserrcode%
    FOR row% = lo TO up
       A(row%, col%) = CCUR(x(row%))          'Put the column into A
       e(row%) = 0#
    NEXT row%
 NEXT col%
 IF errcode% THEN ERROR errcode%
 cinvexit:
 ERASE Tmp, e, x, rpvt, cpvt
 MatInvC% = errcode%
 EXIT FUNCTION
 cinverr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME cinvexit
 END FUNCTION

 '========================MatInvD%===================================
 'MatInvD% uses the matluD% and matbsD procedures to invert a square, double
 'precision matrix.  Let e(N) contain all zeroes except for the jth position,
 'which is 1.  Then the jth column of A^-1 is x, where Ax=e.
 '
 'Parameters: A(n x n) matrix
 '
 'Returns: A^-1
 '===================================================================
 FUNCTION MatInvD% (A() AS DOUBLE)
 ON LOCAL ERROR GOTO dinverr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 DIM Ain(lo TO up, lo TO up) AS DOUBLE
 DIM e(lo TO up) AS DOUBLE, x(lo TO up) AS DOUBLE
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 errcode% = matluD%(A())                     'Get LU matrix
 IF NOT continue THEN ERROR errcode%
 FOR col% = lo TO up                         'Find A^-1 one column at a time
    e(col%) = 1#
    bserrcode% = matbsD%(A(), e(), x())
    IF bserrcode% THEN ERROR bserrcode%
    FOR row% = lo TO up
       Ain(row%, col%) = x(row%)
       e(row%) = 0#
    NEXT row%
 NEXT col%
 FOR col% = lo TO up                         'Put A^-1 in A
    FOR row% = lo TO up
       A(row%, col%) = Ain(row%, col%)
    NEXT row%
 NEXT col%
 IF errcode% THEN ERROR errcode%
 dinvexit:
 ERASE e, x, Ain, rpvt, cpvt
 MatInvD% = errcode%
 EXIT FUNCTION
 dinverr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME dinvexit
 END FUNCTION

 '========================MatInvS%===================================
 'MatInvS% uses the matluS% and matbsS procedures to invert a square, single
 'precision matrix.  Let e(N) contain all zeroes except for the jth position,
 'which is 1. Then the jth column of A^-1 is x, where Ax=e.
 '
 'Parameters: A(n x n) matrix
 '
 'Returns: A^-1
 '===================================================================
 FUNCTION MatInvS% (A() AS SINGLE)
 ON LOCAL ERROR GOTO sinverr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 DIM Ain(lo TO up, lo TO up) AS SINGLE
 DIM e(lo TO up) AS SINGLE, x(lo TO up) AS SINGLE
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 errcode% = matluS%(A())                     'Get LU matrix
 IF NOT continue THEN ERROR errcode%
 FOR col% = lo TO up                         'find A^-1 one column at a time
    e(col%) = 1!
    bserrcode% = matbsS%(A(), e(), x())
    IF bserrcode% THEN ERROR bserrcode%
    FOR row% = lo TO up
       Ain(row%, col%) = x(row%)
       e(row%) = 0!
    NEXT row%
 NEXT col%
 FOR col% = lo TO up                         'put A^-1 in A
    FOR row% = lo TO up
       A(row%, col%) = Ain(row%, col%)
    NEXT row%
 NEXT col%
 IF errcode% THEN ERROR errcode%
 sinvexit:
 ERASE e, x, Ain, rpvt, cpvt
 MatInvS% = errcode%
 EXIT FUNCTION
 sinverr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME sinvexit
 END FUNCTION

 '========================matluD%====================================
 'matluD% does Gaussian elimination with total pivoting to put a square, doubl
 'precision matrix in LU form. The multipliers used in the row operations to
 'create zeroes below the main diagonal are saved in the zero spaces.
 '
 'Parameters: A(n x n) matrix, rpvt(n) and cpvt(n) permutation vectors
 '            used to index the row and column pivots
 '
 'Returns: A in LU form with corresponding pivot vectors; the total number of
 '         pivots in count, which is used to find the sign of the determinant.
 '===================================================================
 FUNCTION matluD% (A() AS DOUBLE)
 ON LOCAL ERROR GOTO dluerr: errcode% = 0
 'Checks if A is square, returns error code if not
 IF NOT (lo = LBOUND(A, 2) AND up = UBOUND(A, 2)) THEN ERROR 198
 DIM rownorm(lo TO up) AS DOUBLE
 count = 0                            'initialize count, continue
 continue = -1
 FOR row% = lo TO up                  'initialize rpvt and cpvt
    rpvt(row%) = row%
    cpvt(row%) = row%
    rownorm(row%) = 0#                'find the row norms of A()
    FOR col% = lo TO up
       rownorm(row%) = rownorm(row%) + ABS(A(row%, col%))
    NEXT col%
    IF rownorm(row%) = 0# THEN        'if any rownorm is zero, the matrix
       continue = 0                   'is singular, set error, exit and
       ERROR 199                      'do not continue
    END IF
 NEXT row%
 FOR pvt% = lo TO (up - 1)
 'Find best available pivot
    max# = 0#                         'checks all values in rows and columns n
    FOR row% = pvt% TO up             'already used for pivoting and saves the
       r% = rpvt(row%)                'largest absolute number and its positio
       FOR col% = pvt% TO up
          c% = cpvt(col%)
          temp# = ABS(A(r%, c%)) / rownorm(r%)
          IF temp# > max# THEN
             max# = temp#
             bestrow% = row%          'save the position of new max#
             bestcol% = col%
          END IF
       NEXT col%
    NEXT row%
    IF max# = 0# THEN                 'if no nonzero number is found, A is
       continue = 0                   'singular, send back error, do not conti
       ERROR 199
    ELSEIF pvt% > 1 THEN              'check if drop in pivots is too much
       IF max# < (deps# * oldmax#) THEN errcode% = 199
    END IF
    oldmax# = max#
    IF rpvt(pvt%) <> rpvt(bestrow%) THEN
       count = count + 1                    'if a row or column pivot is
       SWAP rpvt(pvt%), rpvt(bestrow%)      'necessary, count it and permute
    END IF                                  'rpvt or cpvt. Note: the rows and
    IF cpvt(pvt%) <> cpvt(bestcol%) THEN    'columns are not actually switched
       count = count + 1                    'only the order in which they are
       SWAP cpvt(pvt%), cpvt(bestcol%)      'used.
    END IF
 'Eliminate all values below the pivot
    rp% = rpvt(pvt%)
    cp% = cpvt(pvt%)
    FOR row% = (pvt% + 1) TO up
       r% = rpvt(row%)
       A(r%, cp%) = -A(r%, cp%) / A(rp%, cp%)  'save multipliers
       FOR col% = (pvt% + 1) TO up
          c% = cpvt(col%)                      'complete row operations
          A(r%, c%) = A(r%, c%) + A(r%, cp%) * A(rp%, c%)
       NEXT col%
    NEXT row%
 NEXT pvt%
 IF A(rpvt(up), cpvt(up)) = 0# THEN
    continue = 0                      'if last pivot is zero or pivot drop is
    ERROR 199                         'too large, A is singular, send back err
 ELSEIF (ABS(A(rpvt(up), cpvt(up))) / rownorm(rpvt(up))) < (deps# * oldmax#) T
    errcode% = 199                    'if pivot is not identically zero then
 END IF                               'continue remains TRUE
 IF errcode% THEN ERROR errcode%
 dluexit:
 matluD% = errcode%
 EXIT FUNCTION
 dluerr:
    IF errcode% < 199 THEN continue = 0
    errcode% = ERR
    RESUME dluexit
 END FUNCTION

 '========================matluS%====================================
 'matluS% does Gaussian elimination with total pivoting to put a square, singl
 'precision matrix in LU form. The multipliers used in the row operations to
 'create zeroes below the main diagonal are saved in the zero spaces.
 '
 'Parameters: A(n x n) matrix, rpvt(n) and cpvt(n) permutation vectors
 '            used to index the row and column pivots
 '
 'Returns: A in LU form with corresponding pivot vectors; the total number of
 '         pivots in count, which is used to find the sign of the determinant.
 '===================================================================
 FUNCTION matluS% (A() AS SINGLE)
 ON LOCAL ERROR GOTO sluerr: errcode% = 0
 'Checks if A is square, returns error code if not
 IF NOT (lo = LBOUND(A, 2) AND up = UBOUND(A, 2)) THEN ERROR 198
 DIM rownorm(lo TO up) AS SINGLE
 count = 0                            'initialize count, continue
 continue = -1
 FOR row% = lo TO up                  'initialize rpvt and cpvt
    rpvt(row%) = row%
    cpvt(row%) = row%
    rownorm(row%) = 0!                'find the row norms of A()
    FOR col% = lo TO up
       rownorm(row%) = rownorm(row%) + ABS(A(row%, col%))
    NEXT col%
    IF rownorm(row%) = 0! THEN        'if any rownorm is zero, the matrix
       continue = 0                   'is singular, set error, exit and do
       ERROR 199                      'not continue
    END IF
 NEXT row%
 FOR pvt% = lo TO (up - 1)
 'Find best available pivot
    max! = 0!                         'checks all values in rows and columns n
    FOR row% = pvt% TO up             'already used for pivoting and finds the
       r% = rpvt(row%)                'number largest in absolute value relati
       FOR col% = pvt% TO up          'to its row norm
          c% = cpvt(col%)
          temp! = ABS(A(r%, c%)) / rownorm(r%)
          IF temp! > max! THEN
             max! = temp!
             bestrow% = row%          'save the position of new max!
             bestcol% = col%
          END IF
       NEXT col%
    NEXT row%
    IF max! = 0! THEN                 'if no nonzero number is found, A is
       continue = 0                   'singular, send back error, do not conti
       ERROR 199
    ELSEIF pvt% > 1 THEN              'check if drop in pivots is too much
       IF max! < (seps! * oldmax!) THEN errcode% = 199
    END IF
    oldmax! = max!
    IF rpvt(pvt%) <> rpvt(bestrow%) THEN
       count = count + 1                    'if a row or column pivot is
       SWAP rpvt(pvt%), rpvt(bestrow%)      'necessary, count it and permute
    END IF                                  'rpvt or cpvt. Note: the rows and
    IF cpvt(pvt%) <> cpvt(bestcol%) THEN    'columns are not actually switched
       count = count + 1                    'only the order in which they are
       SWAP cpvt(pvt%), cpvt(bestcol%)      'used.
    END IF
 'Eliminate all values below the pivot
    rp% = rpvt(pvt%)
    cp% = cpvt(pvt%)
    FOR row% = (pvt% + 1) TO up
       r% = rpvt(row%)
       A(r%, cp%) = -A(r%, cp%) / A(rp%, cp%)  'save multipliers
       FOR col% = (pvt% + 1) TO up
          c% = cpvt(col%)                      'complete row operations
          A(r%, c%) = A(r%, c%) + A(r%, cp%) * A(rp%, c%)
       NEXT col%
    NEXT row%
 NEXT pvt%
 IF A(rpvt(up), cpvt(up)) = 0! THEN
    continue = 0                      'if last pivot is zero or pivot drop is
    ERROR 199                         'too large, A is singular, send back err
 ELSEIF (ABS(A(rpvt(up), cpvt(up))) / rownorm(rpvt(up))) < (seps! * oldmax!) T
    errcode% = 199                    'if pivot is not identically zero then
 END IF                               'continue remains TRUE
 IF errcode% THEN ERROR errcode%
 sluexit:
 matluS% = errcode%
 EXIT FUNCTION
 sluerr:
    errcode% = ERR
    IF errcode% < 199 THEN continue = 0
    RESUME sluexit
 END FUNCTION

 '=======================MatMultC%===================================
 'MatMultC% multiplies two currency type matrices and places the
 'product in a result matrix
 '
 'Parameters: matrices Alpha,Beta,Gamma
 '
 'Returns: Gamma() = Alpha() * Beta()
 '===================================================================
 FUNCTION MatMultC% (Alpha() AS CURRENCY, Beta() AS CURRENCY, Gamma() AS CURRE
 ON LOCAL ERROR GOTO cmulterr: MatMultC% = 0
 IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta,
    ERROR 197                   'check inside dimensions
 ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(
    ERROR 195                   'check dimensions of result matrix
 END IF
 'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)
 FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)
    FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)
       Gamma(row%, col%) = 0@
       FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
          Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(
       NEXT inside%
    NEXT col%
 NEXT row%
 cmultexit:
 EXIT FUNCTION
 cmulterr:
    MatMultC% = (ERR + 5) MOD 200 - 5
    RESUME cmultexit
 END FUNCTION

 '=======================MatMultD%===================================
 'MatMultD% multiplies two double precision matrices and places the
 'product in a result matrix
 '
 'Parameters: matrices Alpha,Beta,Gamma
 '
 'Returns: Gamma() = Alpha() * Beta()
 '===================================================================
 FUNCTION MatMultD% (Alpha() AS DOUBLE, Beta() AS DOUBLE, Gamma() AS DOUBLE)
 ON LOCAL ERROR GOTO dmulterr: MatMultD% = 0
 IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta,
    ERROR 197                   'check inside dimensions
 ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(
    ERROR 195                   'check dimensions of result matrix
 END IF
 'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)
 FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)
    FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)
       Gamma(row%, col%) = 0#
       FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
          Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(
       NEXT inside%
    NEXT col%
 NEXT row%
 dmultexit:
 EXIT FUNCTION
 dmulterr:
    MatMultD% = (ERR + 5) MOD 200 - 5
    RESUME dmultexit
 END FUNCTION

 '=======================MatMultI%===================================
 'MatMultI% multiplies two integer matrices and places the product in
 'a result matrix
 '
 'Parameters: matrices Alpha,Beta,Gamma
 '
 'Returns: Gamma() = Alpha() * Beta()
 '===================================================================
 FUNCTION MatMultI% (Alpha() AS INTEGER, Beta() AS INTEGER, Gamma() AS INTEGER
 ON LOCAL ERROR GOTO imulterr: MatMultI% = 0
 IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta,
    ERROR 197                   'check inside dimensions
 ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(
    ERROR 195                   'check dimensions of result matrix
 END IF
 'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)
 FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)
    FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)
       Gamma(row%, col%) = 0
       FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
          Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(
       NEXT inside%
    NEXT col%
 NEXT row%
 imultexit:
 EXIT FUNCTION
 imulterr:
    MatMultI% = (ERR + 5) MOD 200 - 5
    RESUME imultexit
 END FUNCTION

 '=======================MatMultL%===================================
 'MatMultL% multiplies two long integer matrices and places the product
 'in a result matrix
 '
 'Parameters: matrices Alpha,Beta,Gamma
 '
 'Returns: Gamma() = Alpha() * Beta()
 '===================================================================
 FUNCTION MatMultL% (Alpha() AS LONG, Beta() AS LONG, Gamma() AS LONG)
 ON LOCAL ERROR GOTO lmulterr: MatMultL% = 0
 IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta,
    ERROR 197                   'check inside dimensions
 ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(
    ERROR 195                   'check dimensions of result matrix
 END IF
 'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)
 FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)
    FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)
       Gamma(row%, col%) = 0&
       FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
          Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(
       NEXT inside%
    NEXT col%
 NEXT row%
 lmultexit:
 EXIT FUNCTION
 lmulterr:
    MatMultL% = (ERR + 5) MOD 200 - 5
    RESUME lmultexit
 END FUNCTION

 '=======================MatMultS%===================================
 'MatMultS% multiplies two single precision matrices and places the
 'product in a result matrix
 '
 'Parameters: matrices Alpha,Beta,Gamma
 '
 'Returns: Gamma() = Alpha() * Beta()
 '===================================================================
 FUNCTION MatMultS% (Alpha() AS SINGLE, Beta() AS SINGLE, Gamma() AS SINGLE)
 ON LOCAL ERROR GOTO smulterr: MatMultS% = 0
 IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta,
    ERROR 197                   'check inside dimensions
 ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(
    ERROR 195                   'check dimensions of result matrix
 END IF
 'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)
 FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)
    FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)
       Gamma(row%, col%) = 0!
       FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
          Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(
       NEXT inside%
    NEXT col%
 NEXT row%
 smultexit:
 EXIT FUNCTION
 smulterr:
    MatMultS% = (ERR + 5) MOD 200 - 5
    RESUME smultexit
 END FUNCTION

 '========================MatSEqnC%==================================
 'MatSEqnC% solves a system of n linear equations, Ax=b, and puts the
 'answer in b. A is first put in LU form by matluC%, then matbsC is called
 'to solve the system.  matrices A,b are currency type.
 '
 'Parameters: A(n x n) contains coefficient matrix, b(N) contains the right si
 '
 'Returns: A in LU form, solution in b
 '===================================================================
 FUNCTION MatSEqnC% (A() AS CURRENCY, b() AS CURRENCY)
 ON LOCAL ERROR GOTO cseqnerr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 'duplicate A(), b() in temporary double precision matrices Tmp(), btmp()
 DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS DOUBLE
 DIM x(lo TO up) AS DOUBLE, btmp(lo TO up) AS DOUBLE
 FOR row% = lo TO up
    FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)
       Tmp(row%, col%) = CDBL(A(row%, col%))
    NEXT col%
 NEXT row%
 errcode% = matluD%(Tmp())                   'Get LU matrix
 IF NOT continue THEN ERROR errcode%
 'check dimensions of b, make double precision copy if ok.
 IF (lo <> LBOUND(b)) OR (up <> UBOUND(b)) THEN ERROR 197
 FOR row% = lo TO up
    btmp(row%) = CDBL(b(row%))
 NEXT row%
 bserrcode% = matbsD%(Tmp(), btmp(), x())    'Backsolve system
 IF bserrcode% THEN ERROR bserrcode%
 FOR row% = lo TO up
    b(row%) = CCUR(x(row%))                  'Put solution in b for return
 NEXT row%
 IF errcode% THEN ERROR errcode%
 cseqnexit:
 ERASE Tmp, btmp, x, rpvt, cpvt
 MatSEqnC% = errcode%
 EXIT FUNCTION
 cseqnerr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME cseqnexit
 END FUNCTION

 '========================MatSEqnD%==================================
 'MatSEqnD% solves a system of n linear equations, Ax=b, and puts the
 'answer in b. A is first put in LU form by matluD%, then matbsD is called
 'to solve the system.  matrices A,b are double precision.
 '
 'Parameters: A(n x n) contains coefficient matrix, b(N) contains the right si
 '
 'Returns: A in LU form, solution in b
 '===================================================================
 FUNCTION MatSEqnD% (A() AS DOUBLE, b() AS DOUBLE)
 ON LOCAL ERROR GOTO dseqnerr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 DIM x(lo TO up) AS DOUBLE
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 errcode% = matluD%(A())                      'Get LU matrix
 IF NOT continue THEN ERROR errcode%
 'check dimensions of b
 IF (lo <> LBOUND(b)) OR (up <> UBOUND(b)) THEN ERROR 197
 bserrcode% = matbsD%(A(), b(), x())          'Backsolve system
 IF bserrcode% THEN ERROR bserrcode%
 FOR row% = lo TO up
    b(row%) = x(row%)                         'Put solution in b for return
 NEXT row%
 IF errcode% THEN ERROR errcode%
 dseqnexit:
 ERASE x, rpvt, cpvt
 MatSEqnD% = errcode%
 EXIT FUNCTION
 dseqnerr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME dseqnexit
 END FUNCTION

 '========================MatSEqnS%==================================
 'MatSEqnS% solves a system of n linear equations, Ax=b, and puts the
 'answer in b. A is first put in LU form by matluS%, then matbsS is called
 'to solve the system.  matrices A,b are single precision.
 '
 'Parameters: A(n x n) contains coefficient matrix, b(N) contains the right si
 '
 'Returns: A in LU form, solution in b
 '===================================================================
 FUNCTION MatSEqnS% (A() AS SINGLE, b() AS SINGLE)
 ON LOCAL ERROR GOTO sseqnerr: errcode% = 0
 lo = LBOUND(A, 1)
 up = UBOUND(A, 1)
 DIM x(lo TO up) AS SINGLE
 REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER
 errcode% = matluS%(A())                      'Get LU matrix
 IF NOT continue THEN ERROR errcode%
 'check dimensions of b
 IF (lo <> LBOUND(b)) OR (up <> UBOUND(b)) THEN ERROR 197
 bserrcode% = matbsS%(A(), b(), x())          'Backsolve system
 IF bserrcode% THEN ERROR bserrcode%
 FOR row% = lo TO up
    b(row%) = x(row%)                         'Put solution in b for return
 NEXT row%
 IF errcode% THEN ERROR errcode%
 sseqnexit:
 ERASE x, rpvt, cpvt
 MatSEqnS% = errcode%
 EXIT FUNCTION
 sseqnerr:
    errcode% = (ERR + 5) MOD 200 - 5
    RESUME sseqnexit
 END FUNCTION

 '=======================MatSubC%====================================
 'MatSubC% takes the difference of two currency type matrices and
 'places the result in the first.
 '
 'Params: matrices Alpha,Beta
 '
 'Returns: Alpha=Alpha-Beta
 '===================================================================
 FUNCTION MatSubC% (Alpha() AS CURRENCY, Beta() AS CURRENCY)
 ON LOCAL ERROR GOTO csuberr: MatSubC% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and subtract elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)
    NEXT col%
 NEXT row%
 csubexit:
 EXIT FUNCTION
 csuberr:
    MatSubC% = (ERR + 5) MOD 200 - 5
    RESUME csubexit:
 END FUNCTION

 '=======================MatSubD%====================================
 'MatSubD% takes the difference of two double precision matrices and
 'places the result in the first.
 '
 'Parameters: matrices Alpha,Beta
 '
 'Returns: Alpha() = Alpha() - Beta()
 '===================================================================
 FUNCTION MatSubD% (Alpha() AS DOUBLE, Beta() AS DOUBLE)
 ON LOCAL ERROR GOTO dsuberr: MatSubD% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and subtract elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)
    NEXT col%
 NEXT row%
 dsubexit:
 EXIT FUNCTION
 dsuberr:
    MatSubD% = (ERR + 5) MOD 200 - 5
    RESUME dsubexit:
 END FUNCTION

 '=======================MatSubI%====================================
 'MatSubI% takes the difference of two integer matrices and places the
 'result in the first.
 '
 'Parameters: matrices Alpha,Beta
 '
 'Returns: Alpha() = Alpha() - Beta()
 '===================================================================
 FUNCTION MatSubI% (Alpha() AS INTEGER, Beta() AS INTEGER)
 ON LOCAL ERROR GOTO isuberr: MatSubI% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and subtract elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)
    NEXT col%
 NEXT row%
 isubexit:
 EXIT FUNCTION
 isuberr:
    MatSubI% = (ERR + 5) MOD 200 - 5
    RESUME isubexit:
 END FUNCTION

 '=======================MatSubL%====================================
 'MatSubL% takes the difference of two long integer matrices and places
 'the result in the first.
 '
 'Parameters: matrices Alpha,Beta
 '
 'Returns: Alpha() = Alpha() - Beta()
 '===================================================================
 FUNCTION MatSubL% (Alpha() AS LONG, Beta() AS LONG)
 ON LOCAL ERROR GOTO lsuberr: MatSubL% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and subtract elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)
    NEXT col%
 NEXT row%
 lsubexit:
 EXIT FUNCTION
 lsuberr:
    MatSubL% = (ERR + 5) MOD 200 - 5
    RESUME lsubexit:
 END FUNCTION

 '=======================MatSubS%====================================
 'MatSubS% takes the difference of two single precision matrices and
 'places the result in the first.
 '
 'Parameters: matrices Alpha,Beta
 '
 'Returns: Alpha() = Alpha() - Beta()
 '===================================================================
 FUNCTION MatSubS% (Alpha() AS SINGLE, Beta() AS SINGLE)
 ON LOCAL ERROR GOTO ssuberr: MatSubS% = 0
 'check if Alpha, Beta have same dimensions if not, exit and send back error
 IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta,
 'loop through and subtract elements
 FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)
    FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)
       Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)
    NEXT col%
 NEXT row%
 ssubexit:
 EXIT FUNCTION
 ssuberr:
    MatSubS% = (ERR + 5) MOD 200 - 5
    RESUME ssubexit:
 END FUNCTION



 MENU.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MENU.BAS

 '============================================================================
 '
 '     MENU.BAS - Pull-down Menu Routines for the User Interface Toolbox in
 '           Microsoft BASIC 7.0, Professional Development System
 '              Copyright (C) 1987-1989, Microsoft Corporation
 '
 '  NOTE:    This sample source code toolbox is intended to demonstrate some
 '           of the extended capabilities of Microsoft BASIC 7.0 Professional
 '           Development system that can help to leverage the professional
 '           developer's time more effectively.  While you are free to use,
 '           modify, or distribute the routines in this module in any way you
 '           find useful, it should be noted that these are examples only and
 '           should not be relied upon as a fully-tested "add-on" library.
 '
 '  PURPOSE: These are the routines which provide support for the pull-down
 '           menus in the user interface toolbox.
 '
 '  For information on creating a library and QuickLib from the routines
 '  contained in this file, read the comment header of GENERAL.BAS.
 '
 '============================================================================

 DEFINT A-Z

 '$INCLUDE: 'general.bi'
 '$INCLUDE: 'mouse.bi'
 '$INCLUDE: 'menu.bi'

 COMMON SHARED /uitools/ GloMenu    AS MenuMiscType
 COMMON SHARED /uitools/ GloTitle() AS MenuTitleType
 COMMON SHARED /uitools/ GloItem()  AS MenuItemType

 FUNCTION MenuCheck (action%) STATIC

     SELECT CASE action

     '=======================================================================
     ' This simulates "polling" for a menu event.  If a menu event occured,
     ' GloMenu.currMenu and .currItem are set.  When MenuCheck(0) is
     ' called, these values are transfered to .lastMenu and .lastItem.
     ' MenuCheck(0) then returns the menu number, or 0 (FALSE) if none
     ' selected as of last call
     '=======================================================================

         CASE 0
             GloMenu.lastMenu = GloMenu.currMenu
             GloMenu.lastItem = GloMenu.currItem
             GloMenu.currMenu = 0
             GloMenu.currItem = 0
             MenuCheck = GloMenu.lastMenu

         '===================================================================
         ' Returns the menu item last selected.  Functions only after a call
         ' to MenuCheck(0)
         '===================================================================

         CASE 1
             MenuCheck = GloMenu.lastItem

         '===================================================================
         ' Checks GloMenu.currMenu and .currItem.  If both are not 0, this
         ' returns TRUE meaning a menu has been selected since MenuCheck(0)
         ' was last called.  This does not change any values, it simply
         ' reports on the current state.
         '===================================================================

         CASE 2
             IF GloMenu.currMenu = 0 OR GloMenu.currItem = 0 THEN
                 MenuCheck = FALSE
             ELSE
                 MenuCheck = TRUE
             END IF
         CASE ELSE
             MenuCheck = 0
     END SELECT

 END FUNCTION

 SUB MenuColor (fore, back, highlight, disabled, cursorFore, cursorBack, curso

     GloMenu.fore = fore
     GloMenu.back = back
     GloMenu.highlight = highlight
     GloMenu.disabled = disabled
     GloMenu.cursorFore = cursorFore
     GloMenu.cursorBack = cursorBack
     GloMenu.cursorHi = cursorHi

 END SUB

 SUB MenuDo STATIC

     '=======================================================================
     ' If menu event trapping turned off, return immediately
     '=======================================================================

     IF NOT GloMenu.MenuOn THEN
         EXIT SUB
     END IF

     '=======================================================================
     ' Initialize MenuDo's variables, and then enter the main loop
     '=======================================================================

     GOSUB MenuDoInit

     WHILE NOT MenuDoDone

         '===================================================================
         ' If in MouseMode then
         '   if button is pressed, check where mouse is and react acccordingly
         '   if button not pressed, switch to keyboard mode.
         '===================================================================
         IF mouseMode THEN
             MousePoll mouseRow, mouseCol, lButton, rButton
             IF lButton THEN
                 IF mouseRow = 1 THEN
                     GOSUB MenuDoGetMouseMenu
                 ELSE
                     GOSUB MenuDoGetMouseItem
                 END IF
             ELSE
                 mouseMode = FALSE
                 GOSUB MenuDoMouseRelease
                 IF NOT pulldown THEN
                     GOSUB MenuDoShowTitleAccessKeys
                 END IF
             END IF
         ELSE

             '===============================================================
             ' If in keyboard mode, show the cursor, wait for key, hide cursor
             ' Perform the desired action based on what key was pressed.
             '===============================================================

             GOSUB MenuDoShowCursor
             GOSUB MenuDoGetKey
             GOSUB MenuDoHideCursor

             SELECT CASE kbd$
                 CASE "enter":       GOSUB MenuDoEnter
                 CASE "up":          GOSUB MenuDoUp
                 CASE "down":        GOSUB menuDoDown
                 CASE "left":        GOSUB MenuDoLeft
                 CASE "right":       GOSUB MenuDoRight
                 CASE "escape":      GOSUB MenuDoEscape
                 CASE "altReleased": GOSUB MenuDoAltReleased
                 CASE "mouse":       GOSUB MenuDoMousePress
                 CASE ELSE:          GOSUB MenuDoAccessKey
             END SELECT
         END IF
     WEND
     GOSUB MenuDoHideTitleAccessKeys
     EXIT SUB

 '===========================================================================
 ' Initialize variables for proper MenuDo execution.
 '===========================================================================

 MenuDoInit:
     REDIM buffer$(MAXMENU), copyFlag(MAXMENU)             'Stores screen back

     FOR a = 1 TO MAXMENU
         buffer$(a) = ""                         '1 buffer per menu
         copyFlag(a) = FALSE                     'FALSE means not copied yet
     NEXT a

     pulldown = FALSE                            'FALSE means no menu is shown
     MenuDoDone = FALSE                          'FALSE means keep going in lo

     altWasReleased = FALSE                      'Set to TRUE if ALT is presse
                                                 'and then released

     altWasPressedAgain = FALSE                  'Set to TRUE is ALT is presse
                                                 'and then released, and then
                                                 'pressed again.

     '=======================================================================
     ' If mouse installed and button is pressed, then set MouseMode to TRUE
     ' Else, set MouseMode to FALSE
     '=======================================================================

     MousePoll mouseRow, mouseCol, lButton, rButton
     IF lButton THEN
         mouseMode = TRUE
         currMenu = 0
         currItem = 0
     ELSE
         mouseMode = FALSE
         currMenu = 1
         currItem = 0
         GOSUB MenuDoShowTitleAccessKeys
     END IF

 RETURN

 '===========================================================================
 ' This shows the cursor at the location CurrMenu,CurrItem.
 '===========================================================================

 MenuDoShowCursor:

     MouseHide
     IF currMenu <> 0 AND RTRIM$(GloItem(currMenu, currItem).text) <> "-" THEN
         IF currItem = 0 THEN
             COLOR GloMenu.cursorFore, GloMenu.cursorBack
             LOCATE 1, GloTitle(currMenu).lColTitle
             PRINT " "; RTRIM$(GloTitle(currMenu).text); " ";
             IF NOT mouseMode THEN
                COLOR GloMenu.cursorHi, GloMenu.cursorBack
                LOCATE 1, GloTitle(currMenu).lColTitle + GloTitle(currMenu).ac
                PRINT MID$(GloTitle(currMenu).text, GloTitle(currMenu).accessK
             END IF
         ELSE
             IF GloItem(currMenu, currItem).state = 2 THEN
                 chk$ = CHR$(175)
             ELSE
                 chk$ = " "
             END IF

             COLOR GloMenu.cursorFore, GloMenu.cursorBack
             LOCATE GloItem(currMenu, currItem).row, GloTitle(currMenu).lColIt
             PRINT chk$; LEFT$(GloItem(currMenu, currItem).text, GloTitle(curr

             IF GloItem(currMenu, currItem).state > 0 THEN
                 COLOR GloMenu.cursorHi, GloMenu.cursorBack
                 LOCATE GloItem(currMenu, currItem).row, col + GloItem(currMen
                 PRINT MID$(GloItem(currMenu, currItem).text, GloItem(currMenu
             END IF

         END IF
     END IF
     MouseShow

 RETURN

 '===========================================================================
 ' This hides the cursor at the location CurrMenu,CurrItem.
 '===========================================================================

 MenuDoHideCursor:

     MouseHide
     IF currMenu <> 0 AND RTRIM$(GloItem(currMenu, currItem).text) <> "-" THEN
         IF currItem = 0 THEN
             SELECT CASE GloTitle(currMenu).state
                 CASE 0: COLOR GloMenu.disabled, GloMenu.back
                 CASE 1, 2: COLOR GloMenu.fore, GloMenu.back
                 CASE ELSE
             END SELECT
             LOCATE 1, GloTitle(currMenu).lColTitle
             PRINT " "; RTRIM$(GloTitle(currMenu).text); " ";

             IF GloTitle(currMenu).state > 0 THEN
                 COLOR GloMenu.highlight, GloMenu.back
                 LOCATE 1, GloTitle(currMenu).lColTitle + GloTitle(currMenu).a
                 PRINT MID$(GloTitle(currMenu).text, GloTitle(currMenu).access
             END IF
         ELSE
             IF GloItem(currMenu, currItem).state = 2 THEN
                 chk$ = CHR$(175)
             ELSE
                 chk$ = " "
             END IF
             SELECT CASE GloItem(currMenu, currItem).state
                 CASE 0: COLOR GloMenu.disabled, GloMenu.back
                 CASE 1, 2: COLOR GloMenu.fore, GloMenu.back
                 CASE ELSE
             END SELECT
             LOCATE GloItem(currMenu, currItem).row, GloTitle(currMenu).lColIt
             PRINT chk$; LEFT$(GloItem(currMenu, currItem).text, GloTitle(curr

             IF GloItem(currMenu, currItem).state > 0 THEN
                 COLOR GloMenu.highlight, GloMenu.back
                 LOCATE GloItem(currMenu, currItem).row, col + GloItem(currMen
                 PRINT MID$(GloItem(currMenu, currItem).text, GloItem(currMenu
             END IF

         END IF
     END IF
     MouseShow
 RETURN

 '===========================================================================
 ' Handles state where mouse is at row #1.
 '===========================================================================

 MenuDoGetMouseMenu:

     '=======================================================================
     ' Computes the menu number based on mouse column location.  Uses info
     ' calculated in MenuShow()
     '=======================================================================

     newMenu = CVI(MID$(GloMenu.menuIndex, mouseCol * 2 - 1, 2))

     IF GloTitle(newMenu).state <> 1 THEN
         newMenu = 0
     END IF

     '=======================================================================
     ' If new menu<>current menu, hide current menu, show new menu, assign new
     ' menu to current menu
     '=======================================================================

     IF newMenu <> currMenu THEN
         GOSUB MenuDoHidePullDown
         currMenu = newMenu
         currItem = 0
         GOSUB menuDoShowPullDown
     END IF

 RETURN

 '===========================================================================
 ' Handles state where mouse is not in row #1.  If a menu is down, it picks
 ' the proper menu item based on which row the mouse is located
 '===========================================================================

 MenuDoGetMouseItem:

     '=======================================================================
     ' If pulldown, and mouse column is within the menu area, then compute new
     ' item  based on computations done in MenuShow.  If not in box, then new
     ' item = 0
     '=======================================================================

     IF pulldown THEN
         IF mouseCol >= GloTitle(currMenu).lColItem AND mouseCol <= GloTitle(c
             newItem = GloItem(currMenu, mouseRow - 2).index
         ELSE
             newItem = 0
         END IF

         ' ===================================================================
         ' If current item <> new item, hide old cursor, show new cursor,
         ' assign new item to current item.
         ' ===================================================================

         IF currItem <> newItem THEN
             IF currItem <> 0 THEN
                 GOSUB MenuDoHideCursor
             END IF
             currItem = newItem
             GOSUB MenuDoShowCursor
         END IF
     END IF
 RETURN

 ' ===========================================================================
 ' Handles state when MenuDo is in mouse mode, and mouse button is released.
 ' ===========================================================================

 MenuDoMouseRelease:
     menuMode = FALSE

     ' =======================================================================
     ' If no menu selected, then exit MenuDo returning 0s for menu and item
     ' =======================================================================

     IF currMenu = 0 THEN
         GloMenu.currMenu = 0
         GloMenu.currItem = 0
         MenuDoDone = TRUE
     ELSE

         ' ===================================================================
         ' If menu is down, but no item is selected then
         '    if mouse is on the top row, simply gosub the MenuDoDown routine
         '    else hide menu then exit MenuDo returning 0's for menu and item
         ' ===================================================================

         IF currItem = 0 THEN
             IF mouseRow = 1 THEN
                 GOSUB menuDoDown
             ELSE
                 GOSUB MenuDoHidePullDown
                 GloMenu.currMenu = 0
                 GloMenu.currItem = 0
                 MenuDoDone = TRUE
             END IF
         ELSE

             ' ===============================================================
             ' If current (menu,item)'s state is disabled, then just beep
             ' ===============================================================

             IF GloItem(currMenu, currItem).state = 0 THEN
                 BEEP

             ' ===============================================================
             ' If current (menu,item)'s state is a line
             ' then exit MenuDo returning 0s for menu and item
             ' ===============================================================

             ELSEIF RTRIM$(GloItem(currMenu, currItem).text) = "-" THEN
                 GOSUB MenuDoHidePullDown
                 GloMenu.currMenu = 0
                 GloMenu.currItem = 0
                 MenuDoDone = TRUE
             ELSE

                 ' ===========================================================
                 ' Otherwise, selection must be valid, exit MenuDo, returning
                 ' proper menu,item pair in the proper global variables
                 ' ===========================================================
                 GOSUB MenuDoHidePullDown
                 GloMenu.currMenu = currMenu
                 GloMenu.currItem = currItem
                 MenuDoDone = TRUE
             END IF
         END IF
     END IF
 RETURN

 ' ==========================================================================
 ' This routine shows the menu bar's access keys
 ' ==========================================================================

 MenuDoShowTitleAccessKeys:
     MouseHide
     COLOR GloMenu.highlight, GloMenu.back
     FOR menu = 1 TO MAXMENU
         IF GloTitle(menu).state = 1 THEN
             LOCATE 1, GloTitle(menu).lColTitle + GloTitle(menu).accessKey
             PRINT MID$(GloTitle(menu).text, GloTitle(menu).accessKey, 1);
         END IF
     NEXT menu
     MouseShow
 RETURN


 ' ===========================================================================
 ' This routine hides the menu bar's access keys
 ' ===========================================================================

 MenuDoHideTitleAccessKeys:
     MouseHide
     COLOR GloMenu.fore, GloMenu.back
     FOR menu = 1 TO MAXMENU
         IF GloTitle(menu).state = 1 THEN
             LOCATE 1, GloTitle(menu).lColTitle + GloTitle(menu).accessKey
             PRINT MID$(GloTitle(menu).text, GloTitle(menu).accessKey, 1);
         END IF
     NEXT menu
     MouseShow
 RETURN

 ' ===========================================================================
 ' Waits for key press, then returns the key press.  It also returns several
 ' tokens such as "menu", or "altReleased" in special cases.  Read on...
 ' ===========================================================================

 MenuDoGetKey:
     DO
         kbd$ = INKEY$

         ' ===================================================================
         ' If ALT key pressed, then if it was a access key (Alt+A..) reduce
         '  the Alt+A to A.
         '  Also set the altPressed flags to reflect the current state of the
         '  ALT key.
         ' ===================================================================

         IF GetShiftState(3) THEN
             IF kbd$ = "" THEN
                 IF altWasReleased THEN
                     altWasPressedAgain = TRUE
                 END IF
             ELSE
                 altWasPressedAgain = FALSE
                 kbd$ = AltToASCII(kbd$)
             END IF
             altWasReleased = FALSE
         ELSE

             ' ===============================================================
             ' If ALT key is released (initially), then pressed, then released
             ' again with no other action in between, then return the
             ' token "altReleased"
             ' ===============================================================

             IF altWasPressedAgain THEN
                 kbd$ = "altReleased"
                 altWasPressedAgain = FALSE
             ELSE

                 ' ===========================================================
                 ' Based on the key that was pressed, return the proper token
                 ' ===========================================================

                 altWasReleased = TRUE

                 SELECT CASE kbd$
                     CASE CHR$(27) + "": kbd$ = "escape"
                     CASE CHR$(32) + "": kbd$ = ""
                     CASE CHR$(13) + "": kbd$ = "enter"
                     CASE CHR$(0) + "H": kbd$ = "up"
                     CASE CHR$(0) + "P": kbd$ = "down"
                     CASE CHR$(0) + "K": kbd$ = "left"
                     CASE CHR$(0) + "M": kbd$ = "right"
                     CASE ELSE
                         IF LEN(kbd$) = 1 THEN
                             kbd$ = UCASE$(kbd$)
                         END IF
                 END SELECT
             END IF
         END IF

         ' ===================================================================
         ' If mouse button is pressed, it overrides all key actions, and
         ' the token "mouse" is returned
         ' ===================================================================

         MousePoll mouseRow, mouseCol, lButton, rButton
         IF lButton THEN
             kbd$ = "mouse"
         END IF

     LOOP UNTIL kbd$ <> ""

 RETURN


 ' ===========================================================================
 ' Handles the state where the up arrow is pressed.  It searches for the
 ' first non empty, non "-" (dashed) item.
 ' ===========================================================================

 MenuDoUp:
     IF currItem <> 0 THEN
         DO
             currItem = (currItem + MAXITEM - 2) MOD MAXITEM + 1
         LOOP UNTIL GloItem(currMenu, currItem).state >= 0 AND RTRIM$(GloItem(
     END IF
 RETURN


 ' ===========================================================================
 ' Handles 2 different states:
 '
 '  State 1: Menu is open, and the down arrow is pressed.
 '
 '  State 2: Any time a new menu is opened, and the top item
 '      is to be the current item.  Specifically:
 '          - When no menu is opened, and the down arrow is pressed
 '          - When the mouse is released over the menu title
 '          - When a menu is opened, and the user hits right/left arrow
 '          - When enter is pressed while cursor is on title bar
 '          - When a access key is used on the title bar.
 ' ===========================================================================

 menuDoDown:
     DO
         IF currItem = 0 THEN
             GOSUB MenuDoHideTitleAccessKeys
             GOSUB menuDoShowPullDown
             currItem = (currItem) MOD MAXITEM + 1
         ELSEIF currItem > 0 THEN
             currItem = (currItem) MOD MAXITEM + 1
         END IF

     LOOP UNTIL GloItem(currMenu, currItem).state >= 0 AND RTRIM$(GloItem(curr
 RETURN


 ' ===========================================================================
 ' Handles state when the left arrow is pressed.  If a menu is down, it
 ' hides it.  It then finds the first valid menu to the left.  If the menu
 ' was initially down, then the new menu is pulled down as well
 ' ===========================================================================

 MenuDoLeft:
     IF pulldown THEN
         GOSUB MenuDoHidePullDown
         pulldown = TRUE
     END IF

     DO
         currMenu = (currMenu + MAXMENU - 2) MOD MAXMENU + 1
     LOOP UNTIL GloTitle(currMenu).state = 1

     IF pulldown THEN
         currItem = 0
         GOSUB menuDoDown
     END IF
 RETURN


 ' ===========================================================================
 ' Handles state when the right arrow is pressed.  If a menu is down, it
 ' hides it.  It then finds the first valid menu to the right.  If the menu
 ' was initially down, then the new menu is pulled down as well
 ' ===========================================================================

 MenuDoRight:
     IF pulldown THEN
         GOSUB MenuDoHidePullDown
         pulldown = TRUE
     END IF

     DO
         currMenu = (currMenu) MOD MAXMENU + 1
     LOOP UNTIL GloTitle(currMenu).state = 1

     IF pulldown THEN
         currItem = 0
         GOSUB menuDoDown
     END IF
 RETURN


 ' ===========================================================================
 ' Handles state when the ESC key is pressed.  First hides the menu, and
 ' then exits menuDo, returning 0's in the proper global variables
 ' ===========================================================================

 MenuDoEscape:
     GOSUB MenuDoHidePullDown
     GloMenu.currMenu = 0
     GloMenu.currItem = 0
     MenuDoDone = TRUE
 RETURN

 ' ===========================================================================
 ' Handles state when Enter is pressed.  If on a valid item, return the
 ' proper (menu,item) pair and exit.  Else beep.  If on a valid menu
 ' this will open the menu by calling MenuDoDown
 ' ===========================================================================

 MenuDoEnter:
     IF currItem = 0 THEN
         IF GloTitle(currMenu).state = 0 THEN
             BEEP
         ELSE
             GOSUB menuDoDown
         END IF
     ELSE
         IF GloItem(currMenu, currItem).state <= 0 THEN
             BEEP
         ELSE
             GOSUB MenuDoHidePullDown
             GloMenu.currMenu = currMenu
             GloMenu.currItem = currItem
             MenuDoDone = TRUE
         END IF
     END IF
 RETURN


 ' ===========================================================================
 ' If ALT pressed and released with nothing else happening in between, it
 ' will exit if no menu is open, or close the menu if one is open.
 ' ===========================================================================

 MenuDoAltReleased:
     IF pulldown THEN
         GOSUB MenuDoHidePullDown
         currItem = 0
         GOSUB MenuDoShowTitleAccessKeys
     ELSE
         GloMenu.currMenu = 0
         GloMenu.currItem = 0
         MenuDoDone = TRUE
     END IF
 RETURN


 ' ===========================================================================
 ' If mouse is pressed while in keyboard mode, this routine assigns
 ' TRUE to MouseMode, resets the item, and hides the access keys
 ' ===========================================================================

 MenuDoMousePress:
     mouseMode = TRUE
     currItem = 0
     IF NOT pulldown THEN
         GOSUB MenuDoHideTitleAccessKeys
     END IF
 RETURN


 ' ===========================================================================
 ' If a access key is pressed
 ' ===========================================================================

 MenuDoAccessKey:

     ' =======================================================================
     ' If an access key is pressed
     '   If no menu selected, search titles for matching access key, and open
     '      than menu.
     ' =======================================================================

     IF currItem = 0 THEN
         newMenu = (currMenu + MAXMENU - 2) MOD MAXMENU + 1
         loopEnd = (currMenu + MAXMENU - 2) MOD MAXMENU + 1
         DO
             newMenu = (newMenu) MOD MAXMENU + 1
         LOOP UNTIL (UCASE$(MID$(GloTitle(newMenu).text, GloTitle(newMenu).acc

         IF kbd$ = UCASE$(MID$(GloTitle(newMenu).text, GloTitle(newMenu).acces
             currMenu = newMenu
             GOSUB menuDoDown
         END IF
     ELSE

         ' ===================================================================
         ' If menu is selected, search items for matching access key, and
         ' select that (menu,item) and exit MenuDo if item is enabled
         ' ===================================================================

         newItem = (currItem + MAXITEM - 2) MOD MAXITEM + 1
         loopEnd = (currItem + MAXITEM - 2) MOD MAXITEM + 1
         DO
             newItem = (newItem) MOD MAXITEM + 1
         LOOP UNTIL (UCASE$(MID$(GloItem(currMenu, newItem).text, GloItem(curr


         IF kbd$ = UCASE$(MID$(GloItem(currMenu, newItem).text, GloItem(currMe
             currItem = newItem

             IF GloItem(currMenu, currItem).state <= 0 THEN
                 BEEP
             ELSE
                 GOSUB MenuDoHidePullDown
                 GloMenu.currMenu = currMenu
                 GloMenu.currItem = currItem
                 MenuDoDone = TRUE
             END IF
         END IF
     END IF
 RETURN

 ' ===========================================================================
 ' Draws the menu -- only if menu is enabled.
 ' ===========================================================================

 menuDoShowPullDown:
     IF currMenu <> 0 AND GloTitle(currMenu).state = 1 THEN

         ' ===================================================================
         ' Copies the background if this is the first time this particular
         ' menu is being drawn
         ' ===================================================================

         MouseHide
         IF NOT copyFlag(currMenu) THEN
             IF GloTitle(currMenu).rColItem - GloTitle(currMenu).lColItem < LE
                 GloTitle(currMenu).rColItem = GloTitle(currMenu).lColItem + L
             END IF

             GetBackground 1, GloTitle(currMenu).lColItem, GloTitle(currMenu).
             copyFlag(currMenu) = TRUE
         END IF

         ' ===================================================================
         ' Draw the menu, this is pretty straight forward
         ' ===================================================================
         pulldown = TRUE
         length = GloTitle(currMenu).itemLength
         IF length = 0 THEN length = 6
         lowestRow = 3
         col = GloTitle(currMenu).lColItem

         COLOR GloMenu.cursorFore, GloMenu.cursorBack
         LOCATE 1, GloTitle(currMenu).lColTitle
         PRINT " "; RTRIM$(GloTitle(currMenu).text); " ";

         COLOR GloMenu.fore, GloMenu.back
         LOCATE 2, col
         PRINT "┌"; STRING$(length + 2, "─"); "┐"

         FOR item = 1 TO MAXITEM
             IF GloItem(currMenu, item).state >= 0 THEN
                 IF GloItem(currMenu, item).state = 2 THEN
                     chk$ = CHR$(175)
                 ELSE
                     chk$ = " "
                 END IF

                 LOCATE GloItem(currMenu, item).row, col
                 COLOR GloMenu.fore, GloMenu.back

                 IF RTRIM$(GloItem(currMenu, item).text) = "-" THEN
                     PRINT "├"; STRING$(length + 2, "─"); "┤"
                 ELSE
                     PRINT "│"; chk$;
                     IF GloItem(currMenu, item).state > 0 THEN
                         COLOR GloMenu.fore, GloMenu.back
                     ELSE
                         COLOR GloMenu.disabled, GloMenu.back
                     END IF
                     PRINT LEFT$(GloItem(currMenu, item).text + SPACE$(20), le
                     COLOR GloMenu.fore, GloMenu.back
                     PRINT " │";

                     IF GloItem(currMenu, item).state > 0 THEN
                         COLOR GloMenu.highlight, GloMenu.back
                         LOCATE GloItem(currMenu, item).row, col + GloItem(cur
                         PRINT MID$(GloItem(currMenu, item).text, GloItem(curr
                     END IF
                 END IF
                 lowestRow = GloItem(currMenu, item).row + 1
             END IF
         NEXT item

         COLOR GloMenu.fore, GloMenu.back
         LOCATE lowestRow, col
         PRINT "└"; STRING$(length + 2, "─"); "┘";

         rCol = col + length + 5

         AttrBox 3, rCol - 1, lowestRow, rCol, 8
         AttrBox lowestRow + 1, col + 2, lowestRow + 1, rCol, 8
     END IF

     MouseShow

 RETURN

 ' ===========================================================================
 ' Replace the background over the menu
 ' ===========================================================================

 MenuDoHidePullDown:
     IF pulldown THEN
         MouseHide

         PutBackground 1, GloTitle(currMenu).lColItem, buffer$(currMenu)

         MouseShow
         pulldown = FALSE
     END IF
 RETURN

 END SUB

 SUB MenuEvent

     ' =======================================================================
     ' If ALT key is pressed, let MenuDo take over.  NOTE:  This will
     ' not call MenuDo if the ALT key has not been released at least
     ' once since the last time MenuDo was called.  This prevents the menu
     ' from flashing if the user simply holds down the ALT key.
     ' =======================================================================

     IF GetShiftState(3) THEN
         IF GloMenu.altKeyReset THEN
             MenuDo
             GloMenu.altKeyReset = FALSE
         END IF
     ELSE
         GloMenu.altKeyReset = TRUE
     END IF

     ' =======================================================================
     ' Call MenuDo if the mouse button is down, and the cursor is on the top r
     ' =======================================================================

     MousePoll mouseRow, mouseCol, lButton, rButton
     IF mouseRow = 1 AND lButton THEN
         MenuDo
     END IF

 END SUB

 SUB MenuInit

     ' =======================================================================
     '  Initialize global menu arrays
     ' =======================================================================

     FOR menu = 1 TO MAXMENU
         GloTitle(menu).text = ""
         GloTitle(menu).state = -1            'state of -1 means "empty"
         GloTitle(menu).rColItem = 0           'These get set in MenuShow
         GloTitle(menu).lColItem = 0           ' |
         GloTitle(menu).rColTitle = 0          ' |
         GloTitle(menu).lColTitle = 0          ' |
         GloTitle(menu).itemLength = 0         ' |
         GloTitle(menu).accessKey = 1            'Initial AccessKey of 1

         FOR item = 1 TO MAXITEM
             GloItem(menu, item).text = ""
             GloItem(menu, item).state = -1      'state of -1 means "empty"
             GloItem(menu, item).index = 0       'These get set in MenuShow
             GloItem(menu, item).row = 0         '  |
             GloItem(menu, item).accessKey = 1   'Initial AccessKey of 1
         NEXT item
     NEXT menu

     ' =======================================================================
     ' Initialize mouse
     ' =======================================================================

     MouseInit

     ' =======================================================================
     ' Set initial state of ALT key to "reset"
     ' Clear out shortcut key index
     ' Set initial state of menu to ON
     ' =======================================================================

     GloMenu.altKeyReset = TRUE
     GloMenu.shortcutKeyIndex = STRING$(100, 0)
     GloMenu.MenuOn = TRUE

     GloMenu.fore = 0
     GloMenu.back = 7
     GloMenu.highlight = 15
     GloMenu.disabled = 8
     GloMenu.cursorFore = 7
     GloMenu.cursorBack = 0
     GloMenu.cursorHi = 15

 END SUB

 FUNCTION MenuInkey$ STATIC

     ' =======================================================================
     ' Scan keyboard, return KBD$ by default -- unless it is over written belo
     ' =======================================================================

     kbd$ = INKEY$
     MenuInkey$ = kbd$

     ' =======================================================================
     ' Check if KBD$ matches a shortcut key.  If it does, return "menu" instea
     ' of the key that was pressed
     ' =======================================================================

     ShortCutKeyEvent kbd$
     IF MenuCheck(2) THEN
         MenuInkey$ = "menu"
     ELSE

         ' ===================================================================
         ' Call menu event, which looks at mouse, and state of ALT key
         ' If a menu item is selected, return "menu" instead of KBD$
         ' ===================================================================

         MenuEvent
         IF MenuCheck(2) THEN
             MenuInkey$ = "menu"
         END IF
     END IF

 END FUNCTION

 SUB MenuItemToggle (menu, item)

     IF item >= 0 AND menu >= 1 AND item <= MAXITEM AND menu <= MAXMENU THEN

         IF item = 0 OR GloItem(menu, item).state < 1 OR GloItem(menu, item).s
             SOUND 2000, 40
         ELSE
             GloItem(menu, item).state = 3 - GloItem(menu, item).state
         END IF

     END IF
 END SUB

 DEFSNG A-Z
 SUB MenuOff

     ' =======================================================================
     ' Simply assigns FALSE to the proper global variable
     ' =======================================================================

     GloMenu.MenuOn = FALSE

 END SUB

 DEFINT A-Z
 SUB MenuOn

     ' =======================================================================
     ' Simply assigns TRUE to the proper global variable
     ' =======================================================================

     GloMenu.MenuOn = TRUE

 END SUB

 SUB MenuPreProcess STATIC

     currCol = 2     'Represents the col where first menu title is located

     ' =======================================================================
     ' Menu index is a fast way of decoding which menu the mouse cursor
     ' is pointing to based on the col of the cursor.  See MENU.BI for details
     ' =======================================================================

     GloMenu.menuIndex = STRING$(160, 0)

     ' =======================================================================
     ' Process each menu, one at a time
     ' =======================================================================

     FOR menu = 1 TO MAXMENU

         ' ===================================================================
         ' If state is empty, or text is "" then clear out data for that menu
         ' ===================================================================

         IF GloTitle(menu).state < 0 OR LEN(RTRIM$(GloTitle(menu).text)) = 0 T
             GloTitle(menu).rColItem = 0
             GloTitle(menu).lColItem = 0
             GloTitle(menu).rColTitle = 0
             GloTitle(menu).lColTitle = 0
             GloTitle(menu).itemLength = 0
             GloTitle(menu).state = -1
        ELSE
             ' ===============================================================
             ' else, assign data about the column location to the global stora
             ' ===============================================================

             GloTitle(menu).lColTitle = currCol
             GloTitle(menu).rColTitle = currCol + LEN(RTRIM$(GloTitle(menu).te
             GloTitle(menu).lColItem = currCol - 1

             IF GloTitle(menu).rColTitle > MAXCOL THEN
                 BEEP: CLS : PRINT "Menu bar longer than screen!  Cannot funct
                 END
             END IF

             ' ===============================================================
             ' Update the index about where the menu is located, increment
             ' currCol
             ' ===============================================================

             FOR index = currCol TO currCol + LEN(RTRIM$(GloTitle(menu).text))
                 MID$(GloMenu.menuIndex, index * 2 - 1, 2) = MKI$(menu)
             NEXT index

             currCol = currCol + LEN(RTRIM$(GloTitle(menu).text)) + 2

             ' ===============================================================
             ' Process the items in the menu, computing the
             ' longest item, and preparing the row index
             ' ===============================================================

             GloTitle(menu).itemLength = 0
             currRow = 3
             iFlag = FALSE

             FOR item = 1 TO MAXITEM
                 GloItem(menu, currRow - 2).index = 0
                 IF GloItem(menu, item).state >= 0 THEN
                     GloItem(menu, currRow - 2).index = item
                     GloItem(menu, item).row = currRow
                     currRow = currRow + 1
                     IF LEN(RTRIM$(GloItem(menu, item).text)) > GloTitle(menu)
                         GloTitle(menu).itemLength = LEN(RTRIM$(GloItem(menu,
                     END IF
                     iFlag = TRUE
                 END IF
             NEXT item

             ' ===============================================================
             ' If all items were empty, disable the menu itself
             ' else, assign the longest length to the proper variable
             ' ===============================================================

             IF NOT iFlag THEN
                 GloTitle(menu).state = 0
             ELSE
                 GloTitle(menu).rColItem = GloTitle(menu).lColItem + GloTitle(
                 IF GloTitle(menu).rColItem > MAXCOL - 2 THEN
                    diff = GloTitle(menu).rColItem - (MAXCOL - 2)
                    GloTitle(menu).rColItem = GloTitle(menu).rColItem - diff
                    GloTitle(menu).lColItem = GloTitle(menu).lColItem - diff
                 END IF
             END IF

         END IF

         GloTitle(menu).lowestRow = currRow + 1
     NEXT menu

 END SUB

 SUB MenuSet (menu, item, state, text$, accessKey) STATIC

     IF accessKey > LEN(text$) THEN accessKey = LEN(text$)

     IF item >= 0 AND menu >= 1 AND item <= MAXITEM AND menu <= MAXMENU THEN

         ' ===================================================================
         ' Assign parameters to proper global menu variables
         ' ===================================================================

         IF item = 0 THEN
             IF state < -1 OR state > 1 THEN
                 SOUND 3000, 40
             ELSE
                 GloTitle(menu).text = text$
                 GloTitle(menu).state = state
                 GloTitle(menu).accessKey = accessKey
             END IF
         ELSE
             IF state < -1 OR state > 2 THEN
                 SOUND 4000, 40
             ELSE
                 GloItem(menu, item).text = text$
                 GloItem(menu, item).state = state
                 GloItem(menu, item).accessKey = accessKey
             END IF
         END IF
     END IF

 END SUB

 SUB MenuSetState (menu, item, state) STATIC

     ' =======================================================================
     ' Assign parameters to proper global menu variables
     ' =======================================================================

     IF item = 0 THEN
         IF state < 0 OR state > 1 OR GloTitle(menu).state < 0 THEN
             SOUND 5000, 40
         ELSE
             GloTitle(menu).state = state
         END IF
     ELSE
         IF state < 0 OR state > 2 OR GloItem(menu, item).state < 0 THEN
             SOUND 6000, 40
         ELSE
             GloItem(menu, item).state = state
         END IF
     END IF

 END SUB

 DEFSNG A-Z
 SUB MenuShow

     ' =======================================================================
     ' This section actually prints the menu on the screen
     ' =======================================================================

     COLOR GloMenu.fore, GloMenu.back
     LOCATE 1, 1
     PRINT SPACE$(MAXCOL);

     FOR menu = 1 TO MAXMENU
         SELECT CASE GloTitle(menu).state
             CASE 0:
                 COLOR GloMenu.disabled, GloMenu.back
                 LOCATE 1, GloTitle(menu).lColTitle + 1
                 PRINT RTRIM$(GloTitle(menu).text$);
             CASE 1:
                 COLOR GloMenu.fore, GloMenu.back
                 LOCATE 1, GloTitle(menu).lColTitle + 1
                 PRINT RTRIM$(GloTitle(menu).text$);
             CASE ELSE
         END SELECT

     NEXT menu

 END SUB

 DEFINT A-Z
 SUB ShortCutKeyDelete (menu, item) STATIC

     '=======================================================================
     ' Search through shortcut key index until the menu,item pair is found
     ' or the end of the list is reached.
     '=======================================================================

     ptr = -1
     DO
         ptr = ptr + 1
         temp = CVI(MID$(GloMenu.shortcutKeyIndex, ptr * 4 + 1, 2))
         testMenu = INT(temp / 256)
         testItem = INT(temp MOD 256)
     LOOP UNTIL (menu = testMenu AND item = testItem) OR testMenu = 0 AND test

     '=======================================================================
     ' If a match is found, delete the shortcut key by squeezing out the four
     ' bytes that represents the shortcut key, and adding four chr$(0) at the
     ' end.
     '=======================================================================

     IF menu = testMenu AND item = testItem THEN
         GloMenu.shortcutKeyIndex = LEFT$(GloMenu.shortcutKeyIndex, ptr * 4) +
     END IF

 END SUB

 SUB ShortCutKeyEvent (theKey$)

     '=======================================================================
     ' If menu event trapping turned off, return immediately
     '=======================================================================

     IF NOT GloMenu.MenuOn THEN
         EXIT SUB
     END IF

     '=======================================================================
     ' Make sure the length of theKey$ is two bytes by adding a chr$(0) if
     ' necessary.  If the length is > 2, make it null.
     '=======================================================================

     SELECT CASE LEN(theKey$)
         CASE 1
             theKey$ = theKey$ + CHR$(0)
         CASE 2
         CASE ELSE
             theKey$ = ""
     END SELECT

     '=======================================================================
     ' Search the shortcut key list for a match -- only if theKey$ is valid.
     '=======================================================================

     IF theKey$ <> "" THEN

         ptr = -1
         DO
             ptr = ptr + 1
             testKey$ = MID$(GloMenu.shortcutKeyIndex, ptr * 4 + 3, 2)

         LOOP UNTIL theKey$ = testKey$ OR testKey$ = STRING$(2, 0) OR ptr = 25

         '===================================================================
         ' If match is found, make sure menu choice is valid (state > 0)
         ' If so, assign the proper global variables.
         '===================================================================

     IF theKey$ = testKey$ THEN
             temp = CVI(MID$(GloMenu.shortcutKeyIndex, ptr * 4 + 1, 2))
             tempMenu = INT(temp / 256)
             tempItem = INT(temp MOD 256)

             IF GloItem(tempMenu, tempItem).state > 0 THEN
                 GloMenu.currMenu = tempMenu
                 GloMenu.currItem = tempItem
             END IF
         END IF
     END IF

 END SUB

 SUB ShortCutKeySet (menu, item, shortcutKey$)

     '=======================================================================
     ' Make sure the length of theKey$ is two bytes by adding a chr$(0) if
     ' necessary.  If the length is >2, make it null.
     '=======================================================================

     SELECT CASE LEN(shortcutKey$)
         CASE 1
             shortcutKey$ = shortcutKey$ + CHR$(0)
         CASE 2
         CASE ELSE
             shortcutKey$ = ""
     END SELECT

     '=======================================================================
     ' First delete the shortcut key, just in case it already exists, and then
     ' and the shortcut key to the front of the shortcut key index string.
     '=======================================================================

     ShortCutKeyDelete menu, item
     IF shortcutKey$ <> "" THEN
         newKey$ = MKI$(menu * 256 + item) + shortcutKey$
         GloMenu.shortcutKeyIndex = newKey$ + LEFT$(GloMenu.shortcutKeyIndex,
     END IF

 END SUB



 MOUSE.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MOUSE.BAS

 '============================================================================
 '
 '    MOUSE.BAS - Mouse Support Routines for the User Interface Toolbox in
 '           Microsoft BASIC 7.0, Professional Development System
 '              Copyright (C) 1987-1989, Microsoft Corporation
 '
 ' NOTE:     This sample source code toolbox is intended to demonstrate some
 '           of the extended capabilities of Microsoft BASIC 7.0 Professional
 '           Development system that can help to leverage the professional
 '           developer's time more effectively.  While you are free to use,
 '           modify, or distribute the routines in this module in any way you
 '           find useful, it should be noted that these are examples only and
 '           should not be relied upon as a fully-tested "add-on" library.
 '
 '  PURPOSE: These routines are required for mouse support in the user
 '           interface toolbox, but they may be used independently as well.
 '
 '  For information on creating a library and QuickLib from the routines
 '  contained in this file, read the comment header of GENERAL.BAS.
 '
 '============================================================================

 DEFINT A-Z

 '$INCLUDE: 'general.bi'
 '$INCLUDE: 'mouse.bi'
 '$INCLUDE: 'menu.bi'

 COMMON SHARED /uitools/ GloMenu      AS MenuMiscType
 COMMON SHARED /uitools/ GloTitle()   AS MenuTitleType
 COMMON SHARED /uitools/ GloItem()    AS MenuItemType

 SUB MouseBorder (row1, col1, row2, col2) STATIC

     ' =======================================================================
     ' Sets max and min bounds on mouse movement both vertically, and
     ' horizontally
     ' =======================================================================

     MouseDriver 7, 0, (col1 - 1) * 8, (col2 - 1) * 8
     MouseDriver 8, 0, (row1 - 1) * 8, (row2 - 1) * 8

 END SUB

 SUB MouseDriver (m0, m1, m2, m3) STATIC

     DIM regs AS RegType

     IF MouseChecked = FALSE THEN
         DEF SEG = 0

         MouseSegment& = 256& * PEEK(207) + PEEK(206)
         MouseOffset& = 256& * PEEK(205) + PEEK(204)

         DEF SEG = MouseSegment&

         IF (MouseSegment& = 0 AND MouseOffset& = 0) OR PEEK(MouseOffset&) = 2
             MousePresent = FALSE
             MouseChecked = TRUE
             DEF SEG
         END IF
     END IF

     IF MousePresent = FALSE AND MouseChecked = TRUE THEN
         EXIT SUB
     END IF

     ' =======================================================================
     ' Calls interrupt 51 to invoke mouse functions in the MS Mouse Driver.
     ' =======================================================================

     regs.ax = m0
     regs.bx = m1
     regs.cx = m2
     regs.dx = m3

     Interrupt 51, regs, regs

     m0 = regs.ax
     m1 = regs.bx
     m2 = regs.cx
     m3 = regs.dx

     IF MouseChecked THEN EXIT SUB

     ' =======================================================================
     ' Check for successful mouse initialization
     ' =======================================================================

     IF m0 AND NOT MouseChecked THEN
         MousePresent = TRUE
     END IF

     MouseChecked = TRUE

 END SUB

 SUB MouseHide

     ' =======================================================================
     ' Decrements internal cursor flag
     ' =======================================================================

    MouseDriver 2, 0, 0, 0

 END SUB

 SUB MouseInit

     ' =======================================================================
     ' Mouse driver's initialization routine
     ' =======================================================================

     MouseDriver 0, 0, 0, 0

 END SUB

 SUB MousePoll (row, col, lButton, rButton) STATIC

     ' =======================================================================
     ' Polls mouse driver, then sets parms correctly
     ' =======================================================================

     MouseDriver 3, button, col, row
     row = row / 8 + 1
     col = col / 8 + 1

     IF button AND 1 THEN
         lButton = TRUE
     ELSE
         lButton = FALSE
     END IF

     IF button AND 2 THEN
         rButton = TRUE
     ELSE
         rButton = FALSE
     END IF

 END SUB

 SUB MouseShow

     ' =======================================================================
     ' Increments mouse's internal cursor flag
     ' =======================================================================

     MouseDriver 1, 0, 0, 0

 END SUB



 MUSIC.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MUSIC.BAS

 ' Turn on trapping of background music events:
 PLAY ON

 ' Branch to the Refresh subroutine when there are fewer than
 ' two notes in the background music buffer:
 ON PLAY(2) GOSUB Refresh

 PRINT "Press any key to start, q to end."
 Pause$ = INPUT$(1)

 ' Select the background music option for PLAY:
 PLAY "MB"

 ' Start playing the music, so notes will be put in the
 ' background music buffer:
 GOSUB Refresh

 I = 0

 DO

         ' Print the numbers from 0 to 10,000 over and over until
         ' the user presses the "q" key. While this is happening,
         ' the music will repeat in the background:
         PRINT I
         I = (I + 1) MOD 10001
 LOOP UNTIL INKEY$ = "q"

 END

 Refresh:

         ' Plays the opening motive of
         ' Beethoven's Fifth Symphony:
         Listen$ = "t180 o2 p2 p8 L8 GGG L2 E-"
         Fate$   = "p24 p8 L8 FFF L2 D"
         PLAY Listen$ + Fate$
         RETURN



 MXADSTA.ASM
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MXADSTA.ASM

 ;***************************** ADDSTRING ********************************
 ; This procedure accepts two far strings, concatenates them, and
 ; returns the result in the form of a far string.

         .model  medium,basic        ;Define memory model to match BASIC.
         .stack
         .data?
         maxst = 50                  ;Maximum bytes reserved for strings
 inbuffer1       db  maxst dup(0)    ;Room for first fixed-length string
 inbuffer2       db  maxst dup(0)    ;and second one
 outbuffer       db  2*maxst dup(0)  ;Work area for string processing
         .data
 sh              dd  0               ;Output string descriptor
         .code
 addstring   proc    uses si di ds, s1:far ptr, s1len, s2:far ptr, s2len

 ;First get BASIC to convert BASIC strings into standard form.
         les     ax,s1               ;Push far pointer to
         push    es                  ;input string descriptor.
         push    ax
         xor     ax,ax               ;Push a zero to indicate
         push    ax                  ;it is variable length.
         push    ds                  ;Push far pointer to
         lea     ax, inbuffer1       ;destination string.
         push    ax
         mov     ax,maxst            ;Push length of destination
         push    ax                  ;fixed-length string.
         extrn   stringassign:proc
         call    stringassign        ;Call BASIC to assign variable-length
                                     ;string to fixed-length string.
         les     ax,s2               ;Push far pointer to second
         push    es                  ;input string descriptor.
         push    ax
         xor     ax,ax               ;Push a zero to indicate
         push    ax                  ;it is variable length.
         push    ds                  ;Push far pointer to
         lea     ax,inbuffer2        ;second destination string.
         push    ax
         mov     ax,maxst            ;Push length of destination
         push    ax                  ;fixed-length string.
         extrn   stringassign:proc
         call    stringassign        ;Call BASIC to assign variable-length
                                     ;string to fixed-length string.
 ;Concatenate strings.
         lea     si,inbuffer1        ;Copy first string to buffer.
         lea     di,outbuffer
         mov     ax,ds
         mov     es,ax
         mov     cx,s1len
         rep     movsb
         lea     si,inbuffer2        ;Concatenate second string to
         mov     cx,s2len            ;end of first.
         rep     movsb

 ;Get BASIC to convert result back into a BASIC string.
         push    ds                  ;Push far pointer to fixed-length
         lea     ax,outbuffer        ;result string.
         push    ax
         mov     ax,s1len            ;Compute total length of
         mov     bx,s2len            ;fixed-length result string.
         add     ax,bx
         push    ax                  ;Push length.
         push    ds                  ;Push far pointer to sh (BASIC
         lea     ax,sh               ;will use this in StringAssign).
         push    ax
         xor     ax,ax               ;Push a zero for length
         push    ax                  ;indicating variable-length.
         call    stringassign        ;Call BASIC to assign the
                                     ;result to sh.
         lea     ax,sh               ;Return output string pointer
                                     ;in ax and go back to BASIC.
         ret

 addstring       endp
                 end


 MXADSTB.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MXADSTB.BAS

 DEFINT A-Z

 'Start program in BASIC for proper initialization.
 ' Define external and internal procedures.
 DECLARE SUB shakespeare ()
 DECLARE SUB StringAssign (BYVAL srcsegment, BYVAL srcoffset, BYVAL srclen, BY
 DECLARE SUB addstring (instrg1off, instrg1len, instrg2off, instrg2len, outstr
 DECLARE SUB StringRelease (s$)

 'Go to main routine in second language
 CALL shakespeare

 'The non-BASIC program calls this SUB to add the two strings together
 SUB addstring (instrg1off, instrg1len, instrg2off, instrg2len, outstrgoff, ou

 'Create variable-length strings and transfer non-BASIC fixed strings to them.
 'Use VARSEG() to compute the segement of the strings returned from the other
 'language--this is the DGROUP segment, and all string descriptors are found
 'in this segment (even though the far string itself is elsewhere).

 CALL StringAssign(VARSEG(a$), instrg1off, instrg1len, VARSEG(a$), VARPTR(a$),
 CALL StringAssign(VARSEG(b$), instrg2off, instrg2len, VARSEG(b$), VARPTR(b$),

 ' Process the strings--in this case, add them.
 c$ = a$ + b$

 ' Calculate the new output length.
 outstrglen = LEN(c$)

 ' Transfer string output to a non-BASIC fixed-length string.
 CALL StringAssign(VARSEG(c$), VARPTR(c$), 0, VARSEG(c$), outstrgoff, outstrgl

 END SUB



 MXADSTC.C
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MXADSTC.C

 #include <string.h>

 /* Function Prototypes force either correct data typing or compiler warnings.
  * Note all functions exported to BASIC and all BASIC callback (extern)
  * functions are declared with the far pascal calling convention.
  * WARNING: This must be compiled with the Medium memory model (/AM)
  */

 char * pascal addstring( char far *s1, int s1len,
               char far *s2, int s2len );
 extern void far pascal StringAssign( char far *source, int slen,
                        char far *dest, int dlen );

 /* Declare global char array to contain new BASIC string descriptor.
  */
 char BASICDesc[4];

 char * pascal addstring( char far *s1, int s1len,
               char far *s2, int s2len )
 {
     char TS1[50];
     char TS2[50];
     char TSBig[100];

     /* Use the BASIC callback StringAssign to retrieve information
      * from the descriptors, s1 and s2, and place them in the temporary
      * arrays TS1 and TS2.
      */
     StringAssign( s1, 0, TS1, 49 );        /* Get S1 as array of char */
     StringAssign( s2, 0, TS2, 49 );        /* Get S2 as array of char */

     /* Copy the data from TS1 into TSBig, then append the data from
      * TS2.
      */
     memcpy( TSBig, TS1, s1len );
     memcpy( &TSBig[s1len], TS2, s2len );

     StringAssign( TSBig, s1len + s2len, BASICDesc, 0 );

     return BASICDesc;
 }

 /*
  * If, for example, we wanted to return not just one variable length string,
  * but rather the variable length string and the reverse of that:
  *
  * call addstring( "foo ", 4, "bar", 3, a$, r$ )
  *
  * you get "foo bar" in a$ and "rab oof" in r$.
  *
  * Say you give me s1, and s2 (and their respective lengths) on input; for
  * output, I want s3 and s4.
  *
  * Change the StringAssign for TSBig to assign to s3 instead of BASICDesc.
  *
  * Add the following lines of code:
  *
  *     TSBig[s1len + s2len] = '\0';
  *     strrev( TSBig );
  *     StringAssign( TSBig, s1len + s2len, s4, 0 );
  *
  * Delete the return statement.
  *
  * Change the prototype and function header to say:
  *
  * void far pascal addstring
  *
  * instead of
  *
  * char far * pascal addstring
  */


 MXADSTF.FOR
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MXADSTF.FOR

 C ******************** ADDSTRING  *********************
 C This program is in file MXADSTF.FOR
 C Declare interface to Stringassign subprogram. The pointer fields are
 C declared INTEGER*4, so that different types of far pointers can be
 C passed without conflict. The INTEGER*4 fields are essentially generic
 C pointers. [VALUE] must be specified, or FORTRAN will pass pointers to
 C pointers. INTEGER*2 also passed by [VALUE], to be consistent with
 C declaration of Stringassign.
 C
        INTERFACE TO SUBROUTINE STRASG [ALIAS:'STRINGASSIGN'] (S,SL,D,DL)
        INTEGER*4 S [VALUE]
        INTEGER*2 SL [VALUE]
        INTEGER*4 D [VALUE]
        INTEGER*2 DL [VALUE]
        END
 C
 C Declare heading of Addstring function in the same way as above: the
 C pointer fields are INTEGER*4
 C
        INTEGER*2 FUNCTION ADDSTR [ALIAS:'ADDSTRING'] (S1,S1LEN,S2,S2LEN)
        INTEGER*4 S1 [VALUE]
        INTEGER*2 S1LEN [VALUE]
        INTEGER*4 S2 [VALUE]
        INTEGER*2 S2LEN [VALUE]
 C
 C Local parameters TS1, TS2, and BIGSTR are temporary strings. STRDES is
 C a four-byte object into which Stringassign will put BASIC string
 C descriptor.
 C
        CHARACTER*50 TS1, TS2
        CHARACTER*100 BIGSTR
        INTEGER*4 STRDES

         TS1 = " "
         TS2 = " "
         STRDES = 0

 C
 C Use the LOCFAR function to take the far address of data. LOCFAR returns
 C a value of type INTEGER*4.
 C
        CALL STRASG (S1, 0, LOCFAR(TS1), S1LEN)
        CALL STRASG (S2, 0, LOCFAR(TS2), S2LEN)
        BIGSTR = TS1(1:S1LEN) // TS2(1:S2LEN)
        CALL STRASG (LOCFAR(BIGSTR), S1LEN+S2LEN, LOCFAR(STRDES), 0)
        ADDSTR = LOC(STRDES)
        RETURN
        END


 MXSHKA.ASM
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MXSHKA.ASM

 ;*************************** SHAKESPEARE ******************************
 ; This program creates two strings and passes them to a BASIC procedure
 ; called addstring (in file MXADSTB.BAS).  This procedure concatenates
 ; the strings and passes the result to MASM which prints it.

         .model  medium,basic        ;Use same memory model as BASIC.
         .stack
         .data                       ;Create the data.
 phrase1         db      "To be or not to be;"
 phrase1len      dw      $-phrase1
 phrase1off      dw      phrase1
 phrase2         db      " that is the question."
 phrase2len      dw      $-phrase2
 phrase2off      dw      phrase2
 sentence        db      100 dup(0)  ;Make room for return data
 sentencelen     dw      0           ;and a length indicator.
 sentenceoff     dw      sentence

         .code
 shakespeare proc    uses si

 ;First call BASIC to concatenate strings.
         lea     ax,phrase1off       ;Push far address of
         push    ax                  ;fixed-length string #1,
         lea     ax,phrase1len       ;and its length.
         push    ax
         lea     ax,phrase2off       ;Do the same for the
         push    ax                  ;address of string #2,
         lea     ax,phrase2len       ;and its length.
         push    ax
         lea     ax,sentenceoff      ;Push far address of
         push    ax                  ;the return string,
         lea     ax,sentencelen      ;and its length.
         push    ax
         extrn   addstring:proc      ;Call BASIC function to
         call    addstring           ;concatenate the strings and
                                     ;put the result in the
                                     ;fixed-length return string.

 ;Call DOS to print string. The DOS string output routine (09H)
 ;requires that strings end with a "$" character.
         mov     bx,sentencelen      ;Go to end of the result string
         lea     si,sentence         ;and add a "$" (24h) character.
         mov     byte ptr [bx + si],24h

         lea     dx,sentence         ;Set up registers
         mov     ah,9                ;and call DOS to
         int     21h                 ;print result string.
         ret

 shakespeare endp

         end


 MXSHKB.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MXSHKB.BAS

 DEFINT A-Z
 'Define non-basic procedures
 DECLARE FUNCTION addstring$(SEG s1$, BYVAL s1length, SEG s2$, BYVAL s2length)


 'Create the data
 a$ = "To be or not to be;"
 b$ = " that is the question."

 'Use non-BASIC function to add two BASIC far strings
 c$ = addstring(a$, LEN(a$), b$, LEN(b$))

 'print the result on the screen

 PRINT c$


 MXSHKC.C
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MXSHKC.C

 #include <stdio.h>
 #include <string.h>

 /* Function Prototypes force either correct data typing or compiler warnings.
  * Note all functions exported to BASIC and all BASIC callback (extern)
  * functions are declared with the far pascal calling convention.
  * IMPORTANT: This must be compiled with the Medium memory model (/AM)
  */
 void far pascal shakespeare( void );
 extern void far pascal addstring( char  ** s1, int * s1len,
                                     char ** s2, int * s2len,
                                     char ** s3, int * s3len );

 void far pascal shakespeare( void )
 {
     char * s1 = "To be or not to be;";
     int  s1len;
     char * s2 = " that is the question.";
     int  s2len;
     char s3[100];
     int  s3len;
     char * s3add = s3;

     s1len = strlen( s1 );
     s2len = strlen( s2 );
     addstring( &s1, &s1len, &s2, &s2len, &s3add, &s3len );

     s3[s3len] = '\0';
     printf("\n%s", s3 );
 }


 MXSHKF.FOR
 CD-ROM Disc Path:   \SAMPCODE\BASIC\MXSHKF.FOR

 C *********************** SHAKESPEARE ****************
 C This program is in file MXSHKF.FOR
 C Declare interface to BASIC routine ADDSTRING.
 C All parameters must be passed NEAR, for compatibility with BASIC's
 C conventions.
 C


        INTERFACE TO SUBROUTINE ADDSTR[ALIAS:'ADDSTRING']
      * (S1,L1,S2,L2,S3,L3)
        INTEGER*2 S1 [NEAR]
        INTEGER*2 L1 [NEAR]
        INTEGER*2 S2 [NEAR]
        INTEGER*2 L2 [NEAR]
        INTEGER*2 S3 [NEAR]
        INTEGER*2 L3 [NEAR]
        END
 C
 C Declare subroutine SHAKESPEARE, which declares two strings, calls BASIC
 C subroutine ADDSTRING, and prints the result.
 C
        SUBROUTINE SHAKES [ALIAS:'SHAKESPEARE']
        CHARACTER*50 STR1, STR2
        CHARACTER*100 STR3
        INTEGER*2 STRLEN1, STRLEN2, STRLEN3
        INTEGER*2 TMP1, TMP2, TMP3
 C
 C The subroutine uses FORTRAN LEN_TRIM function, which returns the length
 C of string, excluding trailing blanks. (All FORTRAN strings are initialized
 C to blanks.)
 C
        STR1 = 'To be or not to be;'
        STRLEN1 = LEN_TRIM(STR1)
        STR2 = ' that is the question.'
        STRLEN2 = LEN_TRIM(STR2)
        TMP1 = LOC(STR1)
        TMP2 = LOC(STR2)
        TMP3 = LOC(STR3)
        CALL ADDSTR (TMP1, STRLEN1, TMP2, STRLEN2, TMP3, STRLEN3)
        WRITE (*,*) STR3
        END



 PALETTE.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\PALETTE.BAS

 DECLARE SUB InitPalette ()
 DECLARE        SUB ChangePalette ()
 DECLARE        SUB DrawEllipses ()

 DEFINT A-Z
 DIM SHARED PaletteArray(15)

 SCREEN 8                 ' 640 x 200 resolution; 16 colors

 InitPalette                 ' Initialize PaletteArray.
 DrawEllipses                 ' Draw and paint concentric ellipses.

 DO                         ' Shift the palette until a key
    ChangePalette         ' is pressed.
 LOOP WHILE INKEY$ = ""

 END


 ' ====================== InitPalette ======================
 '    This procedure initializes the integer array used to
 '    change the palette.
 ' =========================================================

 SUB InitPalette        STATIC
    FOR I = 0 TO        15
       PaletteArray(I) =        I
    NEXT        I
 END SUB
 ' ===================== DrawEllipses ======================
 '    This procedure draws 15 concentric ellipses and
 '    paints the interior of each with a different color.
 ' =========================================================

 SUB DrawEllipses STATIC
    CONST ASPECT        = 1 / 3
    FOR ColorVal        = 15 TO        1 STEP -1
       Radius = 20 * ColorVal
       CIRCLE (320, 100), Radius, ColorVal, , , ASPECT
       PAINT (320, 100),        ColorVal
    NEXT
 END SUB


 ' ===================== ChangePalette =====================
 '  This procedure rotates the palette by one each time it
 '  is called. For example, after the first call to
 '  ChangePalette, PaletteArray(1) = 2, PaletteArray(2) = 3,
 '  . . . , PaletteArray(14) = 15, and PaletteArray(15) = 1
 ' =========================================================

 SUB ChangePalette STATIC
    FOR I = 1 TO        15
       PaletteArray(I) =        (PaletteArray(I) MOD 15) + 1
    NEXT        I
    PALETTE USING PaletteArray(0) ' Shift the color displayed
                                  ' by each of the attributes.
 END SUB



 PASSWRD.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\PASSWRD.BAS

 DECLARE FUNCTION CertifiedOperator% ()
 CONST FALSE = 0, True = NOT FALSE

 IF CertifiedOperator = FALSE THEN
         PRINT "Connection Refused."
         END
 END IF

 PRINT "Connected to Network."
 'Main program continues here.
 '  .
 '  .
 '  .
 END

 FUNCTION CertifiedOperator%
 ON LOCAL ERROR GOTO Handler
 'Count the number of times the operator tries to sign on.
 Attempts% = 0

 TryAgain:
 'Assume the operator has valid credentials.
 CertifiedOperator = True
 'Keep track of bad entries.
 Attempts% = Attempts% + 1
 IF Attempts% > 3 THEN ERROR 255
 'Check out the operator's credentials.
 INPUT "Enter Account Number"; Account$
 IF LEFT$(Account$, 4) <> "1234" THEN ERROR 200
 INPUT "Enter Password"; Password$
 IF Password$ <> "Swordfish" THEN ERROR 201
 EXIT FUNCTION

 Handler:
 SELECT CASE ERR
     'Start over if account number doesn't have "1234" in it.
         CASE 200
                 PRINT "Illegal account number. Please re-enter."
                 RESUME TryAgain
     'Start over if the password is wrong.
         CASE 201
                 PRINT "Wrong password. Please re-enter both items."
                 RESUME TryAgain
     'Return false if operator makes too many mistakes.
         CASE 255
                 CertifiedOperator% = FALSE
                 EXIT FUNCTION
 END SELECT

 END FUNCTION


 PGBAR.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\PGBAR.BAS

 ' PGBAR.BAS:  Create sample bar chart

 DEFINT A-Z
 ' $INCLUDE: 'CHRTB.BI'
 CONST FALSE = 0, TRUE = NOT FALSE, MONTHS = 12
 CONST HIGHESTMODE = 13, TEXTONLY = 0

 DIM Env AS ChartEnvironment                 ' See CHRTB.BI for declaration of
 DIM MonthCategories(1 TO MONTHS) AS STRING  ' Array for categories (used for

 DIM OJvalues(1 TO MONTHS) AS SINGLE         ' Array for 1st data series

 DECLARE FUNCTION BestMode ()

 ' Initialize the data arrays
 FOR index = 1 TO MONTHS: READ OJvalues(index): NEXT index
 FOR index = 1 TO MONTHS: READ MonthCategories$(index): NEXT index

 ' Pass the value returned by the BestMode function to the Presentation
 ' Graphics routine ChartScreen to set the graphics mode for charting

 ChartScreen (BestMode)      ' Even if SCREEN is already set to an acceptable

 IF ChartErr = cBadScreen THEN   ' Check to make sure ChartScreen succeeded
         PRINT "Sorry --- There is a screen-mode problem in the Charting libra
         END
 END IF
 ' Initialize a default pie chart

 DefaultChart Env, cBar, cPlain      ' the constant cBar (for Bar Chart) and


 ' Add Titles and some chart options. These assignments modify some default
 ' values set in the variable Env (of type ChartEnvironment) by DefaultChart

 Env.MainTitle.Title = "Good Neighbor Grocery" ' Specifies text of chart title
 Env.MainTitle.TitleColor = 15                 ' Specifies color of title text
 Env.MainTitle.Justify = cRight                ' How to align of title text
 Env.SubTitle.Title = "Orange Juice Sales"     ' Text of chart subtitle
 Env.SubTitle.TitleColor = 15                  ' Color of subtitle text
 Env.SubTitle.Justify = cRight                 ' How to align of subtitle text
 Env.ChartWindow.Border = cNo                  ' Specifies chart has no border

 ' The next 2 assignments label the x-axis and y-axis
 Env.XAxis.AxisTitle.Title = "Quantity (cases)"
 Env.YAxis.AxisTitle.Title = "Months"

 ' Call the bar-charting routine --- Arguments for call to Chart are:
 ' Env                 - Environment variable
 ' MonthCategories()   - Array containing Category labels
 ' OJvalues()          - Array containing Data values to chart
 ' MONTHS              - Tells number of data values to chart

         Chart Env, MonthCategories(), OJvalues(), MONTHS
         SLEEP
         '  If the rest of your program isn't graphic, reset original mode her
 END

 ' Simulate data generation for chart values and category labels
 DATA 33,27,42,64,106,157,182,217,128,62,43,36
 DATA "Jan","Feb","Mar","Apr","May","Jun","Jly","Aug","Sep","Oct","Nov","Dec",

 '============= Function to determine and set highest resolution ========
 ' The BestMode function uses a local error trap to check available modes,
 ' then assigns the integer representing the best mode for charting to its
 ' name so it is returned to the caller. The function terminate execution if
 ' the hardware doesn't support a mode appropriate for Presentation Graphics
 '========================================================================
 FUNCTION BestMode

 ' Set a trap for an expected local error --- handled within the function
 ON LOCAL ERROR GOTO ScreenError

 FOR TestValue = HIGHESTMODE TO 0 STEP -1
         DisplayError = FALSE
         SCREEN TestValue
         IF DisplayError = FALSE THEN
                 SELECT CASE TestValue
                         CASE 12, 13
                                 BestMode = 12
                         CASE 9, 10, 11
                                 BestMode = 9
                         CASE 8, 4, 3
                                 BestMode = TestValue
                         CASE 2, 7
                                 BestMode = 2
                         CASE 1
                                 BestMode = 1
                         CASE ELSE
                                 PRINT "Sorry, you need graphics to display ch
                                 END
                 END SELECT
                 EXIT FUNCTION
         END IF
 NEXT TestValue
 ' Note there is no need to turn off the local error handler. It is turned off
 ' automatically when control passes out of the function

 EXIT FUNCTION
 '==================== | Local error handler code |=======================
 ' The ScreenError label identifies a local error handler relied in the
 ' BestMode function. Invalid SCREEN values generate Error # 5 (Illegal
 ' function call) --- so if that is not the error reset ERROR to the ERR
 ' value that was generated so the error can be passed to other, possibly
 ' more appropriate errors.
 ScreenError:
         IF ERR = 5 THEN
                 DisplayError = TRUE
                 RESUME NEXT
         ELSE
                 ERROR ERR
         END IF
 END FUNCTION



 PGLINEMS.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\PGLINEMS.BAS

 ' PGLINEMS.BAS - Program to generate a simple multi-data series line chart

 DEFINT A-Z
 '$INCLUDE: 'CHRTB.BI'                 ' Declarations and Definitions
 DIM Env AS ChartEnvironment           ' Variable to hold environment structur
 DIM AxisLabels(1 TO 4) AS STRING      ' Array of categories
 DIM LegendLabels(1 TO 2) AS STRING    ' Array of series labels
 DIM Values(1 TO 4, 1 TO 3) AS SINGLE  ' 2-dimentsion array of values to plot

 DIM Col%(0 TO cPalLen)          ' Define arrays to hold values retrieved with
 DIM Lines%(0 TO cPalLen)        ' call to GetPaletteDef. By modifying these
 DIM Fill$(0 TO cPalLen)         ' values, then calling ResetPaletteDef, you
 DIM Char%(0 TO cPalLen)         ' can change colors, plot characters, borders
 DIM Bord%(0 TO cPalLen)         ' and even the line styles and fill patterns

 ' Read the data to display into the arrays

 FOR index = 1 TO 2: READ LegendLabels(index): NEXT index
 FOR index = 1 TO 4: READ AxisLabels(index): NEXT index

 FOR columnindex = 1 TO 2                ' The array has 2 columns, each of
   FOR rowindex = 1 TO 4                 ' which has 4 rows. Each column rep-
     READ Values(rowindex, columnindex)  ' resents 1 full data series. First,
   NEXT rowindex                         ' fill column 1, then fill column 2
 NEXT columnindex                        ' with values from the last DATA
                                         ' statement (below).
 CLS

 ChartScreen 2                           ' Set a common graphics mode

 ' Retrieve current palette settings, then assign some new values

 GetPaletteDef Col%(), Lines%(), Fill$(), Char%(), Bord%()

  Col%(2) = (15)          '  Assign white as color for second-series plot line
  Char%(1) = (4)          '  Assign  "" as plot character for 1st plot line
  Char%(2) = (18)         '  Assign  "" as plot character for 2nd plot line

 ' Reset the palettes with modified arrays

 SetPaletteDef Col%(), Lines%(), Fill$(), Char%(), Bord%()   ' Enter the chang

 DefaultChart Env, cLine, cLines         ' Set up multi-series line chart

 ' Display the chart

 ChartMS Env, AxisLabels(), Values(), 4, 1, 2, LegendLabels()

 SLEEP                                   ' Keep it onscreen until user presses
                                         ' a key
 END

 ' Simulated data to be shown on chart
 DATA "Qtr 1","Qtr 2"
 DATA "Admn","Markg","Prodn","Devel"
 DATA 38,30,40,32,18,40,20,12



 PGPIE.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\PGPIE.BAS

 ' PGPIE.BAS:  Create sample pie chart

 DEFINT A-Z
 ' $INCLUDE: 'fontb.BI'
 ' $INCLUDE: 'CHRTB.BI'
 CONST FALSE = 0, TRUE = NOT FALSE, MONTHS = 12
 CONST HIGHESTMODE = 13, TEXTONLY = 0

 DIM Env AS ChartEnvironment                 ' See CHRTB.BI for declaration of
 DIM MonthCategories(1 TO MONTHS) AS STRING  ' Array for categories
 DIM OJvalues(1 TO MONTHS) AS SINGLE         ' Array for 1st data series
 DIM Exploded(1 TO MONTHS) AS INTEGER        ' "Explode" flags array (specifie

 DECLARE FUNCTION BestMode ()

 ' Initialize the data arrays
 FOR index = 1 TO MONTHS: READ OJvalues(index): NEXT index
 FOR index = 1 TO MONTHS: READ MonthCategories$(index): NEXT index

 ' Set the elements of the array that determines separation of the pie slices
 FOR Flags = 1 TO MONTHS                       ' If value of OJvalues(Flags)
         Exploded(Flags) = (OJvalues(Flags) >= 100)  ' >= 100 the correspondin
 NEXT Flags                                    ' is set true, separating slice

 ' Pass the value returned by the BestMode function to the Presentation
 ' Graphics routine ChartScreen to set the graphics mode for charting

 ChartScreen (BestMode)      ' Even if SCREEN is already set to an acceptable


 IF ChartErr = cBadScreen THEN   ' Check to make sure ChartScreen succeeded
         PRINT "Sorry --- There is a screen-mode problem in the Charting libra
         END
 END IF

 ' Initialize a default pie chart

 DefaultChart Env, cPie, cPercent    ' the constant cPie (for Pie Chart) and


 ' Add Titles and some chart options. These assignments modify some default
 ' values set in the variable Env (of type ChartEnvironment) by DefaultChart


 Env.MainTitle.Title = "Good Neighbor Grocery" ' Specifies text of chart title
 Env.MainTitle.TitleColor = 15                 ' Specifies color of title text
 Env.MainTitle.Justify = cCenter               ' How to align of title text
 Env.SubTitle.Title = "Orange Juice Sales"     ' Text of chart subtitle
 Env.SubTitle.TitleColor = 11                  ' Color of subtitle text
 Env.SubTitle.Justify = cCenter                ' How to align of subtitle text
 Env.ChartWindow.Border = cYes                 ' Specifies chart has no border

 ' Call the pie-charting routine --- Arguments for call to ChartPie are:
 ' Env                 - Environment variable
 ' MonthCategories()   - Array containing Category labels
 ' OJvalues()          - Array containing Data values to chart
 ' Exploded()          - Integer array tells which pieces of the pie should
 '                         be separated (non-zero=exploded, 0=not exploded)
 ' MONTHS              - Tells number of data values to chart

         ChartPie Env, MonthCategories(), OJvalues(), Exploded(), MONTHS
         SLEEP
         '  If the rest of your program isn't graphic, reset original mode her
 END

 ' Simulate data generation for chart values and category labels
 DATA 33,27,42,64,106,157,182,217,128,62,43,36
 DATA "Jan","Feb","Mar","Apr","May","Jun","Jly","Aug","Sep","Oct","Nov","Dec"

 '============= Function to determine and set highest resolution ========
 ' The BestMode function uses a local error trap to check available modes,
 ' then assigns the integer representing the best mode for charting to its
 ' name so it is returned to the caller. The function terminate execution if
 ' the hardware doesn't support a mode appropriate for Presentation Graphics
 '========================================================================
 FUNCTION BestMode

 ' Set a trap for an expected local error --- handled within the function
 ON LOCAL ERROR GOTO ScreenError

 FOR TestValue = HIGHESTMODE TO 0 STEP -1
         DisplayError = FALSE
         SCREEN TestValue
         IF DisplayError = FALSE THEN
                 SELECT CASE TestValue
                         CASE 12, 13
                                 BestMode = 12
                         CASE 9, 10, 11
                                 BestMode = 9
                         CASE 8, 4, 3
                                 BestMode = TestValue
                         CASE 2, 7
                                 BestMode = 2
                         CASE 1
                                 BestMode = 1
                         CASE ELSE
                                 PRINT "Sorry, you need graphics to display ch
                                 END
                 END SELECT
                 EXIT FUNCTION
         END IF
 NEXT TestValue
 ' Note there is no need to turn off the local error handler. It is turned off
 ' automatically when control passes out of the function

 EXIT FUNCTION
 '==================== | Local error handler code |=======================
 ' The ScreenError label identifies a local error handler relied in the
 ' BestMode function. Invalid SCREEN values generate Error # 5 (Illegal
 ' function call) --- so if that is not the error reset ERROR to the ERR
 ' value that was generated so the error can be passed to other, possibly
 ' more appropriate errors.
 ScreenError:
         IF ERR = 5 THEN
                 DisplayError = TRUE
                 RESUME NEXT
         ELSE
                 ERROR ERR
         END IF
 END FUNCTION



 PGSCAT.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\PGSCAT.BAS

 ' PGSCAT.BAS:  Create sample scatter diagram

 DEFINT A-Z
 ' $INCLUDE: 'CHRTB.BI'
 CONST FALSE = 0, TRUE = NOT FALSE, MONTHS = 12
 CONST HIGHESTMODE = 13, TEXTONLY = 0

 DIM Env AS ChartEnvironment                 ' See CHRTB.BI for declaration of

 DIM OJvalues(1 TO MONTHS) AS SINGLE         ' Array for 1st data series
 DIM HCvalues(1 TO MONTHS) AS SINGLE         ' Array for 2nd data series
 DECLARE FUNCTION BestMode ()

 ' Initialize the data arrays
 FOR index = 1 TO MONTHS: READ OJvalues(index): NEXT index
 FOR index = 1 TO MONTHS: READ HCvalues(index): NEXT index

 ' Pass the value returned by the BestMode function to the Presentation
 ' Graphics routine ChartScreen to set the graphics mode for charting

 ChartScreen (BestMode)      ' Even if SCREEN is already set to an acceptable

 IF ChartErr = cBadScreen THEN   ' Check to make sure ChartScreen succeeded
         PRINT "Sorry --- There is a screen-mode problem in the Charting libra
         END
 END IF

 ' Initialize a default pie chart

 DefaultChart Env, cScatter, cNoLines  ' constant cScatter (for Scatter Chart)


 ' Add Titles and some chart options. These assignments modify some default
 ' values set in the variable Env (of type ChartEnvironment) by DefaultChart

 Env.MainTitle.Title = "Good Neighbor Grocery" ' Specifies text of chart title
 Env.MainTitle.TitleColor = 11                 ' Specifies color of title text
 Env.MainTitle.Justify = cRight                ' How to align of title text
 Env.SubTitle.Title = "OJ vs. Hot Chocolate"   ' Text of chart subtitle
 Env.SubTitle.TitleColor = 15                  ' Color of subtitle text
 Env.SubTitle.Justify = cRight                 ' How to align of subtitle text
 Env.ChartWindow.Border = cNo                  ' Specifies chart has no border

 ' The next two assignments label the x and y axes of the chart
 Env.XAxis.AxisTitle.Title = "Orange Juice Sales"
 Env.YAxis.AxisTitle.Title = "Hot Chocolate Sales"

 ' Call the pie-charting routine --- Arguments for call to ChartPie are:
 ' Env                 - Environment variable
 ' OJvalues            - Array containing orange-juice sales values to chart
 ' HCvalues            - Array containing hot-chocolate sales values to chart
 ' MONTHS              - Tells number of data values to chart

         ChartScatter Env, OJvalues(), HCvalues(), MONTHS
         SLEEP
         '  If the rest of your program isn't graphic, reset original mode her
 END

 ' Simulate data generation for chart values and category labels
 DATA 33,27,42,64,106,157,182,217,128,62,43,36
 DATA 37,37,30,19,10,5,2,1,7,15,28,39

 '============= Function to determine and set highest resolution ========
 ' The BestMode function uses a local error trap to check available modes,
 ' then assigns the integer representing the best mode for charting to its
 ' name so it is returned to the caller. The function terminate execution if
 ' the hardware doesn't support a mode appropriate for Presentation Graphics
 '========================================================================
 FUNCTION BestMode

 ' Set a trap for an expected local error --- handled within the function
 ON LOCAL ERROR GOTO ScreenError

 FOR TestValue = HIGHESTMODE TO 0 STEP -1
         DisplayError = FALSE
         SCREEN TestValue
         IF DisplayError = FALSE THEN
                 SELECT CASE TestValue
                         CASE 12, 13
                                 BestMode = 12
                         CASE 9, 10, 11
                                 BestMode = 9
                         CASE 8, 4, 3
                                 BestMode = TestValue
                         CASE 2, 7
                                 BestMode = 2
                         CASE 1
                                 BestMode = 1
                         CASE ELSE
                                 PRINT "Sorry, you need graphics to display ch
                                 END
                 END SELECT
                 EXIT FUNCTION
         END IF
 NEXT TestValue
 ' Note there is no need to turn off the local error handler. It is turned off
 ' automatically when control passes out of the function

 EXIT FUNCTION
 '==================== | Local error handler code |=======================
 ' The ScreenError label identifies a local error handler relied in the
 ' BestMode function. Invalid SCREEN values generate Error # 5 (Illegal
 ' function call) --- so if that is not the error reset ERROR to the ERR
 ' value that was generated so the error can be passed to other, possibly
 ' more appropriate errors.
 ScreenError:
         IF ERR = 5 THEN
                 DisplayError = TRUE
                 RESUME NEXT
         ELSE
                 ERROR ERR
         END IF
 END FUNCTION



 PLOTTER.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\PLOTTER.BAS

 ' Values for keys on the numeric keypad and the spacebar:
 CONST UP = 72, DOWN = 80, LFT = 75, RGHT = 77
 CONST UPLFT = 71, UPRGHT = 73, DOWNLFT = 79, DOWNRGHT = 81
 CONST SPACEBAR = " "

 ' Null$ is the first character of the two-character INKEY$
 ' value returned for direction keys such as UP and DOWN:
 Null$ = CHR$(0)
 ' Plot$ = "" means draw lines; Plot$ = "B" means
 ' move graphics cursor, but don't draw lines:
 Plot$ = ""

 PRINT "Use the cursor movement keys to draw lines."
 PRINT "Press spacebar to toggle line drawing on and off."
 PRINT "Press <ENTER> to begin. Press q to end the program."
 DO : LOOP WHILE INKEY$ = ""

 SCREEN 1

 DO
    SELECT CASE KeyVal$
       CASE Null$ + CHR$(UP)
          DRAW Plot$ + "C1 U2"
       CASE Null$ + CHR$(DOWN)
          DRAW Plot$ + "C1 D2"
       CASE Null$ + CHR$(LFT)
          DRAW Plot$ + "C2 L2"
       CASE Null$ + CHR$(RGHT)
          DRAW Plot$ + "C2 R2"
       CASE Null$ + CHR$(UPLFT)
          DRAW Plot$ + "C3 H2"
       CASE Null$ + CHR$(UPRGHT)
          DRAW Plot$ + "C3 E2"
       CASE Null$ + CHR$(DOWNLFT)
          DRAW Plot$ + "C3 G2"
       CASE Null$ + CHR$(DOWNRGHT)
          DRAW Plot$ + "C3 F2"
       CASE SPACEBAR
          IF Plot$ = "" THEN Plot$ = "B " ELSE Plot$ = ""
       CASE ELSE
          ' The user pressed some key other than one of the
          ' direction keys, the spacebar, or "q," so
          ' don't do anything.
    END SELECT

    KeyVal$ = INKEY$

 LOOP UNTIL KeyVal$ = "q"

 SCREEN 0, 0                ' Restore the screen to 80-column
 WIDTH 80                ' text mode and end.
 END



 QLBDUMP.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\QLBDUMP.BAS

 'This program prints the names of Quick library procedures.

 DECLARE SUB DumpSym (SymStart AS INTEGER, QHdrPos AS LONG)

 TYPE ExeHdr                   'Part of DOS .EXE header.
      other1    AS STRING * 8  'Other header information.
      CParHdr   AS INTEGER     'Size of header in paragraphs.
      other2    AS STRING * 10 'Other header information.
      IP         AS INTEGER    'Initial IP value.
      CS         AS INTEGER    'Initial (relative) CS value.
 END TYPE
 TYPE QBHdr                    'QLB header.
      QBHead    AS STRING * 6  'QBX specific heading.
      Magic     AS INTEGER     'Magic word: identifies file as a Quick library
      SymStart  AS INTEGER     'Offset from header to first code symbol.
      DatStart  AS INTEGER     'Offset from header to first data symbol.
 END TYPE

 TYPE QbSym                    'QuickLib symbol entry.
      Flags     AS INTEGER     'Symbol flags.
      NameStart AS INTEGER     'Offset into name table.
      other     AS STRING * 4  'Other header information.
 END TYPE

 DIM EHdr AS ExeHdr, Qhdr AS QBHdr, QHdrPos AS LONG

 INPUT "Enter Quick library file name: ", FileName$
 FileName$ = UCASE$(FileName$)
 IF INSTR(FileName$, ".QLB") = 0 THEN FileName$ = FileName$ + ".QLB"
 INPUT "Enter output file name or press ENTER for screen: ", OutFile$
 OutFile$ = UCASE$(OutFile$)
 IF OutFile$ = "" THEN OutFile$ = "CON"

 IF DIR$(FileName$) = "" THEN PRINT "File "; FileName$; " not found.": END

 OPEN FileName$ FOR BINARY AS #1
 OPEN OutFile$ FOR OUTPUT AS #2

 GET #1, , EHdr                     'Read the EXE format header.
 TEMP1& = EHdr.CParHdr + EHdr.CS    'Use a LONG temp to prevent overflow.
 QHdrPos = TEMP1& * 16 + EHdr.IP + 1

 GET #1, QHdrPos, Qhdr              'Read the QuickLib format header.
 IF Qhdr.Magic <> &H6C75 THEN PRINT "Not a valid QBX Quick-Library": END

 PRINT #2, "Code Symbols:": PRINT #2,
 DumpSym Qhdr.SymStart, QHdrPos     'Dump code symbols.
 PRINT #2,
 PRINT #2, "Data Symbols:": PRINT #2, ""
 DumpSym Qhdr.DatStart, QHdrPos     'Dump data symbols.
 PRINT #2,

 END

 SUB DumpSym (SymStart AS INTEGER, QHdrPos AS LONG)
         DIM QlbSym AS QbSym
         DIM NextSym AS LONG, CurrentSym AS LONG

     'Calculate the location of the first symbol entry, then read that entry.
         NextSym = QHdrPos + SymStart
         GET #1, NextSym, QlbSym
 DO
         NextSym = SEEK(1)         'Save the location of the next symbol.
                 CurrentSym = QHdrPos + QlbSym.NameStart
         SEEK #1, CurrentSym       'Use SEEK to move to the name
                                   'for the current symbol entry.
         Prospect$ = INPUT$(40, 1) 'Read the longest legal string,
                                   'plus one additional byte for
                                   'the final null character (CHR$(0)).

         'Extract the null-terminated name.
                 SName$ = LEFT$(Prospect$, INSTR(Prospect$, CHR$(0)))

         'Print only those names that do not begin with "__", "$", or "b$"
         'as these names are usually considered reserved.
                 T$ = LEFT$(SName$, 2)
                 IF T$ <> "__" AND LEFT$(SName$, 1) <> "$" AND UCASE$(T$) <> "
                         PRINT #2, "  " + SName$
                 END IF

         GET #1, NextSym, QlbSym    'Read a symbol entry.
     LOOP WHILE QlbSym.Flags        'Flags=0 (false) means end of table.

 END SUB


 REMLINE.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\REMLINE.BAS

 DEFINT A-Z
 '
 '   Microsoft RemLine - Line Number Removal Utility
 '   Copyright (C) Microsoft Corporation   - 1985, 1986, 1987
 '
 '   REMLINE.BAS is a program to remove line numbers from Microsoft BASIC
 '   Programs. It removes only those line numbers that are not the object
 '   of one of the following statements: GOSUB, RETURN, GOTO, THEN, ELSE,
 '   RESUME, RESTORE, or RUN.
 '
 '   REMLINE is run by typing
 '
 '      REMLINE [<input> [, <output>]]
 '
 '   where <input> is the name of the file to be processed and <output>
 '   is the name of the file or device to receive the reformatted output.
 '   If no extension is given, .BAS is assumed (except for output devices).
 '   If file names are not given, REMLINE prompts for file names. If both
 '   file names are the same, REMLINE saves the original file with the
 '   extension .BAK.
 '
 '   REMLINE makes several assumptions about the program:
 '
 '     1. It must be correct syntactically, and must run in BASICA or
 '        GWBASIC interpreter.
 '     2. There is a 400 line limit. To process larger files, change
 '        MaxLines constant.
 '     3. The first number encountered on a line is considered a line
 '        number; thus some continuation lines (in a compiler specific
 '        constructiion) may not be handled correctly.
 '     4. REMLINE can handle simple statements that test the ERL function
 '        using  relational operators such as =, <, and >. For example,
 '        the following statement is handled correctly:
 '
 '             IF ERL = 100 THEN END
 '
 '        Line 100 is not removed from the source code. However, more
 '        complex expressions that contain the +, -, AND, OR, XOR, EQV,
 '        MOD, or IMP operators may not be handled correctly. For example,
 '        in the following statement REMLINE does not recognize line 105
 '        as a referenced line number and removes it from the source code:
 '
 '             IF ERL + 5 = 105 THEN END
 '
 '   If you do not like the way REMLINE formats its output, you can modify
 '   the output lines in SUB GenOutFile. An example is shown in comments.

 ' Function and Subprogram declarations

 DECLARE FUNCTION GetToken$ (Search$, Delim$)
 DECLARE FUNCTION StrSpn% (InString$, Separator$)
 DECLARE FUNCTION StrBrk% (InString$, Separator$)
 DECLARE FUNCTION IsDigit% (Char$)
 DECLARE SUB GetFileNames ()
 DECLARE SUB BuildTable ()
 DECLARE SUB GenOutFile ()
 DECLARE SUB InitKeyTable ()

 ' Global and constant data

 CONST TRUE = -1
 CONST false = 0
 CONST MaxLines = 400

 DIM SHARED LineTable!(MaxLines)
 DIM SHARED LineCount
 DIM SHARED Seps$, InputFile$, OutputFile$, TmpFile$

 ' Keyword search data

 CONST KeyWordCount = 9
 DIM SHARED KeyWordTable$(KeyWordCount)

 KeyData:
    DATA THEN, ELSE, GOSUB, GOTO, RESUME, RETURN, RESTORE, RUN, ERL, ""

 ' Start of module-level program code

    Seps$ = " ,:=<>()" + CHR$(9)
    InitKeyTable
    GetFileNames
    ON ERROR GOTO FileErr1
    OPEN InputFile$ FOR INPUT AS 1
    ON ERROR GOTO 0
    COLOR 7: PRINT "Working"; : COLOR 23: PRINT " . . .": COLOR 7: PRINT
    BuildTable
    CLOSE #1
    OPEN InputFile$ FOR INPUT AS 1
    ON ERROR GOTO FileErr2
    OPEN OutputFile$ FOR OUTPUT AS 2
    ON ERROR GOTO 0
    GenOutFile
    CLOSE #1, #2
    IF OutputFile$ <> "CON" THEN CLS

 END

 FileErr1:
    CLS
    PRINT "      Invalid file name": PRINT
    INPUT "      New input file name (ENTER to terminate): ", InputFile$
    IF InputFile$ = "" THEN END
 FileErr2:
    INPUT "      Output file name (ENTER to print to screen) :", OutputFile$
    PRINT
    IF (OutputFile$ = "") THEN OutputFile$ = "CON"
    IF TmpFile$ = "" THEN
       RESUME
    ELSE
       TmpFile$ = ""
       RESUME NEXT
    END IF

 '
 ' BuildTable:
 '   Examines the entire text file looking for line numbers that are
 '   the object of GOTO, GOSUB, etc. As each is found, it is entered
 '   into a table of line numbers. The table is used during a second
 '   pass (see GenOutFile), when all line numbers not in the list
 '   are removed.
 ' Input:
 '   Uses globals KeyWordTable$, KeyWordCount, and Seps$
 ' Output:
 '   Modefies LineTable! and LineCount
 '
 SUB BuildTable STATIC

    DO WHILE NOT EOF(1)
       ' Get line and first token
       LINE INPUT #1, InLin$
       token$ = GetToken$(InLin$, Seps$)
       DO WHILE (token$ <> "")
          FOR KeyIndex = 1 TO KeyWordCount
             ' See if token is keyword
             IF (KeyWordTable$(KeyIndex) = UCASE$(token$)) THEN
                ' Get possible line number after keyword
                token$ = GetToken$("", Seps$)
                ' Check each token to see if it is a line number
                ' (the LOOP is necessary for the multiple numbers
                ' of ON GOSUB or ON GOTO). A non-numeric token will
                ' terminate search.
                DO WHILE (IsDigit(LEFT$(token$, 1)))
                   LineCount = LineCount + 1
                   LineTable!(LineCount) = VAL(token$)
                   token$ = GetToken$("", Seps$)
                   IF token$ <> "" THEN KeyIndex = 0
                LOOP
             END IF
          NEXT KeyIndex
          ' Get next token
          token$ = GetToken$("", Seps$)
       LOOP
    LOOP

 END SUB

 '
 ' GenOutFile:
 '  Generates an output file with unreferenced line numbers removed.
 ' Input:
 '  Uses globals LineTable!, LineCount, and Seps$
 ' Output:
 '  Processed file
 '
 SUB GenOutFile STATIC

    ' Speed up by eliminating comma and colon (can't separate first token)
    Sep$ = " " + CHR$(9)
    DO WHILE NOT EOF(1)
       LINE INPUT #1, InLin$
       IF (InLin$ <> "") THEN
          ' Get first token and process if it is a line number
          token$ = GetToken$(InLin$, Sep$)
          IF IsDigit(LEFT$(token$, 1)) THEN
             LineNumber! = VAL(token$)
             FoundNumber = false
             ' See if line number is in table of referenced line numbers
             FOR index = 1 TO LineCount
                IF (LineNumber! = LineTable!(index)) THEN
                   FoundNumber = TRUE
                END IF
             NEXT index
             ' Modify line strings
             IF (NOT FoundNumber) THEN
                token$ = SPACE$(LEN(token$))
                MID$(InLin$, StrSpn(InLin$, Sep$), LEN(token$)) = token$
             END IF

             ' You can replace the previous lines with your own
             ' code to reformat output. For example, try these lines:

             'TmpPos1 = StrSpn(InLin$, Sep$) + LEN(Token$)
             'TmpPos2 = TmpPos1 + StrSpn(MID$(InLin$, TmpPos1), Sep$)
             '
             'IF FoundNumber THEN
             '   InLin$ = LEFT$(InLin$, TmpPos1 - 1) + CHR$(9) + MID$(InLin$,
             'ELSE
             '   InLin$ = CHR$(9) + MID$(InLin$, TmpPos2)
             'END IF

          END IF
       END IF
       ' Print line to file or console (PRINT is faster than console device)
       IF OutputFile$ = "CON" THEN
          PRINT InLin$
       ELSE
          PRINT #2, InLin$
       END IF
    LOOP

 END SUB

 '
 ' GetFileNames:
 '  Gets a file name from COMMAND$ or by prompting the user.
 ' Input:
 '  Used Command$ or user input
 ' Output:
 '  Defines InputFiles$ and OutputFiles$
 '
 SUB GetFileNames STATIC

    IF (COMMAND$ = "") THEN
       CLS
       PRINT " Microsoft RemLine: Line Number Removal Utility"
       PRINT "       (.BAS assumed if no extension given)"
       PRINT
       INPUT "      Input file name (ENTER to terminate): ", InputFile$
       IF InputFile$ = "" THEN END
       INPUT "      Output file name (ENTER to print to screen): ", OutputFile
       PRINT
       IF (OutputFile$ = "") THEN OutputFile$ = "CON"
    ELSE
       InputFile$ = UCASE$(GetToken$(COMMAND$, Seps$))
       OutputFile$ = UCASE$(GetToken$("", Seps$))
       IF (OutputFile$ = "") THEN
          INPUT "      Output file name (ENTER to print to screen): ", OutputF
          PRINT
          IF (OutputFile$ = "") THEN OutputFile$ = "CON"
       END IF
    END IF
    IF INSTR(InputFile$, ".") = 0 THEN
       InputFile$ = InputFile$ + ".BAS"
    END IF
    IF INSTR(OutputFile$, ".") = 0 THEN
       SELECT CASE OutputFile$
          CASE "CON", "SCRN", "PRN", "COM1", "COM2", "LPT1", "LPT2", "LPT3"
             EXIT SUB
          CASE ELSE
             OutputFile$ = OutputFile$ + ".BAS"
       END SELECT
    END IF
    DO WHILE InputFile$ = OutputFile$
       TmpFile$ = LEFT$(InputFile$, INSTR(InputFile$, ".")) + "BAK"
       ON ERROR GOTO FileErr1
       NAME InputFile$ AS TmpFile$
       ON ERROR GOTO 0
       IF TmpFile$ <> "" THEN InputFile$ = TmpFile$
    LOOP

 END SUB

 '
 ' GetToken$:
 '  Extracts tokens from a string. A token is a word that is surrounded
 '  by separators, such as spaces or commas. Tokens are extracted and
 '  analyzed when parsing sentences or commands. To use the GetToken$
 '  function, pass the string to be parsed on the first call, then pass
 '  a null string on subsequent calls until the function returns a null
 '  to indicate that the entire string has been parsed.
 ' Input:
 '  Search$ = string to search
 '  Delim$  = String of separators
 ' Output:
 '  GetToken$ = next token
 '
 FUNCTION GetToken$ (Search$, Delim$) STATIC

    ' Note that SaveStr$ and BegPos must be static from call to call
    ' (other variables are only static for efficiency).
    ' If first call, make a copy of the string
    IF (Search$ <> "") THEN
       BegPos = 1
       SaveStr$ = Search$
    END IF

    ' Find the start of the next token
    NewPos = StrSpn(MID$(SaveStr$, BegPos, LEN(SaveStr$)), Delim$)
    IF NewPos THEN
       ' Set position to start of token
       BegPos = NewPos + BegPos - 1
    ELSE
       ' If no new token, quit and return null
       GetToken$ = ""
       EXIT FUNCTION
    END IF

    ' Find end of token
    NewPos = StrBrk(MID$(SaveStr$, BegPos, LEN(SaveStr$)), Delim$)
    IF NewPos THEN
       ' Set position to end of token
       NewPos = BegPos + NewPos - 1
    ELSE
       ' If no end of token, return set to end a value
       NewPos = LEN(SaveStr$) + 1
    END IF
    ' Cut token out of search string
    GetToken$ = MID$(SaveStr$, BegPos, NewPos - BegPos)
    ' Set new starting position
    BegPos = NewPos

 END FUNCTION

 '
 ' InitKeyTable:
 '  Initializes a keyword table. Keywords must be recognized so that
 '  line numbers can be distinguished from numeric constants.
 ' Input:
 '  Uses KeyData
 ' Output:
 '  Modifies global array KeyWordTable$
 '
 SUB InitKeyTable STATIC

    RESTORE KeyData
    FOR Count = 1 TO KeyWordCount
       READ KeyWord$
       KeyWordTable$(Count) = KeyWord$
    NEXT

 END SUB

 '
 ' IsDigit:
 '  Returns true if character passed is a decimal digit. Since any
 '  BASIC token starting with a digit is a number, the function only
 '  needs to check the first digit. Doesn't check for negative numbers,
 '  but that's not needed here.
 ' Input:
 '  Char$ - initial character of string to check
 ' Output:
 '  IsDigit - true if within 0 - 9
 '
 FUNCTION IsDigit (Char$) STATIC

    IF (Char$ = "") THEN
       IsDigit = false
    ELSE
       CharAsc = ASC(Char$)
       IsDigit = (CharAsc >= ASC("0")) AND (CharAsc <= ASC("9"))
    END IF

 END FUNCTION

 '
 ' StrBrk:
 '  Searches InString$ to find the first character from among those in
 '  Separator$. Returns the index of that character. This function can
 '  be used to find the end of a token.
 ' Input:
 '  InString$ = string to search
 '  Separator$ = characters to search for
 ' Output:
 '  StrBrk = index to first match in InString$ or 0 if none match
 '
 FUNCTION StrBrk (InString$, Separator$) STATIC

    Ln = LEN(InString$)
    BegPos = 1
    ' Look for end of token (first character that is a delimiter).
    DO WHILE INSTR(Separator$, MID$(InString$, BegPos, 1)) = 0
       IF BegPos > Ln THEN
          StrBrk = 0
          EXIT FUNCTION
       ELSE
          BegPos = BegPos + 1
       END IF
    LOOP
    StrBrk = BegPos

 END FUNCTION

 '
 ' StrSpn:
 '  Searches InString$ to find the first character that is not one of
 '  those in Separator$. Returns the index of that character. This
 '  function can be used to find the start of a token.
 ' Input:
 '  InString$ = string to search
 '  Separator$ = characters to search for
 ' Output:
 '  StrSpn = index to first nonmatch in InString$ or 0 if all match
 '
 FUNCTION StrSpn% (InString$, Separator$) STATIC

    Ln = LEN(InString$)
    BegPos = 1
    ' Look for start of a token (character that isn't a delimiter).
    DO WHILE INSTR(Separator$, MID$(InString$, BegPos, 1))
       IF BegPos > Ln THEN
          StrSpn = 0
          EXIT FUNCTION
       ELSE
          BegPos = BegPos + 1
       END IF
    LOOP
    StrSpn = BegPos

 END FUNCTION



 SINEWAVE.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\SINEWAVE.BAS

 SCREEN 2

 ' Viewport sized to proper scale for graph:
 VIEW (20, 2)-(620, 172), , 1
 CONST PI = 3.141592653589#

 ' Make window large enough to graph sine wave from
 ' 0 radians to pi radians:
 WINDOW (0, -1.1)-(2 * PI, 1.1)
 Style% = &HFF00         ' Use to make dashed line.
 VIEW PRINT 23 TO 24  ' Scroll printed output in rows 23, 24.
 DO
         PRINT TAB(20);
         INPUT "Number of cycles (0 to end): ", Cycles
         CLS
         LINE (2 * PI, 0)-(0, 0), , , Style%  ' Draw the x axis.
         IF Cycles > 0 THEN

                 '  Start at (0,0) and plot the graph:
                 FOR X = 0 TO 2 * PI STEP .01
          Y = SIN(Cycles * X) ' Calculate the y coordinate.
          LINE -(X, Y)     ' Draw a line to new point.
                 NEXT X
         END IF
 LOOP WHILE Cycles > 0



 STRTONUM.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\STRTONUM.BAS

 DECLARE FUNCTION Filter$ (Txt$, FilterString$)

 ' Input a line:
 LINE INPUT "Enter a number with commas: "; A$

 ' Look only for valid numeric characters (0123456789.-)
 ' in the input string:
 CleanNum$ = Filter$(A$, "0123456789.-")

 ' Convert the string to a number:
 PRINT "The number's value = "; VAL(CleanNum$)
 END

 ' ========================== FILTER =======================
 '         Takes unwanted characters out of a string by
 '         comparing them with a filter string containing
 '         only acceptable numeric characters
 ' =========================================================

 FUNCTION Filter$ (Txt$, FilterString$) STATIC
    Temp$ = ""
    TxtLength = LEN(Txt$)

    FOR I = 1 TO TxtLength     ' Isolate each character in
       C$ = MID$(Txt$, I, 1)   ' the string.

       ' If the character is in the filter string, save it:
       IF INSTR(FilterString$, C$) <> 0 THEN
          Temp$ = Temp$ + C$
       END IF
    NEXT I

    Filter$ = Temp$
 END FUNCTION



 TERMINAL.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\TERMINAL.BAS

 DEFINT A-Z

 DECLARE        SUB Filter (InString$)

 COLOR 7, 1                        ' Set screen color.
 CLS

 Quit$ = CHR$(0) + CHR$(16)        ' Value returned by INKEY$
                                 ' when ALT+q is pressed.

 ' Set up prompt on bottom line of screen and turn cursor on:
 LOCATE 24, 1, 1
 PRINT STRING$(80, "_");
 LOCATE 25, 1
 PRINT TAB(30); "Press ALT+q to quit";

 VIEW PRINT 1 TO        23                ' Print between lines 1 & 23.

 ' Open communications (1200 baud, no parity, 8-bit data,
 ' 1 stop bit, 256-byte input buffer):
 OPEN "COM1:1200,N,8,1" FOR RANDOM AS #1        LEN = 256

 DO                                ' Main communications loop.

    KeyInput$ = INKEY$                ' Check the keyboard.

    IF KeyInput$        = Quit$        THEN        ' Exit the loop if the user
       EXIT DO                        ' pressed ALT+q.

    ELSEIF KeyInput$ <> "" THEN        ' Otherwise, if the user has
       PRINT #1,        KeyInput$;        ' pressed a key, send the
    END IF                        ' character typed to modem.
  ' Check the modem. If characters are waiting (EOF(1) is
  ' true), get them and print them to the screen:
  IF NOT EOF(1) THEN

       ' LOC(1) gives the number of characters waiting:
       ModemInput$ = INPUT$(LOC(1), #1)

       Filter ModemInput$        ' Filter out line feeds and
       PRINT ModemInput$;        ' backspaces, then print.
    END IF
 LOOP

 CLOSE                                ' End communications.
 CLS
 END
 '
 ' ========================= FILTER ========================
 '               Filters characters in an input string
 ' =========================================================
 '
 SUB Filter (InString$) STATIC

    ' Look for backspace characters and recode
    ' them to CHR$(29) (the LEFT cursor key):
    DO
       BackSpace = INSTR(InString$, CHR$(8))
       IF BackSpace THEN
       MID$(InString$, BackSpace) = CHR$(29)
       END IF
    LOOP WHILE BackSpace

    ' Look for line-feed characters and
    ' remove any found:
    DO
       LnFd = INSTR(InString$, CHR$(10))
       IF LnFd THEN
    InString$=LEFT$(InString$,LnFd-1)+MID$(InString$,LnFd+1)
       END IF
    LOOP WHILE LnFd

 END SUB



 TIMER.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\TIMER.BAS

 ' Declare external MASM procedures.
 DECLARE SUB SetInt
 DECLARE SUB RestInt

 ' Install new interrupt service routine.
 CALL SetInt

 ' Set up the BASIC event handler.
 ON UEVENT GOSUB SpecialTask
 UEVENT ON

 DO
 ' Normal program operation occurs here.
 ' Program ends when any key is pressed.
 LOOP UNTIL INKEY$ <> ""

 ' Restore old interrupt service routine before quitting.
 CALL RestInt

 END

 ' Program branches here every 4.5 seconds.
 SpecialTask:
 ' Code for performing the special task goes here, for example:
 PRINT "Arrived here after 4.5 seconds."
 RETURN



 TIMERA.ASM
 CD-ROM Disc Path:   \SAMPCODE\BASIC\TIMERA.ASM

 ;*************************  TIMERA.ASM  ******************************
 ; This program, along with TIMER.BAS, makes use of the BASIC SetUEvent
 ; routine to print a message on the screen every 4.5 seconds.
 ; This file has three procedures.  SetInt sets up the new DOS interrupt
 ; vector.  EventHandler increments a counter 18 times a second and
 ; notifies BASIC when 4.5 seconds have elapsed.  RestInt restores the
 ; old interrupt vector.

             .model  medium, basic           ;Stay compatible with BASIC.
             .code
 SetInt      proc    uses ds                 ;Get old interrupt vector
             mov     ax, 351CH               ;and save it.
                         int        21h
             mov     word ptr cs:OldVector, bx
             mov     word ptr cs:OldVector + 2, es

             push    cs                      ;Set the new
             pop ds                          ;interrupt vector
             lea dx, EventHandler            ;to the address
             mov ax, 251CH                   ;of our service
             int 21H                         ;routine.
                         ret
 SetInt      endp

 public  EventHandler                        ;Make this routine
                                             ;public for debugging--
 EventHandler    proc                        ;it will check to see if
                 extrn   SetUEvent: proc     ;4.5 seconds have passed.

             push    bx
             lea     bx, TimerTicks
             inc     byte ptr cs:[bx]        ;Have 4.5 seconds elapsed?
             cmp     byte ptr cs:[bx], 82
             jnz     Continue
             mov     byte ptr cs:[bx], 0     ;If true, reset counter,
             push    ax                      ;save registers, and
             push    cx                      ;have BASIC set the
             push    dx                      ;user event flag.
             push    es
             call    SetUevent
             pop     es
             pop     dx                      ;Restore registers.
             pop     cx
             pop     ax
 Continue:
             pop     bx
             jmp     cs:OldVector            ;Continue on with the
                                             ;old service routine.

 TimerTicks  db      0                       ;Keep data in code segment
 OldVector   dd      0                       ;where it can be found no
                                             ;matter where in memory the
 EventHandler    endp                        ;interrupt occurs.

 RestInt     proc    uses ds                 ;Restore the old
             lds     dx, cs:OldVector        ;interrupt vector
             mov     ax, 251CH               ;so things will
             int     21h                     ;keep working when
             ret                             ;this BASIC program is
 RestInt     endp                            ;finished.
                         end


 TOKEN.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\TOKEN.BAS

 ' TOKEN.BAS
 '
 ' Demonstrates a BASIC version of the strtok C function.
 '
 DECLARE FUNCTION StrTok$(Source$,Delimiters$)

 LINE INPUT "Enter string: ",P$
 ' Set up the characters that separate tokens.
 Delimiters$=" ,;:().?"+CHR$(9)+CHR$(34)
 ' Invoke StrTok$ with the string to tokenize.
 Token$=StrTok$(P$,Delimiters$)
 WHILE Token$<>""
    PRINT Token$
    ' Call StrTok$ with a null string so it knows this
    ' isn't the first call.
    Token$=StrTok$("",Delimiters$)
 WEND

 FUNCTION StrTok$(Srce$,Delim$)
 STATIC Start%, SaveStr$

    ' If first call, make a copy of the string.
    IF Srce$<>"" THEN
       Start%=1 : SaveStr$=Srce$
    END IF

    BegPos%=Start% : Ln%=LEN(SaveStr$)
    ' Look for start of a token (character that isn't delimiter).
    WHILE BegPos%<=Ln% AND INSTR(Delim$,MID$(SaveStr$,BegPos%,1))<>0
       BegPos%=BegPos%+1
    WEND
    ' Test for token start found.
    IF BegPos% > Ln% THEN
       StrTok$="" : EXIT FUNCTION
    END IF
    ' Find the end of the token.
    EndPos%=BegPos%
    WHILE EndPos% <= Ln% AND INSTR(Delim$,MID$(SaveStr$,EndPos%,1))=0
       EndPos%=EndPos%+1
    WEND
    StrTok$=MID$(SaveStr$,BegPos%,EndPos%-BegPos%)
    ' Set starting point for search for next token.
    Start%=EndPos%

 END FUNCTION


 TORUS.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\TORUS.BAS

 ' ======================================================================
 '                                TORUS
 '   This program draws a Torus figure. The program accepts user input
 '   to specify various TORUS parameters. It checks the current system
 '   configuration and takes appropriate action to set the best possible
 '   initial mode.
 ' ======================================================================

 DEFINT A-Z
 DECLARE SUB GetConfig ()
 DECLARE SUB SetPalette ()
 DECLARE SUB TorusDefine ()
 DECLARE SUB TorusCalc (T() AS ANY)
 DECLARE SUB TorusColor (T() AS ANY)
 DECLARE SUB TorusSort (Low, High)
 DECLARE SUB TorusDraw (T() AS ANY, Index())
 DECLARE SUB TileDraw (T AS ANY)
 DECLARE SUB TorusRotate (First)
 DECLARE SUB Delay (Seconds!)
 DECLARE SUB CountTiles (T1, T2)
 DECLARE SUB Message (Text$)
 DECLARE SUB SetConfig (mode)
 DECLARE FUNCTION Inside (T AS ANY)
 DECLARE FUNCTION DegToRad! (Degrees)
 DECLARE FUNCTION Rotated (Lower, Upper, Current, Inc)

 ' General purpose constants
 CONST PI = 3.14159
 CONST TRUE = -1, FALSE = 0
 CONST BACK = 0
 CONST TROW = 24, TCOL = 60

 ' Rotation flags
 CONST RNDM = -1
 CONST START = 0
 CONST CONTINUE = 1

 ' Constants for best available screen mode
 CONST VGA = 12
 CONST MCGA = 13
 CONST EGA256 = 9
 CONST EGA64 = 8
 CONST MONO = 10
 CONST HERC = 3
 CONST CGA = 1

 ' User-defined type for tiles - an array of these make a torus
 TYPE Tile
    x1    AS SINGLE
    x2    AS SINGLE
    x3    AS SINGLE
    x4    AS SINGLE
    y1    AS SINGLE
    y2    AS SINGLE
    y3    AS SINGLE
    y4    AS SINGLE
    z1    AS SINGLE
    xc    AS SINGLE
    yc    AS SINGLE
    TColor AS INTEGER
 END TYPE

 ' User-defined type to hold information about the mode
 TYPE Config
    Scrn     AS INTEGER
    Colors   AS INTEGER
    Atribs   AS INTEGER
    XPix     AS INTEGER
    YPix     AS INTEGER
    TCOL     AS INTEGER
    TROW     AS INTEGER
 END TYPE

 DIM VC AS Config

 ' User-defined type to hold information about current Torus
 TYPE TORUS
    Panel    AS INTEGER
    Sect     AS INTEGER
    Thick    AS SINGLE
    XDegree  AS INTEGER
    YDegree  AS INTEGER
    Bord     AS STRING * 3
    Delay    AS SINGLE
 END TYPE

 DIM TOR AS TORUS, Max AS INTEGER

 ' A palette of colors to paint with
 DIM Pal(0 TO 300) AS LONG

 ' Error variables to check screen type
 DIM InitRows AS INTEGER, BestMode AS INTEGER, Available AS STRING

 ' The code of the module-level program begins here

    ' Initialize defaults
    TOR.Thick = 3: TOR.Bord = "YES"
    TOR.Panel = 8: TOR.Sect = 14
    TOR.XDegree = 60: TOR.YDegree = 165

    ' Get best configuration and set initial graphics mode to it
    GetConfig
    VC.Scrn = BestMode

    DO WHILE TRUE           ' Loop forever (exit is from within a SUB)

       ' Get Torus definition from user
       TorusDefine

       ' Dynamically dimension arrays
       DO
          Tmp = TOR.Panel
          Max = TOR.Panel * TOR.Sect

          ' Array for indexes
          REDIM Index(0 TO Max - 1) AS INTEGER
          ' Turn on error trap for insufficient memory
          ON ERROR GOTO MemErr
          ' Array for tiles
          REDIM T(0 TO Max - 1) AS Tile
          ON ERROR GOTO 0
       LOOP UNTIL Tmp = TOR.Panel

       ' Initialize array of indexes
       FOR Til = 0 TO Max - 1
          Index(Til) = Til
       NEXT

       ' Calculate the points of each tile on the torus
       Message "Calculating"
       TorusCalc T()

       ' Color each tile in the torus.
       TorusColor T()

       ' Sort the tiles by their "distance" from the screen
       Message "Sorting"
       TorusSort 0, Max - 1

       ' Set the screen mode
       SCREEN VC.Scrn

       ' Mix a palette of colors
       SetPalette

       ' Set logical window with variable thickness
       ' Center is 0, up and right are positive, down and left are negative
       WINDOW (-(TOR.Thick + 1), -(TOR.Thick + 1))-(TOR.Thick + 1, TOR.Thick +

       ' Draw and paint the tiles, the farthest first and nearest last
       TorusDraw T(), Index()

       ' Rotate the torus by rotating the color palette
       DO WHILE INKEY$ = ""
          Delay (TOR.Delay)
          TorusRotate CONTINUE
       LOOP
       SCREEN 0
       WIDTH 80
    LOOP

    ' Restore original rows
    WIDTH 80, InitRows

 END

 ' Error trap to make torus screen independent
 VideoErr:
    SELECT CASE BestMode    ' Fall through until something works
       CASE VGA
          BestMode = MCGA
          Available = "12BD"
       CASE MCGA
          BestMode = EGA256
          Available = "12789"
       CASE EGA256
          BestMode = CGA
          Available = "12"
       CASE CGA
          BestMode = MONO
          Available = "A"
       CASE MONO
          BestMode = HERC
          Available = "3"
       CASE ELSE
          PRINT "Sorry. Graphics not available. Can't run Torus."
          END
    END SELECT
    RESUME

 ' Trap to detect 64K EGA
 EGAErr:
    BestMode = EGA64
    Available = "12789"
    RESUME NEXT

 ' Trap to detect insufficient memory for large Torus
 MemErr:
    LOCATE 22, 1
    PRINT "Out of memory"
    PRINT "Reducing panels from"; TOR.Panel; "to"; TOR.Panel - 1
    PRINT "Reducing sections from"; TOR.Sect; "to"; TOR.Sect - 1;
    DO WHILE INKEY$ = "": LOOP
    TOR.Panel = TOR.Panel - 1
    TOR.Sect = TOR.Sect - 1
    RESUME NEXT

 ' Trap to determine initial number of rows so they can be restored
 RowErr:
    IF InitRows = 50 THEN
       InitRows = 43
       RESUME
    ELSE
       InitRows = 25
       RESUME NEXT
    END IF

 ' ============================ CountTiles ==============================
 '   Displays number of the tiles currently being calculated or sorted.
 ' ======================================================================
 '
 SUB CountTiles (T1, T2) STATIC

    ' Erase previous
    LOCATE TROW - 1, TCOL: PRINT SPACE$(19);
    ' If positive, display - give negative values to erase
    IF T1 > 0 AND T2 > 0 THEN
       LOCATE TROW - 1, TCOL
       PRINT "Tile ";
       PRINT USING " ###"; T1;
       PRINT USING " ###"; T2;
    END IF

 END SUB

 ' ============================ DegToRad ================================
 '   Convert degrees to radians, since BASIC trigonometric functions
 '   require radians.
 ' ======================================================================
 '
 FUNCTION DegToRad! (Degrees) STATIC

    DegToRad! = (Degrees * 2 * PI) / 360

 END FUNCTION

 ' =============================== Delay ================================
 '   Delay based on time so that wait will be the same on any processor.
 '   Notice the check for negative numbers so that the delay won't
 '   freeze at midnight when the delay could become negative.
 ' ======================================================================
 '
 SUB Delay (Seconds!) STATIC

    Begin! = TIMER
    DO UNTIL (TIMER - Begin! > Seconds!) OR (TIMER - Begin! < 0)
    LOOP

 END SUB

 ' ============================ GetConfig ===============================
 '   Get the starting number of lines and the video adapter.
 ' ======================================================================
 '
 SUB GetConfig STATIC
 SHARED InitRows AS INTEGER, BestMode AS INTEGER, Available AS STRING

    ' Assume 50 line display and fall through error
    ' until we get the actual number
    InitRows = 50
    ON ERROR GOTO RowErr
    LOCATE InitRows, 1

    ' Assume best possible screen mode
    BestMode = VGA
    Available = "12789BCD"

    ON ERROR GOTO VideoErr
    ' Fall through error trap until a mode works
    SCREEN BestMode
    ' If EGA, then check pages to see whether more than 64K
    ON ERROR GOTO EGAErr
    IF BestMode = EGA256 THEN SCREEN 8, , 1

    ON ERROR GOTO 0

    ' Reset text mode
    SCREEN 0, , 0
    WIDTH 80, 25

 END SUB

 ' ============================== Inside ================================
 '   Finds a point, T.xc and T.yc, that is mathematically within a tile.
 '   Then check to see if the point is actually inside. Because of the
 '   jagged edges of tiles, the center point is often actually inside
 '   very thin tiles. Such tiles will not be painted, This causes
 '   imperfections that are often visible at the edge of the Torus.
 '
 '   Return FALSE if a center point is not found inside a tile.
 ' ======================================================================
 '
 FUNCTION Inside (T AS Tile) STATIC
 SHARED VC AS Config
 DIM Highest AS SINGLE, Lowest AS SINGLE

    Border = VC.Atribs - 1

    ' Find an inside point. Since some tiles are triangles, the
    ' diagonal center isn't good enough. Instead find the center
    ' by drawing a diagonal from the center of the outside to
    ' a bottom corner.
    T.xc = T.x2 + ((T.x3 + (T.x4 - T.x3) / 2 - T.x2) / 2)
    T.yc = T.y2 + ((T.y3 + (T.y4 - T.y3) / 2 - T.y2) / 2)

    ' If we're on a border, no need to fill
    IF POINT(T.xc, T.yc) = Border THEN
       Inside = FALSE
       EXIT FUNCTION
    END IF

    ' Find highest and lowest Y on the tile
    Highest = T.y1
    Lowest = T.y1
    IF T.y2 > Highest THEN Highest = T.y2
    IF T.y2 < Lowest THEN Lowest = T.y2
    IF T.y3 > Highest THEN Highest = T.y3
    IF T.y3 < Lowest THEN Lowest = T.y3
    IF T.y4 > Highest THEN Highest = T.y4
    IF T.y4 < Lowest THEN Lowest = T.y4

    ' Convert coordinates to pixels
    X = PMAP(T.xc, 0)
    YU = PMAP(T.yc, 1)
    YD = YU
    H = PMAP(Highest, 1)
    L = PMAP(Lowest, 1)

    ' Search for top and bottom tile borders until we either find them
    ' both, or check beyond the highest and lowest points.

    IsUp = FALSE
    IsDown = FALSE

    DO
       YU = YU - 1
       YD = YD + 1

       ' Search up
       IF NOT IsUp THEN
          IF POINT(T.xc, PMAP(YU, 3)) = Border THEN IsUp = TRUE
       END IF

       ' Search down
       IF NOT IsDown THEN
          IF POINT(T.xc, PMAP(YD, 3)) = Border THEN IsDown = TRUE
       END IF

       ' If top and bottom are found, we're inside
       IF IsUp AND IsDown THEN
          Inside = TRUE
          EXIT FUNCTION
       END IF

    LOOP UNTIL (YD > L) AND (YU < H)
    Inside = FALSE

 END FUNCTION

 ' ============================= Message ================================
 '   Displays a status message followed by blinking dots.
 ' ======================================================================
 '
 SUB Message (Text$) STATIC
 SHARED VC AS Config

    LOCATE TROW, TCOL: PRINT SPACE$(19);
    LOCATE TROW, TCOL
    COLOR 7       ' White
    PRINT Text$;
    COLOR 23      ' Blink
    PRINT " . . .";
    COLOR 7       ' White

 END SUB

 ' ============================ Rotated =================================
 '   Returns the Current value adjusted by Inc and rotated if necessary
 '   so that it falls within the range of Lower and Upper.
 ' ======================================================================
 '
 FUNCTION Rotated (Lower, Upper, Current, Inc)

    ' Calculate the next value
    Current = Current + Inc

    ' Handle special cases of rotating off top or bottom
    IF Current > Upper THEN Current = Lower
    IF Current < Lower THEN Current = Upper
    Rotated = Current

 END FUNCTION

 ' ============================ SetConfig ===============================
 '   Sets the correct values for each field of the VC variable. They
 '   vary depending on Mode and on the current configuration.
 ' ======================================================================
 '
 SUB SetConfig (mode AS INTEGER) STATIC
 SHARED VC AS Config, BestMode AS INTEGER

    SELECT CASE mode
       CASE 1   ' Four-color graphics for CGA, EGA, VGA, and MCGA
          IF BestMode = CGA OR BestMode = MCGA THEN
             VC.Colors = 0
          ELSE
             VC.Colors = 16
          END IF
          VC.Atribs = 4
          VC.XPix = 319
          VC.YPix = 199
          VC.TCOL = 40
          VC.TROW = 25
       CASE 2   ' Two-color medium-res graphics for CGA, EGA, VGA, and MCGA
          IF BestMode = CGA OR BestMode = MCGA THEN
             VC.Colors = 0
          ELSE
             VC.Colors = 16
          END IF
          VC.Atribs = 2
          VC.XPix = 639
          VC.YPix = 199
          VC.TCOL = 80
          VC.TROW = 25
       CASE 3   ' Two-color high-res graphics for Hercules
          VC.Colors = 0
          VC.Atribs = 2
          VC.XPix = 720
          VC.YPix = 348
          VC.TCOL = 80
          VC.TROW = 25
       CASE 7   ' 16-color medium-res graphics for EGA and VGA
          VC.Colors = 16
          VC.Atribs = 16
          VC.XPix = 319
          VC.YPix = 199
          VC.TCOL = 40
          VC.TROW = 25
       CASE 8   ' 16-color high-res graphics for EGA and VGA
          VC.Colors = 16
          VC.Atribs = 16
          VC.XPix = 639
          VC.YPix = 199
          VC.TCOL = 80
          VC.TROW = 25
       CASE 9   ' 16- or 4-color very high-res graphics for EGA and VGA
          VC.Colors = 64
          IF BestMode = EGA64 THEN VC.Atribs = 4 ELSE VC.Atribs = 16
          VC.XPix = 639
          VC.YPix = 349
          VC.TCOL = 80
          VC.TROW = 25
       CASE 10  ' Two-color high-res graphics for EGA or VGA monochrome
          VC.Colors = 0
          VC.Atribs = 2
          VC.XPix = 319
          VC.YPix = 199
          VC.TCOL = 80
          VC.TROW = 25
       CASE 11  ' Two-color very high-res graphics for VGA and MCGA
          ' Note that for VGA screens 11, 12, and 13, more colors are
          ' available, depending on how the colors are mixed.
          VC.Colors = 216
          VC.Atribs = 2
          VC.XPix = 639
          VC.YPix = 479
          VC.TCOL = 80
          VC.TROW = 30
       CASE 12  ' 16-color very high-res graphics for VGA
          VC.Colors = 216
          VC.Atribs = 16
          VC.XPix = 639
          VC.YPix = 479
          VC.TCOL = 80
          VC.TROW = 30
       CASE 13  ' 256-color medium-res graphics for VGA and MCGA
          VC.Colors = 216
          VC.Atribs = 256
          VC.XPix = 639
          VC.YPix = 479
          VC.TCOL = 40
          VC.TROW = 25
       CASE ELSE
          VC.Colors = 16
          VC.Atribs = 16
          VC.XPix = 0
          VC.YPix = 0
          VC.TCOL = 80
          VC.TROW = 25
          VC.Scrn = 0
          EXIT SUB
    END SELECT
    VC.Scrn = mode

 END SUB

 ' ============================ SetPalette ==============================
 '   Mixes palette colors in an array.
 ' ======================================================================
 '
 SUB SetPalette STATIC
 SHARED VC AS Config, Pal() AS LONG

    ' Mix only if the adapter supports color attributes
    IF VC.Colors THEN
       SELECT CASE VC.Scrn
          CASE 1, 2, 7, 8
             ' Red, green, blue, and intense in four bits of a byte
             ' Bits: 0000irgb
             ' Change the order of FOR loops to change color mix
             Index = 0
             FOR Bs = 0 TO 1
                FOR Gs = 0 TO 1
                   FOR Rs = 0 TO 1
                      FOR Hs = 0 TO 1
                         Pal(Index) = Hs * 8 + Rs * 4 + Gs * 2 + Bs
                         Index = Index + 1
                      NEXT
                   NEXT
                NEXT
             NEXT
          CASE 9
             ' EGA red, green, and blue colors in 6 bits of a byte
             ' Capital letters repesent intense, lowercase normal
             ' Bits:  00rgbRGB
             ' Change the order of FOR loops to change color mix
             Index = 0
             FOR Bs = 0 TO 1
                FOR Gs = 0 TO 1
                   FOR Rs = 0 TO 1
                      FOR HRs = 0 TO 1
                         FOR HGs = 0 TO 1
                            FOR HBs = 0 TO 1
                               Pal(Index) = Rs * 32 + Gs * 16 + Bs * 8 + HRs *
                               Index = Index + 1
                            NEXT
                         NEXT
                      NEXT
                   NEXT
                NEXT
             NEXT
          CASE 11, 12, 13
             ' VGA colors in 6 bits of 3 bytes of a long integer
             ' Bits:  000000000 00bbbbbb 00gggggg 00rrrrrr
             ' Change the order of FOR loops to change color mix
             ' Decrease the STEP and increase VC.Colors to get more colors
             Index = 0
             FOR Rs = 0 TO 63 STEP 11
                FOR Bs = 0 TO 63 STEP 11
                   FOR Gs = 0 TO 63 STEP 11
                      Pal(Index) = (65536 * Bs) + (256 * Gs) + Rs
                      Index = Index + 1
                   NEXT
                NEXT
             NEXT
          CASE ELSE
       END SELECT
       ' Assign colors
       IF VC.Atribs > 2 THEN TorusRotate RNDM
    END IF

 END SUB

 ' ============================ TileDraw ================================
 '   Draw and optionally paint a tile. Tiles are painted if there are
 '   more than two atributes and if the inside of the tile can be found.
 ' ======================================================================
 '
 SUB TileDraw (T AS Tile) STATIC
 SHARED VC AS Config, TOR AS TORUS

    'Set border
    Border = VC.Atribs - 1

    IF VC.Atribs = 2 THEN
       ' Draw and quit for two-color modes
       LINE (T.x1, T.y1)-(T.x2, T.y2), T.TColor
       LINE -(T.x3, T.y3), T.TColor
       LINE -(T.x4, T.y4), T.TColor
       LINE -(T.x1, T.y1), T.TColor
       EXIT SUB
    ELSE
       ' For other modes, draw in the border color
       ' (which must be different than any tile color)
       LINE (T.x1, T.y1)-(T.x2, T.y2), Border
       LINE -(T.x3, T.y3), Border
       LINE -(T.x4, T.y4), Border
       LINE -(T.x1, T.y1), Border
    END IF

    ' See if tile is large enough to be painted
    IF Inside(T) THEN
       'Black out the center to make sure it isn't paint color
       PRESET (T.xc, T.yc)
       ' Paint tile black so colors of underlying tiles can't interfere
       PAINT STEP(0, 0), BACK, Border
       ' Fill with the final tile color.
       PAINT STEP(0, 0), T.TColor, Border
    END IF

    ' A border drawn with the background color looks like a border.
    ' One drawn with the tile color doesn't look like a border.
    IF TOR.Bord = "YES" THEN
       Border = BACK
    ELSE
       Border = T.TColor
    END IF

    ' Redraw with the final border
    LINE (T.x1, T.y1)-(T.x2, T.y2), Border
    LINE -(T.x3, T.y3), Border
    LINE -(T.x4, T.y4), Border
    LINE -(T.x1, T.y1), Border

 END SUB

 DEFSNG A-Z
 ' =========================== TorusCalc ================================
 '   Calculates the x and y coordinates for each tile.
 ' ======================================================================
 '
 SUB TorusCalc (T() AS Tile) STATIC
 SHARED TOR AS TORUS, Max AS INTEGER
 DIM XSect AS INTEGER, YPanel AS INTEGER

    ' Calculate sine and cosine of the angles of rotation
    XRot = DegToRad(TOR.XDegree)
    YRot = DegToRad(TOR.YDegree)
    CXRot = COS(XRot)
    SXRot = SIN(XRot)
    CYRot = COS(YRot)
    SYRot = SIN(YRot)

    ' Calculate the angle to increment between one tile and the next.
    XInc = 2 * PI / TOR.Sect
    YInc = 2 * PI / TOR.Panel

    ' First calculate the first point, which will be used as a reference
    ' for future points. This point must be calculated separately because
    ' it is both the beginning and the end of the center seam.
    FirstY = (TOR.Thick + 1) * CYRot

    ' Starting point is x1 of 0 section, 0 panel     last     0
    T(0).x1 = FirstY                             ' +------+------+
    ' Also x2 of tile on last section, 0 panel   ' |      |      | last
    T(TOR.Sect - 1).x2 = FirstY                  ' |    x3|x4    |
    ' Also x3 of last section, last panel        ' +------+------+
    T(Max - 1).x3 = FirstY                       ' |    x2|x1    |  0
    ' Also x4 of 0 section, last panel           ' |      |      |
    T(Max - TOR.Sect).x4 = FirstY                ' +------+------+
    ' A similar pattern is used for assigning all points of Torus

    ' Starting Y point is 0 (center)
    T(0).y1 = 0
    T(TOR.Sect - 1).y2 = 0
    T(Max - 1).y3 = 0
    T(Max - TOR.Sect).y4 = 0

    ' Only one z coordinate is used in sort, so other three can be ignored
    T(0).z1 = -(TOR.Thick + 1) * SYRot

    ' Starting at first point, work around the center seam of the Torus.
    ' Assign points for each section. The seam must be calculated separately
    ' because it is both beginning and of each section.
    FOR XSect = 1 TO TOR.Sect - 1

       ' X, Y, and Z elements of equation
       sx = (TOR.Thick + 1) * COS(XSect * XInc)
       sy = (TOR.Thick + 1) * SIN(XSect * XInc) * CXRot
       sz = (TOR.Thick + 1) * SIN(XSect * XInc) * SXRot
       ssx = (sz * SYRot) + (sx * CYRot)

       T(XSect).x1 = ssx
       T(XSect - 1).x2 = ssx
       T(Max - TOR.Sect + XSect - 1).x3 = ssx
       T(Max - TOR.Sect + XSect).x4 = ssx

       T(XSect).y1 = sy
       T(XSect - 1).y2 = sy
       T(Max - TOR.Sect + XSect - 1).y3 = sy
       T(Max - TOR.Sect + XSect).y4 = sy

       T(XSect).z1 = (sz * CYRot) - (sx * SYRot)
    NEXT

    ' Now start at the first seam between panel and assign points for
    ' each section of each panel. The outer loop assigns the initial
    ' point for the panel. This point must be calculated separately
    ' since it is both the beginning and the end of the seam of panels.
    FOR YPanel = 1 TO TOR.Panel - 1

       ' X, Y, and Z elements of equation
       sx = TOR.Thick + COS(YPanel * YInc)
       sy = -SIN(YPanel * YInc) * SXRot
       sz = SIN(YPanel * YInc) * CXRot
       ssx = (sz * SYRot) + (sx * CYRot)

       ' Assign X points for each panel
       ' Current ring, current side
       T(TOR.Sect * YPanel).x1 = ssx
       ' Current ring minus 1, next side
       T(TOR.Sect * (YPanel + 1) - 1).x2 = ssx
       ' Current ring minus 1, previous side
       T(TOR.Sect * YPanel - 1).x3 = ssx
       ' Current ring, previous side
       T(TOR.Sect * (YPanel - 1)).x4 = ssx

       ' Assign Y points for each panel
       T(TOR.Sect * YPanel).y1 = sy
       T(TOR.Sect * (YPanel + 1) - 1).y2 = sy
       T(TOR.Sect * YPanel - 1).y3 = sy
       T(TOR.Sect * (YPanel - 1)).y4 = sy

       ' Z point for each panel
       T(TOR.Sect * YPanel).z1 = (sz * CYRot) - (sx * SYRot)

       ' The inner loop assigns points for each ring (except the first)
       ' on the current side.
       FOR XSect = 1 TO TOR.Sect - 1

          ' Display section and panel
          CountTiles XSect, YPanel

          ty = (TOR.Thick + COS(YPanel * YInc)) * SIN(XSect * XInc)
          tz = SIN(YPanel * YInc)
          sx = (TOR.Thick + COS(YPanel * YInc)) * COS(XSect * XInc)
          sy = ty * CXRot - tz * SXRot
          sz = ty * SXRot + tz * CXRot
          ssx = (sz * SYRot) + (sx * CYRot)

          T(TOR.Sect * YPanel + XSect).x1 = ssx
          T(TOR.Sect * YPanel + XSect - 1).x2 = ssx
          T(TOR.Sect * (YPanel - 1) + XSect - 1).x3 = ssx
          T(TOR.Sect * (YPanel - 1) + XSect).x4 = ssx

          T(TOR.Sect * YPanel + XSect).y1 = sy
          T(TOR.Sect * YPanel + XSect - 1).y2 = sy
          T(TOR.Sect * (YPanel - 1) + XSect - 1).y3 = sy
          T(TOR.Sect * (YPanel - 1) + XSect).y4 = sy

          T(TOR.Sect * YPanel + XSect).z1 = (sz * CYRot) - (sx * SYRot)
       NEXT
    NEXT
    ' Erase message
    CountTiles -1, -1

 END SUB

 DEFINT A-Z
 ' =========================== TorusColor ===============================
 '   Assigns color atributes to each tile.
 ' ======================================================================
 '
 SUB TorusColor (T() AS Tile) STATIC
 SHARED VC AS Config, Max AS INTEGER

    ' Skip first and last atributes
    LastAtr = VC.Atribs - 2
    Atr = 1

    ' Cycle through each attribute until all tiles are done
    FOR Til = 0 TO Max - 1
       IF (Atr >= LastAtr) THEN
          Atr = 1
       ELSE
          Atr = Atr + 1
       END IF
       T(Til).TColor = Atr
    NEXT

 END SUB

 ' ============================ TorusDefine =============================
 '   Define the attributes of a Torus based on information from the
 '   user, the video configuration, and the current screen mode.
 ' ======================================================================
 '
 SUB TorusDefine STATIC
 SHARED VC AS Config, TOR AS TORUS, Available AS STRING

 ' Constants for key codes and column positions
 CONST ENTER = 13, ESCAPE = 27
 CONST DOWNARROW = 80, UPARROW = 72, LEFTARROW = 75, RIGHTARROW = 77
 CONST COL1 = 20, COL2 = 50, ROW = 9

    ' Display key instructions
    LOCATE 1, COL1
    PRINT "UP .............. Move to next field"
    LOCATE 2, COL1
    PRINT "DOWN ........ Move to previous field"
    LOCATE 3, COL1
    PRINT "LEFT ......... Rotate field value up"
    LOCATE 4, COL1
    PRINT "RIGHT ...... Rotate field value down"
    LOCATE 5, COL1
    PRINT "ENTER .... Start with current values"
    LOCATE 6, COL1
    PRINT "ESCAPE .................. Quit Torus"

    ' Block cursor
    LOCATE ROW, COL1, 1, 1, 12
    ' Display fields
    LOCATE ROW, COL1: PRINT "Thickness";
    LOCATE ROW, COL2: PRINT USING "[ # ]"; TOR.Thick;

    LOCATE ROW + 2, COL1: PRINT "Panels per Section";
    LOCATE ROW + 2, COL2: PRINT USING "[ ## ]"; TOR.Panel;

    LOCATE ROW + 4, COL1: PRINT "Sections per Torus";
    LOCATE ROW + 4, COL2: PRINT USING "[ ## ]"; TOR.Sect;

    LOCATE ROW + 6, COL1: PRINT "Tilt around Horizontal Axis";
    LOCATE ROW + 6, COL2: PRINT USING "[ ### ]"; TOR.XDegree;

    LOCATE ROW + 8, COL1: PRINT "Tilt around Vertical Axis";
    LOCATE ROW + 8, COL2: PRINT USING "[ ### ]"; TOR.YDegree;

    LOCATE ROW + 10, COL1: PRINT "Tile Border";
    LOCATE ROW + 10, COL2: PRINT USING "[ & ] "; TOR.Bord;

    LOCATE ROW + 12, COL1: PRINT "Screen Mode";
    LOCATE ROW + 12, COL2: PRINT USING "[ ## ]"; VC.Scrn

    ' Skip field 10 if there's only one value
    IF LEN(Available$) = 1 THEN Fields = 10 ELSE Fields = 12

    ' Update field values and position based on keystrokes
    DO
       ' Put cursor on field
       LOCATE ROW + Fld, COL2 + 2
       ' Get a key and strip null off if it's an extended code
       DO
          K$ = INKEY$
       LOOP WHILE K$ = ""
       Ky = ASC(RIGHT$(K$, 1))

       SELECT CASE Ky
          CASE ESCAPE
             ' End program
             CLS : END
          CASE UPARROW, DOWNARROW
             ' Adjust field location
             IF Ky = DOWNARROW THEN Inc = 2 ELSE Inc = -2
             Fld = Rotated(0, Fields, Fld, Inc)
          CASE RIGHTARROW, LEFTARROW
             ' Adjust field
             IF Ky = RIGHTARROW THEN Inc = 1 ELSE Inc = -1
             SELECT CASE Fld
                CASE 0
                   ' Thickness
                   TOR.Thick = Rotated(1, 9, INT(TOR.Thick), Inc)
                   PRINT USING "#"; TOR.Thick
                CASE 2
                   ' Panels
                   TOR.Panel = Rotated(6, 20, TOR.Panel, Inc)
                   PRINT USING "##"; TOR.Panel
                CASE 4
                   ' Sections
                   TOR.Sect = Rotated(6, 20, TOR.Sect, Inc)
                   PRINT USING "##"; TOR.Sect
                CASE 6
                   ' Horizontal tilt
                   TOR.XDegree = Rotated(0, 345, TOR.XDegree, (15 * Inc))
                   PRINT USING "###"; TOR.XDegree
                CASE 8
                   ' Vertical tilt
                   TOR.YDegree = Rotated(0, 345, TOR.YDegree, (15 * Inc))
                   PRINT USING "###"; TOR.YDegree
                CASE 10
                   ' Border
                   IF VC.Atribs > 2 THEN
                      IF TOR.Bord = "YES" THEN
                         TOR.Bord = "NO"
                      ELSE
                         TOR.Bord = "YES"
                      END IF
                   END IF
                   PRINT TOR.Bord
                CASE 12
                   ' Available screen modes
                   I = INSTR(Available$, HEX$(VC.Scrn))
                   I = Rotated(1, LEN(Available$), I, Inc)
                   VC.Scrn = VAL("&h" + MID$(Available$, I, 1))
                   PRINT USING "##"; VC.Scrn
                CASE ELSE
             END SELECT
          CASE ELSE
       END SELECT
    ' Set configuration data for graphics mode
    SetConfig VC.Scrn
    ' Draw Torus if ENTER
    LOOP UNTIL Ky = ENTER

    ' Remove cursor
    LOCATE 1, 1, 0

    ' Set different delays depending on mode
    SELECT CASE VC.Scrn
       CASE 1
          TOR.Delay = .3
       CASE 2, 3, 10, 11, 13
          TOR.Delay = 0
       CASE ELSE
          TOR.Delay = .05
    END SELECT

    ' Get new random seed for this torus
    RANDOMIZE TIMER

 END SUB

 ' =========================== TorusDraw ================================
 '   Draws each tile of the torus starting with the farthest and working
 '   to the closest. Thus nearer tiles overwrite farther tiles to give
 '   a three-dimensional effect. Notice that the index of the tile being
 '   drawn is actually the index of an array of indexes. This is because
 '   the array of tiles is not sorted, but the parallel array of indexes
 '   is. See TorusSort for an explanation of how indexes are sorted.
 ' ======================================================================
 '
 SUB TorusDraw (T() AS Tile, Index() AS INTEGER)
 SHARED Max AS INTEGER

    FOR Til = 0 TO Max - 1
       TileDraw T(Index(Til))
    NEXT

 END SUB

 ' =========================== TorusRotate ==============================
 '   Rotates the Torus. This can be done more successfully in some modes
 '   than in others. There are three methods:
 '
 '     1. Rotate the palette colors assigned to each attribute
 '     2. Draw, erase, and redraw the torus (two-color modes)
 '     3. Rotate between two palettes (CGA and MCGA screen 1)
 '
 '   Note that for EGA and VGA screen 2, methods 1 and 2 are both used.
 ' ======================================================================
 '
 SUB TorusRotate (First) STATIC
 SHARED VC AS Config, TOR AS TORUS, Pal() AS LONG, Max AS INTEGER
 SHARED T() AS Tile, Index() AS INTEGER, BestMode AS INTEGER
 DIM Temp AS LONG

    ' For EGA and higher rotate colors through palette
    IF VC.Colors THEN

       ' Argument determines whether to start at next color, first color,
       ' or random color
       SELECT CASE First
          CASE RNDM
             FirstClr = INT(RND * VC.Colors)
          CASE START
             FirstClr = 0
          CASE ELSE
             FirstClr = FirstClr - 1
       END SELECT

       ' Set last color to smaller of last possible color or last tile
       IF VC.Colors > Max - 1 THEN
          LastClr = Max - 1
       ELSE
          LastClr = VC.Colors - 1
       END IF

       ' If color is too low, rotate to end
       IF FirstClr < 0 OR FirstClr >= LastClr THEN FirstClr = LastClr

       ' Set last attribute
       IF VC.Atribs = 2 THEN
          ' Last for two-color modes
          LastAtr = VC.Atribs - 1
       ELSE
          ' Smaller of last color or next-to-last attribute
          IF LastClr < VC.Atribs - 2 THEN
             LastAtr = LastClr
          ELSE
             LastAtr = VC.Atribs - 2
          END IF
       END IF

       ' Cycle through attributes, assigning colors
       Work = FirstClr
       FOR Atr = LastAtr TO 1 STEP -1
          PALETTE Atr, Pal(Work)
          Work = Work - 1
          IF Work < 0 THEN Work = LastClr
       NEXT

    END IF

    ' For two-color screens, the best we can do is erase and redraw the torus
    IF VC.Atribs = 2 THEN

       ' Set all tiles to color
       FOR I = 0 TO Max - 1
          T(I).TColor = Toggle
       NEXT
       ' Draw Torus
       TorusDraw T(), Index()
       ' Toggle between color and background
       Toggle = (Toggle + 1) MOD 2

    END IF

    ' For CGA or MCGA screen 1, toggle palettes using the COLOR statement
    ' (these modes do not allow the PALETTE statement)
    IF VC.Scrn = 1 AND (BestMode = CGA OR BestMode = MCGA) THEN
       COLOR , Toggle
       Toggle = (Toggle + 1) MOD 2
       EXIT SUB
    END IF

 END SUB

 ' ============================ TorusSort ===============================
 '   Sorts the tiles of the Torus according to their Z axis (distance
 '   from the "front" of the screen). When the tiles are drawn, the
 '   farthest will be drawn first, and nearer tiles will overwrite them
 '   to give a three-dimensional effect.
 '
 '   To make sorting as fast as possible, the Quick Sort algorithm is
 '   used. Also, the array of tiles is not actually sorted. Instead a
 '   parallel array of tile indexes is sorted. This complicates things,
 '   but makes the sort much faster, since two-byte integers are swapped
 '   instead of 46-byte Tile variables.
 ' ======================================================================
 '
 SUB TorusSort (Low, High)
 SHARED T() AS Tile, Index() AS INTEGER
 DIM Partition AS SINGLE

    IF Low < High THEN
       ' If only one, compare and swap if necessary
       ' The SUB procedure only stops recursing when it reaches this point
       IF High - Low = 1 THEN
          IF T(Index(Low)).z1 > T(Index(High)).z1 THEN
             CountTiles High, Low
             SWAP Index(Low), Index(High)
          END IF
       ELSE
       ' If more than one, separate into two random groups
          RandIndex = INT(RND * (High - Low + 1)) + Low
          CountTiles High, Low
          SWAP Index(High), Index(RandIndex%)
          Partition = T(Index(High)).z1
          ' Sort one group
          DO
             I = Low: J = High
             ' Find the largest
             DO WHILE (I < J) AND (T(Index(I)).z1 <= Partition)
                I = I + 1
             LOOP
             ' Find the smallest
             DO WHILE (J > I) AND (T(Index(J)).z1 >= Partition)
                J = J - 1
             LOOP
             ' Swap them if necessary
             IF I < J THEN
                CountTiles High, Low
                SWAP Index(I), Index(J)
             END IF
          LOOP WHILE I < J

          ' Now get the other group and recursively sort it
          CountTiles High, Low
          SWAP Index(I), Index(High)
          IF (I - Low) < (High - I) THEN
             TorusSort Low, I - 1
             TorusSort I + 1, High
          ELSE
             TorusSort I + 1, High
             TorusSort Low, I - 1
          END IF
       END IF
    END IF

 END SUB



 UIASM.ASM
 CD-ROM Disc Path:   \SAMPCODE\BASIC\UIASM.ASM

 ;----------------------------------------------------------------------------
 ;----------------------------------------------------------------------------
 ;
 ;  UIASM.ASM
 ;
 ;  Copyright (C) 1989 Microsoft Corporation, All Rights Reserved
 ;
 ;  GetCopyBox : Gets screen box info and places into string variable
 ;  PutCopyBox : Puts screen box info from string variable onto screen
 ;  AttrBox    : Changes the color attributes of all characters within a box
 ;
 ;----------------------------------------------------------------------------
 ;----------------------------------------------------------------------------

 ;NOTE: For optimum speed, these routines write directly to screen memory
 ;      without waiting for re-trace.  If "snow" is a problem, these routines
 ;      will need modification.

 .model medium

         extrn   STRINGADDRESS:far       ;BASIC RTL entry point for string inf

 .data

 attr    db      ?                       ;destination attribute (AttrBox)
 x0      db      ?                       ;x coord of upper-left
 y0      db      ?                       ;y coord of upper-left
 x1      db      ?                       ;x coord of lower-right
 y1      db      ?                       ;y coord of lower-right
 bwidth  db      ?                       ;box width
 height  db      ?                       ;box height
 strdoff dw      ?                       ;string pointer offset
 strdseg dw      ?                       ;string pointer segment
 scrseg  dw      ?                       ;screen segment
 movword dw      ?                       ;word count to move/change

 .code

 ;---------------------------------------place segment of screen memory
 ;---------------------------------------in SCRSEG
 get_scrseg      proc

         push    ax                      ;save value of AX
         mov     ah,0Fh
         int     10h                     ;INT 10H fn. 0Fh - Get Video Mode
         mov     dgroup:scrseg,0B800h    ;assume COLOR screen for now
         cmp     al,07h                  ;is it MONOCHROME mode?
         jne     arnd1
         mov     dgroup:scrseg,0B000h    ;yes, set for mono screen seg
 arnd1:  pop     ax                      ;restore AX
         ret                             ;and exit

 get_scrseg      endp


 ;----------------------------------------Given X and Y in AH and AL, find
 ;----------------------------------------the offset into screen memory and
 ;----------------------------------------return in AX
 get_memxy       proc

         push    dx                      ;save DX
         push    ax                      ;save coords
         mov     dl,160
         mul     dl                      ;multiply Y by 160
         pop     dx                      ;put coords in DX
         mov     dl,dh
         mov     dh,0
         add     dl,dl                   ;double X
         add     ax,dx                   ;and add to mult. result for final!
         pop     dx                      ;restore DX
         ret

 get_memxy       endp


 ;----------------------------------------------------------------------------
 ;----------------------------------------This is the routine that copies
 ;----------------------------------------screen info to the string variable
 ;----------------------------------------------------------------------------
         public  getcopybox
 getcopybox      proc    far

         push    bp
         mov     bp,sp
         push    ds
         push    es
         push    si
         push    di                      ;preserve registers

 get_start:
         mov     bx,[bp + 14]            ;get y0
         mov     ax,[bx]
         mov     y0,al
         mov     bx,[bp + 12]            ;...x0
         mov     ax,[bx]
         mov     x0,al
         mov     bx,[bp + 10]            ;...y1
         mov     ax,[bx]
         mov     y1,al
         mov     bx,[bp + 8]             ;...x1
         mov     ax,[bx]
         mov     x1,al
         mov     bx,[bp + 6]             ;...and the destination str desc.

         push    bx
         call    STRINGADDRESS           ;for both near and far string support
         mov     strdoff, ax
         mov     strdseg, dx

         dec     x0                      ;subtract 1 from
         dec     y0                      ;all coordinates
         dec     x1                      ;to reflect BASIC's
         dec     y1                      ;screen base of 1 (not 0)

 get_chkscr:
         call    get_scrseg              ;set up screen segment

 get_setstr:
         mov     al,x1
         sub     al,x0                   ;find width of box
         mov     bwidth,al               ;and save
         add     al,1                    ;add one to width
         mov     ah,0                    ;to find # words to move
         mov     movword,ax              ;MovWord = (width+1)
         mov     al,y1
         sub     al,y0                   ;find height of box
         mov     height,al               ;and save
         mov     es,strdseg
         mov     di,strdoff              ;string is the destination
         mov     si,offset bwidth        ;point to width
         movsb                           ;put width in string
         mov     si,offset height
         movsb                           ;and the height, too

 get_movstr:
         mov     al,y0
         mov     ah,x0                   ;put coords in AH and AL
         call    get_memxy               ;and find offset into screen mem
         mov     si,ax                   ;this will be the source

 get_domove:
         mov     cx,movword
         push    ds
         mov     ds,scrseg
         rep     movsw                   ;move a row into the string
         pop     ds
         add     si,160
         sub     si,movword              ;Add 160-(movword*2) to si
         sub     si,movword              ;to point to next row
         cmp     height,0                ;was that the last row?
         je      get_done                ;yes, we're done
         dec     height                  ;decrement height
         jmp     get_domove              ;and do another row

 get_done:
         pop     di
         pop     si
         pop     es
         pop     ds                      ;restore registers
         pop     bp
         ret     10                      ;there were 5 parameters

 getcopybox      endp


 ;----------------------------------------------------------------------------
 ;----------------------------------------This is the routine that copies the
 ;----------------------------------------information stored in the string to
 ;----------------------------------------the screen in the specified location
 ;----------------------------------------------------------------------------
         public  putcopybox
 putcopybox      proc    far

         push    bp
         mov     bp,sp
         push    ds
         push    es
         push    si
         push    di                      ;preserve registers


 put_start:
         mov     bx,[bp + 10]            ;get y0
         mov     ax,[bx]
         mov     y0,al
         mov     bx,[bp + 8]             ;...x0
         mov     ax,[bx]
         mov     x0,al
         mov     bx,[bp + 6]             ;...and the destination string

         push    bx
         call    STRINGADDRESS           ;for both near and far string support
         mov     strdoff, ax
         mov     strdseg, dx

         dec     x0                      ;subtract 1 from
         dec     y0                      ;all coordinates

 put_chkscr:
         call    get_scrseg              ;set up scrseg

 put_setstr:
         push    ds
         pop     es                      ;equate ES to DS

         mov     si,strdoff              ;point DS:SI to string mem
         push    ds
         mov     ds,strdseg
         mov     di,offset bwidth
         movsb                           ;get width
         mov     di,offset height
         movsb                           ;and height out of string
         pop     ds

         mov     al,bwidth
         add     al,1
         mov     ah,0
         mov     movword,ax              ;set movword to (bwidth+1)

         mov     ah,x0
         mov     al,y0                   ;get coords
         call    get_memxy               ;and find offset into screen mem
         mov     di,ax
         mov     es,scrseg               ;ES:DI -> screen mem (UL corner)

 put_domove:
         mov     cx,movword
         push    ds
         mov     ds,strdseg
         rep     movsw                   ;move a row onto the screen
         pop     ds
         add     di,160
         sub     di,movword              ;add 160-(movword*2) to DI
         sub     di,movword              ;to point to next row on screen
         cmp     height,0                ;was that the last row?
         je      put_done                ;yes, we're finished
         dec     height
         jmp     put_domove              ;no, decrement and do again

 put_done:
         pop     di
         pop     si
         pop     es
         pop     ds                      ;restore registers
         pop     bp
         ret     6                       ;pop off 3 parameters

 putcopybox      endp

 ;----------------------------------------------------------------------------
 ;----------------------------------------This is the routine that changes
 ;----------------------------------------the colors of the box's characters
 ;----------------------------------------------------------------------------
         public  attrbox
 attrbox         proc    far

         push    bp
         mov     bp, sp
         push    ds
         push    es
         push    si
         push    di                      ;preserve registers

 atr_start:
         mov     bx, [bp+14]             ;get y0
         mov     ax, [bx]
         mov     y0, al
         mov     bx, [bp+12]             ;...x0
         mov     ax, [bx]
         mov     x0, al
         mov     bx, [bp+10]             ;...y1
         mov     ax, [bx]
         mov     y1, al
         mov     bx, [bp+8]              ;...x1
         mov     ax, [bx]
         mov     x1, al
         mov     bx, [bp+6]              ;...and finally the new color value
         mov     ax, [bx]
         mov     attr, al

         dec     y0                      ;subtract 1 from
         dec     x0                      ;all coordinates
         dec     y1                      ;to reflect BASIC's
         dec     x1                      ;screen base of 1 (not 0)

 atr_chkscr:
         call    get_scrseg              ;set up screen segment

 atr_setup:
         mov     al, x1
         sub     al, x0                  ;find width of box
         inc     al
         xor     ah, ah
         mov     movword, ax             ;(width + 1 = movword)
         mov     al, y1
         sub     al, y0                  ;find height of box
         mov     height, al              ;and save

 atr_chgclr:
         mov     al, y0
         mov     ah, x0                  ;put coords in AH and AL
         call    get_memxy               ;find offset into screen memory
         mov     di, ax                  ;(which is our destination)
         mov     es, scrseg
         mov     al, attr                ;get the color value to store

 atr_doit:
         mov     cx, movword
 atr_loop:
         inc     di                      ;skip the character value
         stosb                           ;write new color value
         loop    atr_loop                ;cx times
         add     di, 160                 ;add 160-(movword*2) to di
         sub     di, movword
         sub     di, movword
         cmp     height, 0               ;was that the last row?
         je      atr_done                ;yes, we be finished
         dec     height                  ;no, decrement height
         jmp     atr_doit

 atr_done:
         pop     di
         pop     si
         pop     es
         pop     ds
         pop     bp                      ;restore registers
         ret     10                      ;pull off 5 paramters and return

 attrbox         endp

         END


 UIDEMO.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\UIDEMO.BAS

 ' ===========================================================================
 '
 ' UIDEMO.BAS Copyright (c) 1989 Microsoft Corporation
 '
 ' ===========================================================================
 ' ===========================================================================
 ' Decls, includes, and dimensions
 ' ===========================================================================
 DEFINT A-Z
 DECLARE SUB AboutDemo ()
 DECLARE SUB AboutUIP ()
 DECLARE SUB AboutMouse ()
 DECLARE SUB AboutAccess ()
 DECLARE SUB AboutQuick ()
 DECLARE SUB AboutWindows ()
 DECLARE SUB ColorDisplay ()
 DECLARE SUB DemoAlert ()
 DECLARE SUB DemoDialog ()
 DECLARE SUB DemoDialogEZ ()
 DECLARE SUB DemoFileNameListBox ()
 DECLARE SUB DemoListBox ()
 DECLARE SUB DemoWindow ()
 DECLARE SUB DemoScrollBar ()
 DECLARE SUB DemoResize ()
 DECLARE SUB MonoDisplay ()
 DECLARE SUB SetupDesktop ()
 DECLARE SUB SetupMenu ()
 DECLARE FUNCTION GetFileCount% (FileSpec$)

 '$INCLUDE: 'general.bi'
 '$INCLUDE: 'mouse.bi'
 '$INCLUDE: 'menu.bi'
 '$INCLUDE: 'window.bi'

 COMMON SHARED /uitools/ GloMenu           AS MenuMiscType
 COMMON SHARED /uitools/ GloTitle()        AS MenuTitleType
 COMMON SHARED /uitools/ GloItem()         AS MenuItemType
 COMMON SHARED /uitools/ GloWindow()       AS windowType
 COMMON SHARED /uitools/ GloButton()       AS buttonType
 COMMON SHARED /uitools/ GloEdit()         AS EditFieldType
 COMMON SHARED /uitools/ GloStorage        AS WindowStorageType
 COMMON SHARED /uitools/ GloWindowStack()  AS INTEGER
 COMMON SHARED /uitools/ GloBuffer$()

 DIM GloTitle(MAXMENU)           AS MenuTitleType
 DIM GloItem(MAXMENU, MAXITEM)   AS MenuItemType
 DIM GloWindow(MAXWINDOW)        AS windowType
 DIM GloButton(MAXBUTTON)        AS buttonType
 DIM GloEdit(MAXEDITFIELD)       AS EditFieldType
 DIM GloWindowStack(MAXWINDOW)   AS INTEGER
 DIM GloBuffer$(MAXWINDOW + 1, 2)

 DIM SHARED DisplayType          AS INTEGER

     ' =======================================================================
     ' Initialize Demo
     ' =======================================================================

     MenuInit
     WindowInit
     MouseShow
     MonoDisplay

     ' =======================================================================
     ' Show Opening alert window
     ' =======================================================================


          a$ = "User Interface Toolbox Demo|"
     a$ = a$ + "for|"
     a$ = a$ + "Microsoft BASIC 7.0 Professional Development System|"
     a$ = a$ + "Copyright (c) 1989 Microsoft Corporation|"

     x = Alert(4, a$, 9, 10, 14, 70, "Color", "Monochrome", "")

     IF x = 1 THEN
         DisplayType = TRUE
         ColorDisplay
     END IF

     ' =======================================================================
     ' Main Loop : Stay in loop until DemoFinished set to TRUE
     ' =======================================================================

     DemoFinished = FALSE

     WHILE NOT DemoFinished
         kbd$ = MenuInkey$
         WHILE MenuCheck(2)
             GOSUB MenuTrap
         WEND
     WEND

     ' =======================================================================
     ' End Program
     ' =======================================================================

     MouseHide
     COLOR 15, 0
     CLS
     END



 ' ===========================================================================
 ' If a menu event occured, call the proper demo, or if Exit, set demoFinished
 ' ===========================================================================

 MenuTrap:
     menu = MenuCheck(0)
     item = MenuCheck(1)

     SELECT CASE menu
         CASE 1
             SELECT CASE item
                 CASE 1:  DemoAlert
                 CASE 2:  DemoDialogEZ
                 CASE 3:  DemoDialog
                 CASE 4:  DemoListBox
                 CASE 5:  DemoFileNameListBox
                 CASE 6:  DemoScrollBar
                 CASE 7:  DemoWindow
                 CASE 8:  DemoResize
                 CASE 10: DemoFinished = TRUE
             END SELECT
         CASE 2
             SELECT CASE item
                 CASE 1: ColorDisplay
                 CASE 2: MonoDisplay

             END SELECT
         CASE 3
             SELECT CASE item
                 CASE 1: AboutDemo
                 CASE 2: AboutUIP
                 CASE 3: AboutWindows
                 CASE 4: AboutMouse
                 CASE 5: AboutAccess
                 CASE 6: AboutQuick
             END SELECT
         CASE ELSE
     END SELECT
 RETURN

 SUB AboutAccess
          a$ = "                      Access Keys||"
     a$ = a$ + "Access keys are the keys on the menu bar that are highlighted|
     a$ = a$ + "when you press the Alt key. If you press a letter that is|"
     a$ = a$ + "highlighted in a menu title, that menu will be selected.||"
     a$ = a$ + "Once a pull-down menu is displayed, each menu item also has a|
     a$ = a$ + "highlighted letter associated with each choice. Press the|"
     a$ = a$ + "letter that corresponds to the menu item you want to select.||
     a$ = a$ + "If, after you press Alt, you change your mind, press the Alt|"
     a$ = a$ + "key again to cancel."

     junk = Alert(1, a$, 7, 9, 20, 69, "", "", "")

 END SUB

 SUB AboutDemo
          a$ = "                      About This Demo||"
     a$ = a$ + "Running this program provides a visual demonstration of most|"
     a$ = a$ + "of the features implemented in the new User Interface Toolbox|
     a$ = a$ + "for the BASIC Compiler 7.0.||"
     a$ = a$ + "In addition to serving as a demo of toolbox features, the|"
     a$ = a$ + "source code that makes up this program can also serve as a|"
     a$ = a$ + "programming example of how to implement these features in|"
     a$ = a$ + "your programs. While the demo is relatively simple, it does|"
     a$ = a$ + "illustrate almost all the features available."

     junk = Alert(1, a$, 7, 9, 19, 69, "", "", "")
 END SUB

 SUB AboutMouse
          a$ = "                      Using the Mouse||"
     a$ = a$ + "Virtually all operations in the User Interface Toolbox can|"
     a$ = a$ + "be accomplished using the mouse. Move the mouse cursor to|"
     a$ = a$ + "whatever you want to select and press the left button.||"
     a$ = a$ + "In addition to being able to make a choice with a mouse,|"
     a$ = a$ + "you can also perform a number of operations on windows.|"
     a$ = a$ + "Using the mouse you can close, move, or resize windows|"
     a$ = a$ + "depending on the particular features of the window that is|"
     a$ = a$ + "active."

     junk = Alert(1, a$, 7, 9, 19, 69, "", "", "")

 END SUB

 SUB AboutQuick
          a$ = "                      Quick Keys||"
     a$ = a$ + "Quick keys are optional keys that you can define in addition|"
     a$ = a$ + "to the normal access keys that must be specified when you|"
     a$ = a$ + "set up the individual menu items.||"
     a$ = a$ + "Quick keys normally reduce selection of a menu item to one|"
     a$ = a$ + "keystroke. For example, this demo uses function keys F1 thru|"
     a$ = a$ + "F8 to select menu choices that demonstrate different features|
     a$ = a$ + "of the User Interface Toolbox.  Additionally, Ctrl-X is the|"
     a$ = a$ + "Quick key that exits this demonstration program."

     junk = Alert(1, a$, 7, 9, 19, 69, "", "", "")

 END SUB

 SUB AboutUIP
          a$ = "                 About the User Interface||"
     a$ = a$ + "The user interface provided with this toolbox is designed to|"
     a$ = a$ + "provide much the same functionality as that found in the QBX|"
     a$ = a$ + "programming environment. The menus, check boxes, option|"
     a$ = a$ + "buttons, and other interface features operate similarly to|"
     a$ = a$ + "their QBX counterparts. ||"
     a$ = a$ + "If you know how to navigate QBX, you know how to navigate|"
     a$ = a$ + "the interface provided by the User Interface Toolbox."

     junk = Alert(1, a$, 7, 9, 18, 69, "", "", "")
 END SUB

 SUB AboutWindows
          a$ = "                     About the Windows||"
     a$ = a$ + "Several border characters used by the windows in the User|"
     a$ = a$ + "Interface Toolbox have special significance.  Any window that|
     a$ = a$ + "has a '=' in the upper-left corner can be closed by selecting|
     a$ = a$ + "that character with the mouse. Windows with the '░' character|
     a$ = a$ + "across the window's top row can be moved around the screen by|
     a$ = a$ + "selecting that area with the mouse.  The '+' character in the|
     a$ = a$ + "lower-right corner means that the window can be resized by|"
     a$ = a$ + "selecting the '+' character with the mouse.||"
     a$ = a$ + "Note that none of these features can be accessed without a|"
     a$ = a$ + "mouse. "

     junk = Alert(1, a$, 7, 9, 21, 69, "", "", "")

 END SUB

 SUB ColorDisplay
     DisplayType = TRUE
     MouseHide
     SetupMenu
     MenuSetState 2, 1, 2
     MenuSetState 2, 2, 1
     SetupDesktop
     MenuShow
     MouseShow
 END SUB

 SUB DemoAlert

     ' =======================================================================
     ' Simple little demo of how easy alerts are to use.
     ' =======================================================================

          a$ = "|"
     a$ = a$ + "This is an Alert Box.| |"
     a$ = a$ + "It was created using a simple one|"
     a$ = a$ + "line command.  Notice the buttons|"
     a$ = a$ + "below.  They are user definable|"
     a$ = a$ + "yet their spacing is automatic."

     B$ = "You Selected OK"

     C$ = "You Selected Cancel"

     SELECT CASE Alert(4, a$, 6, 20, 15, 60, "OK", "Cancel", "")
         CASE 1
             x = Alert(4, B$, 10, 25, 12, 55, "OK", "", "")
         CASE 2
             x = Alert(4, C$, 10, 25, 12, 55, "OK", "", "")
     END SELECT

 END SUB

 SUB DemoDialog

     ' =======================================================================
     ' This is about as complex as they get.  As you can see it is still very
     ' simple - just a lot bigger.  This sub exactly duplicates the
     ' functionality of the QuickBASIC Search-Change dialog box.
     ' =======================================================================

     ' =======================================================================
     ' Open Window, place a horizontal line on row 13
     ' =======================================================================

     WindowOpen 1, 6, 11, 19, 67, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 1

     WindowLine 13

     ' =======================================================================
     ' Print the text, and boxes for the edit fields
     ' =======================================================================

     WindowLocate 2, 2
     WindowPrint 2, "Find What:"
     WindowBox 1, 14, 3, 56

     WindowLocate 5, 2
     WindowPrint 2, "Change To:"
     WindowBox 4, 14, 6, 56


     ' =======================================================================
     ' Print the title of the window -- This overides the string in WindowOpen
     ' =======================================================================

     WindowLocate 0, 26
     WindowPrint 1, " Change "

     WindowBox 8, 32, 12, 56

     ' =======================================================================
     ' Open Edit fields
     ' =======================================================================

     search$ = ""
     replace$ = ""
     EditFieldOpen 1, search$, 2, 15, 0, 0, 40, 39

     EditFieldOpen 2, replace$, 5, 15, 0, 0, 40, 39

     ' =======================================================================
     ' Open all buttons
     ' =======================================================================

     ButtonOpen 1, 1, "Match Upper/Lowercase", 9, 2, 0, 0, 2
     ButtonOpen 2, 1, "Whole Word", 10, 2, 0, 0, 2
     ButtonOpen 3, 1, "1. Active Window", 9, 34, 0, 0, 3
     ButtonOpen 4, 2, "2. Current Module", 10, 34, 0, 0, 3
     ButtonOpen 5, 1, "3. All Modules", 11, 34, 0, 0, 3
     ButtonOpen 6, 2, "Find and Verify", 14, 2, 0, 0, 1
     ButtonOpen 7, 1, "Change All", 14, 22, 0, 0, 1
     ButtonOpen 8, 1, "Cancel", 14, 38, 0, 0, 1
     ButtonOpen 9, 1, "Help", 14, 49, 0, 0, 1

     ' =======================================================================
     ' Set initial states to match initial button settings
     ' =======================================================================

     MatchState = FALSE
     WordState = FALSE
     searchState = 2
     pushButton = 1
     currButton = 0
     currEditField = 1

     ' =======================================================================
     ' Do until exitFlag is set
     ' =======================================================================

     ExitFlag = FALSE
     WHILE NOT ExitFlag
         WindowDo currButton, currEditField
         SELECT CASE Dialog(0)
             CASE 0, 3, 4, 5, 20

             ' ==============================================================
             ' If edit field clicked, assign currEditField to Dialog(2)
             ' ==============================================================

             CASE 2
                 currButton = 0
                 currEditField = Dialog(2)

             ' ==============================================================
             ' If escape is hit,  set pushbutton = 0 and exit flag
             ' ==============================================================

             CASE 9  '(Escape)
                 pushButton = 3
                 ExitFlag = TRUE

             ' ==============================================================
             ' If return is hit, perform action based on the current button
             ' Button 9 is the help button.  In that case, show help, else jus
             ' exit
             ' ==============================================================

             CASE 6
                 SELECT CASE currButton
                     CASE 9
                         a$ = "Sample Help Window"
                         ButtonSetState pushButton + 5, 1
                         pushButton = 4
                         ButtonSetState pushButton + 5, 2
                         junk = Alert(4, a$, 7, 9, 19, 69, "", "", "")
                     CASE ELSE
                         ExitFlag = TRUE
                 END SELECT


             ' ==============================================================
             ' A Button was pushed with mouse. Perform the desired action
             ' based on Button
             ' ==============================================================

             CASE 1
                 currButton = Dialog(1)
                 currEditField = 0
                 SELECT CASE currButton
                     CASE 1
                         MatchState = NOT MatchState
                         ButtonToggle 1
                     CASE 2
                         WordState = NOT WordState
                         ButtonToggle 2
                     CASE 3, 4, 5
                         ButtonSetState searchState + 2, 1
                         searchState = Dialog(1) - 2
                         ButtonSetState searchState + 2, 2
                     CASE 6, 7, 8
                         pushButton = Dialog(1) - 5
                         ExitFlag = TRUE
                     CASE 9
                         a$ = "Sample Help Window"
                         ButtonSetState pushButton + 5, 1
                         pushButton = Dialog(1) - 5
                         ButtonSetState pushButton + 5, 2
                         junk = Alert(4, a$, 7, 9, 19, 69, "", "", "")
                     CASE ELSE
                 END SELECT


             ' ==============================================================
             ' Tab was hit.  Depending upon the current button, or current edi
             ' assign the new values to currButton, and currEditField
             ' ==============================================================

             CASE 7  'tab
                 SELECT CASE currButton
                     CASE 0
                         SELECT CASE currEditField
                             CASE 1
                                 currEditField = 2

                             CASE ELSE
                                 currButton = 1
                                 currEditField = 0
                         END SELECT
                     CASE 1
                         currButton = 2
                     CASE 6, 7, 8
                         currButton = currButton + 1
                         ButtonSetState pushButton + 5, 1
                         pushButton = currButton - 5
                         ButtonSetState pushButton + 5, 2
                     CASE 3, 4, 5
                         currButton = 6
                     CASE 2
                         currButton = 2 + searchState
                     CASE 9
                         currButton = 0
                         ButtonSetState pushButton + 5, 1
                         pushButton = 1
                         ButtonSetState pushButton + 5, 2
                         currEditField = 1
                 END SELECT


             ' ==============================================================
             ' Same for Back Tab, only reverse.
             ' ==============================================================

             CASE 8 'back tab
                 SELECT CASE currButton
                     CASE 0
                         SELECT CASE currEditField
                             CASE 1
                                 currButton = 9
                                 ButtonSetState pushButton + 5, 1
                                 pushButton = currButton - 5
                                 ButtonSetState pushButton + 5, 2
                                 currEditField = 0
                             CASE 2
                                 currEditField = 1
                         END SELECT
                     CASE 1
                         currButton = 0
                         currEditField = 2
                     CASE 7, 8, 9
                         currButton = currButton - 1
                         ButtonSetState pushButton + 5, 1
                         pushButton = currButton - 5
                         ButtonSetState pushButton + 5, 2
                     CASE 3, 4, 5
                         currButton = 2
                     CASE 6
                         currButton = 2 + searchState
                     CASE 2
                         currButton = 1
                 END SELECT


             ' ==============================================================
             ' Up arrow only affects buttons 1,2,3,4,5  (the radial and check
             ' buttons)
             ' ==============================================================

             CASE 10 'up arrow
                 SELECT CASE currButton
                     CASE 1
                         IF NOT MatchState THEN
                             MatchState = TRUE
                             ButtonToggle 1
                         END IF
                     CASE 2
                         IF NOT WordState THEN
                             WordState = TRUE
                             ButtonToggle 2
                         END IF
                     CASE 3
                         ButtonSetState searchState + 2, 1
                         searchState = 3
                         currButton = 5
                         ButtonSetState searchState + 2, 2
                     CASE 4, 5
                         ButtonSetState searchState + 2, 1
                         searchState = searchState - 1
                         currButton = currButton - 1
                         ButtonSetState searchState + 2, 2
                 END SELECT


             ' ==============================================================
             ' Same with down arrow, only reverse
             ' ==============================================================

             CASE 11 'down
                 SELECT CASE currButton
                     CASE 1
                         IF MatchState THEN
                             MatchState = NOT MatchState
                             ButtonToggle 1
                         END IF
                     CASE 2
                         IF WordState THEN
                             WordState = NOT WordState
                             ButtonToggle 2
                         END IF
                     CASE 3, 4
                         ButtonSetState searchState + 2, 1
                         searchState = searchState + 1
                         currButton = currButton + 1
                         ButtonSetState searchState + 2, 2
                     CASE 5
                         ButtonSetState searchState + 2, 1
                         searchState = 1
                         currButton = 3
                         ButtonSetState searchState + 2, 2
                 END SELECT

             ' ==============================================================
             ' Left arrow only affects button 1 and 2  (the check buttons)
             ' ==============================================================

             CASE 12 'Left Arrow
                SELECT CASE currButton
                     CASE 1
                         IF NOT MatchState THEN
                             MatchState = TRUE
                             ButtonToggle 1
                         END IF
                     CASE 2
                         IF NOT WordState THEN
                             WordState = TRUE
                             ButtonToggle 2
                         END IF
                     CASE 3
                         ButtonSetState searchState + 2, 1
                         searchState = 3
                         currButton = 5
                         ButtonSetState searchState + 2, 2

                     CASE 4, 5
                         ButtonSetState searchState + 2, 1
                         searchState = searchState - 1
                         currButton = currButton - 1
                         ButtonSetState searchState + 2, 2

                END SELECT


             ' ==============================================================
             ' Right arrow only affects button 1 and 2  (the check buttons)
             ' ==============================================================

             CASE 13 'Right Arrow
                 SELECT CASE currButton
                     CASE 1
                         IF MatchState THEN
                             MatchState = NOT MatchState
                             ButtonToggle 1
                         END IF
                     CASE 2
                         IF WordState THEN
                             WordState = NOT WordState
                             ButtonToggle 2
                         END IF
                     CASE 3, 4
                         ButtonSetState searchState + 2, 1
                         searchState = searchState + 1
                         currButton = currButton + 1
                         ButtonSetState searchState + 2, 2
                     CASE 5
                         ButtonSetState searchState + 2, 1
                         searchState = 1
                         currButton = 3
                         ButtonSetState searchState + 2, 2

                 END SELECT

             ' ==============================================================
             ' Space will toggle a check button, or select a push button (incl
             ' ==============================================================

             CASE 14 'space
                 SELECT CASE currButton
                     CASE 1
                         MatchState = NOT MatchState
                         ButtonToggle 1
                     CASE 2
                         WordState = NOT WordState
                         ButtonToggle 2
                     CASE 6, 7, 8
                         pushButton = currButton - 5
                         ExitFlag = TRUE
                     CASE 9
                         a$ = "Sample Help Window"
                         ButtonSetState pushButton + 5, 1
                         pushButton = 4
                         ButtonSetState pushButton + 5, 2
                         junk = Alert(4, a$, 7, 9, 19, 69, "", "", "")
                     CASE ELSE
                 END SELECT
             CASE ELSE
         END SELECT
     WEND


     ' =======================================================================
     ' Prepare data for final alert box that says what the final state was.
     ' =======================================================================

     search$ = EditFieldInquire(1)
     replace$ = EditFieldInquire(2)


     WindowClose 1
     IF pushButton = 3 THEN
         a$ = "You Selected CANCEL"
         x = Alert(4, a$, 10, 25, 12, 55, "OK", "", "")
     ELSE
         IF pushButton = 1 THEN
             a$ = "You selected VERIFY.  Here are your other selections:| |"
         ELSE
             a$ = "You selected CHANGE ALL.  Here are your other selections:|
         END IF

         IF MatchState THEN
             a$ = a$ + "   Match Upper/Lowercase = Yes|"
         ELSE
             a$ = a$ + "   Match Upper/Lowercase = No|"
         END IF

         IF WordState THEN
             a$ = a$ + "   Whole Word            = Yes|"
         ELSE
             a$ = a$ + "   Whole Word            = No|"
         END IF

         SELECT CASE searchState
             CASE 1: a$ = a$ + "   Search space          = Active Window|"
             CASE 2: a$ = a$ + "   Search space          = Current Module|"
             CASE 3: a$ = a$ + "   Search space          = All Modules|"
         END SELECT

         a$ = a$ + "   Search string : " + search$ + "|"
         a$ = a$ + "   Replace string: " + replace$ + "|"

         x = Alert(2, a$, 7, 11, 15, 69, "OK", "", "")
     END IF
 END SUB

 SUB DemoDialogEZ


     ' =======================================================================
     ' Open Window, write text, and open button and edit field
     ' =======================================================================

     WindowOpen 1, 8, 20, 13, 60, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 1

     WindowLocate 2, 2
     WindowPrint 2, "Your Name:"
     WindowBox 1, 14, 3, 38

     EditFieldOpen 1, "", 2, 15, 0, 0, 23, 22
     WindowLine 5
     ButtonOpen 1, 2, "OK", 6, 17, 0, 0, 1


     ' =======================================================================
     ' Set initial state + go into main loop
     ' =======================================================================

     currButton = 0
     currEditField = 1

     ExitFlag = FALSE

     WHILE NOT ExitFlag
         WindowDo currButton, currEditField
         SELECT CASE Dialog(0)
             CASE 1, 6                       'Button, or Enter, exit loop
                 ExitFlag = TRUE
             CASE 2                          'EditField, switch to edit field
                 currButton = 0
                 currEditField = 1
             CASE 7, 8                       'tab and backTab, flip/flop state
                 IF currButton = 1 THEN
                     currButton = 0
                     currEditField = 1
                 ELSE
                     currButton = 1
                     currEditField = 0
                 END IF
             CASE 14                         'space - if on button then exit
                 IF currButton = 1 THEN
                     ExitFlag = TRUE
                 END IF
             CASE 9                          'escape
                 WindowClose 1
                 EXIT SUB
             CASE ELSE
         END SELECT
     WEND

     ' =======================================================================
     ' Assign the variable before closing the window, and close the window
     ' =======================================================================

     yourName$ = EditFieldInquire$(1)

     WindowClose 1

     IF LEN(yourName$) <> 0 THEN
         junk = Alert(4, "Hello " + yourName$ + ".", 10, 20, 12, 60, "OK", "",
     ELSE
         junk = Alert(4, "I understand. You wish to remain anonymous!", 10, 15
     END IF

 END SUB

 SUB DemoFileNameListBox

     WindowOpen 1, 8, 20, 15, 60, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 1

     WindowLocate 2, 4
     WindowPrint 4, "Enter a file specification:"
     WindowBox 3, 4, 5, 38

     EditFieldOpen 1, "*.*", 4, 5, 0, 0, 23, 22
     WindowLine 7
     ButtonOpen 1, 2, "OK", 8, 17, 0, 0, 1

     ' =======================================================================
     ' Set initial state + go into main loop
     ' =======================================================================

     currButton = 0
     currEditField = 1

     ExitFlag = FALSE
     WHILE NOT ExitFlag
         WindowDo currButton, currEditField
         SELECT CASE Dialog(0)
             CASE 1, 6                       'Button, or Enter, exit loop
                 ExitFlag = TRUE
             CASE 2                          'EditField, switch to edit field
                 currButton = 0
                 currEditField = 1
             CASE 7, 8                       'tab and backTab, flip/flop state
                 IF currButton = 1 THEN
                     currButton = 0
                     currEditField = 1
                 ELSE
                     currButton = 1
                     currEditField = 0
                 END IF
             CASE 9                          'escape
                 WindowClose 1
                 EXIT SUB
             CASE 14                         'space - if on button then exit
                 IF currButton = 1 THEN
                     ExitFlag = TRUE
                 END IF
             CASE ELSE
         END SELECT
     WEND

     ' =======================================================================
     ' Assign the variable before closing the window, and close the window
     ' =======================================================================

     FileSpec$ = EditFieldInquire$(1)

     ' =======================================================================
     ' Make sure its a valid file name
     ' =======================================================================

     delimit = INSTR(FileSpec$, ".")

     IF delimit THEN
         fileName$ = LEFT$(FileSpec$, delimit - 1)
         fileExt$ = RIGHT$(FileSpec$, LEN(FileSpec$) - (delimit))
     ELSE
         fileName$ = FileSpec$
         fileExt$ = ""
     END IF

     IF LEN(FileSpec$) = 0 OR LEN(fileName$) > 8 OR LEN(fileExt$) > 3 THEN
         WindowClose 1
         junk = Alert(4, "You didn't enter a valid file specification.", 10, 1
         EXIT SUB
     END IF

     FileCount = GetFileCount(FileSpec$)

     IF FileCount THEN

         REDIM FileList$(FileCount)

     ELSE

         WindowClose 1
         junk = Alert(4, "No match to your file specification could be found."
         EXIT SUB
     END IF

     FileList$(1) = DIR$(FileSpec$)

     FOR Indx = 2 TO FileCount
         FileList$(Indx) = DIR$
     NEXT Indx

     x = ListBox(FileList$(), UBOUND(FileList$))

     SELECT CASE x
         CASE 0
             junk = Alert(4, "You selected CANCEL", 10, 25, 12, 55, "OK", "",
         CASE ELSE
             junk = Alert(4, "You selected " + FileList$(x), 10, 25, 12, 55, "
     END SELECT

     WindowClose 1
 END SUB

 SUB DemoListBox

     REDIM x$(30), y$(30)

     x$(1) = "Orange":                 y$(1) = "Orange you glad I didn't say B
     x$(2) = "Butter":                 y$(2) = "Try margarine! less cholestero
     x$(3) = "Corn":                   y$(3) = "Some people call it maize."
     x$(4) = "Potato":                 y$(4) = "Wouldn't you prefer stuffing?"
     x$(5) = "Grape":                  y$(5) = "Grape balls of fire!"
     x$(6) = "Cherry":                 y$(6) = "Don't chop down the tree!"
     x$(7) = "Lettuce":                y$(7) = "Two heads are better than one.
     x$(8) = "Lima bean":              y$(8) = "Who's Lima? and why do I have
     x$(9) = "Carrot":                 y$(9) = "What's up Doc?"
     x$(10) = "Rice":                  y$(10) = "Yes, but can you use chopstic
     x$(11) = "Steak":                 y$(11) = "Ooo.. Big spender."
     x$(12) = "Meatloaf":              y$(12) = "It must be Thursday."
     x$(13) = "Stuffing":              y$(13) = "Wouldn't you prefer potatoes?
     x$(14) = "Wine":                  y$(14) = "Remember: 'Party Responsibly.
     x$(15) = "Pea":                   y$(15) = "Comes with the princess."
     x$(16) = "Gravy":                 y$(16) = "like home made! (Only no lump
     x$(17) = "Pancake":               y$(17) = "Three for a dollar!"
     x$(18) = "Waffle":                y$(18) = "Syrup on your waffle sir?"
     x$(19) = "Broccoli":              y$(19) = "Little trees..."
     x$(20) = "Oatmeal":               y$(20) = "Yuck.."

     x = ListBox(x$(), 20)

     SELECT CASE x
         CASE 0
             y = Alert(4, "You Selected Cancel", 10, 25, 12, 55, "OK", "", "")
         CASE ELSE
             y = Alert(4, y$(x), 10, 38 - LEN(y$(x)) \ 2, 12, 43 + LEN(y$(x))
     END SELECT

 END SUB

 SUB DemoResize

     ' =======================================================================
     ' Define Window's text string
     ' =======================================================================

     REDIM x$(19)
     x$(1) = "Resize Me!  Hello there!  Welcome to the wonderful world"
     x$(2) = "of Windows.  This demo shows how BASIC programmers can"
     x$(3) = "use a re-sizable window in their own applications."
     x$(4) = ""
     x$(5) = "This demo consists of a single window (this window) which"
     x$(6) = "can be moved, closed, or re-sized.  When the user resizes"
     x$(7) = "a window, an event code of 5 is returned.  Upon receiving"
     x$(8) = "the event code, the programmer can then do whatever is"
     x$(9) = "needed to refresh the window. "
     x$(10) = ""
     x$(11) = "The text in this window simply truncates when the window"
     x$(12) = "is made smaller, but text can be made to wrap either by"
     x$(13) = "character, or at the spaces between words. The choice is"
     x$(14) = "the programmer's."
     x$(15) = ""
     x$(16) = "The programmer has many tools available to make the"
     x$(17) = "job very easy such as functions that return the window"
     x$(18) = "size, and simple one-line calls to perform actions like"
     x$(19) = "opening or closing a window. "


     ' =======================================================================
     ' Open up a resizeable window
     ' =======================================================================

     WindowOpen 1, 4, 5, 4, 16, 0, 7, 0, 7, 8, TRUE, TRUE, TRUE, FALSE, 1, "-W

     GOSUB DemoResizeDrawText

     ExitFlag = FALSE

     ' =======================================================================
     ' Process window events...
     '  IMPORTANT:  Window moving, and re-sizing is handled automatically
     '  The window type dictates when this is allowed to happen.
     ' =======================================================================

     WHILE NOT ExitFlag
         WindowDo 0, 0
         SELECT CASE Dialog(0)
             CASE 4, 9
                 WindowClose WindowCurrent         'Close current window
                 ExitFlag = TRUE
             CASE 5
                 GOSUB DemoResizeDrawText
             CASE 20
                 ExitFlag = TRUE                   'Exit if menu action
             CASE ELSE
         END SELECT
     WEND

     WindowClose 0

 EXIT SUB

 DemoResizeDrawText:
     WindowCls

     FOR a = 1 TO 19
         IF a <= WindowRows(1) THEN
             WindowLocate a, 1
             WindowPrint -1, x$(a)
        END IF
     NEXT a
 RETURN

 END SUB

 SUB DemoScrollBar

     ' =======================================================================
     ' Open up a closeable window
     ' =======================================================================

     IF NOT DisplayType THEN
         WindowOpen 1, 4, 10, 20, 70, 0, 7, 0, 7, 15, FALSE, TRUE, FALSE, FALS
     ELSE
         WindowOpen 1, 4, 10, 20, 70, 15, 5, 15, 5, 14, FALSE, TRUE, FALSE, FA
     END IF

     ButtonOpen 1, 3, "", 4, 4, 14, 4, 6
     ButtonOpen 2, 4, "", 4, 6, 14, 6, 6
     ButtonOpen 3, 5, "", 4, 8, 14, 8, 6
     ButtonOpen 4, 4, "", 4, 10, 14, 10, 6
     ButtonOpen 5, 4, "", 4, 12, 14, 12, 6
     ButtonOpen 6, 9, "", 4, 16, 4, 50, 7
     ButtonOpen 7, 9, "", 6, 16, 6, 50, 7
     ButtonOpen 8, 8, "", 8, 16, 8, 50, 7
     ButtonOpen 9, 10, "", 10, 16, 10, 50, 7
     ButtonOpen 10, 12, "", 12, 16, 12, 50, 7
     ButtonOpen 11, 11, "", 14, 16, 14, 50, 7

     ExitFlag = FALSE

     ' =======================================================================
     ' Process window events...
     '   IMPORTANT:  Window moving, and re-sizing is handled automatically
     '   The window type dictates when this is allowed to happen.
     ' =======================================================================

     WHILE NOT ExitFlag
         WindowDo 0, 0
         x = Dialog(0)

         SELECT CASE x
             CASE 1
                 button = Dialog(1)

                 scrollCode = Dialog(19)
                 currState = ButtonInquire(button)

                 SELECT CASE scrollCode
                     CASE -1
                         IF currState > 1 THEN
                             newState = currState - 1
                         END IF
                     CASE -2
                         IF currState < MaxScrollLength(button) THEN
                             newState = currState + 1
                         END IF
                     CASE ELSE
                         newState = scrollCode
                 END SELECT

                 ButtonSetState button, newState

             CASE 4, 9
                 WindowClose WindowCurrent         'Close current window
                 ExitFlag = TRUE
             CASE 20
                 ExitFlag = TRUE                   'Exit if menu action
             CASE ELSE
         END SELECT
     WEND

     WindowClose 0

 END SUB

 SUB DemoWindow

     REDIM z$(4 TO 6, 6)

     ' =======================================================================
     ' Open up 6 windows, showcase the features, and make each a different col
     ' =======================================================================
     IF NOT DisplayType THEN
         WindowOpen 1, 6, 5, 12, 25, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, FALS
     ELSE
         WindowOpen 1, 6, 5, 12, 25, 0, 4, 0, 4, 15, FALSE, FALSE, FALSE, FALS
     END IF
     WindowPrint 1, "Features:"
     WindowPrint 1, "No Title bar"
     WindowPrint 1, "No border"

     IF NOT DisplayType THEN
         WindowOpen 2, 8, 15, 14, 35, 0, 7, 0, 7, 15, TRUE, FALSE, FALSE, FALS
     ELSE
         WindowOpen 2, 8, 15, 14, 35, 0, 2, 0, 2, 15, TRUE, FALSE, FALSE, FALS
     END IF
     WindowPrint 1, "Features:"
     WindowPrint 1, "Title bar"
     WindowPrint 1, "Moveable window"
     WindowPrint 1, "Single-line border"

     IF NOT DisplayType THEN
         WindowOpen 3, 10, 25, 16, 45, 0, 7, 0, 7, 15, FALSE, TRUE, FALSE, FAL
     ELSE
         WindowOpen 3, 10, 25, 16, 45, 0, 3, 0, 3, 15, FALSE, TRUE, FALSE, FAL
     END IF
     WindowPrint 1, "Features:"
     WindowPrint 1, "Title bar"
     WindowPrint 1, "Closeable window"
     WindowPrint 1, "Single-line border"

     WindowOpen 4, 12, 35, 18, 55, 0, 7, 0, 7, 15, FALSE, FALSE, TRUE, FALSE,
     z$(4, 1) = "Features:"
     z$(4, 2) = "Title bar"
     z$(4, 3) = "Resizeable window"
     z$(4, 4) = "Single-line border"
     ValidLines = 4
     GOSUB DemoReDrawText

     IF NOT DisplayType THEN
         WindowOpen 5, 14, 45, 20, 65, 0, 7, 0, 7, 15, TRUE, TRUE, TRUE, FALSE
     ELSE
         WindowOpen 5, 14, 45, 20, 65, 0, 5, 0, 5, 15, TRUE, TRUE, TRUE, FALSE
     END IF
     z$(5, 1) = "Features:"
     z$(5, 2) = "Title bar"
     z$(5, 3) = "Moveable window"
     z$(5, 4) = "Closeable window"
     z$(5, 5) = "Resizeable window"
     z$(5, 6) = "Single-line border"
     ValidLines = 6
     GOSUB DemoReDrawText

     IF NOT DisplayType THEN
         WindowOpen 6, 16, 55, 22, 75, 0, 7, 0, 7, 15, TRUE, TRUE, TRUE, FALSE
     ELSE
         WindowOpen 6, 16, 55, 22, 75, 0, 6, 0, 6, 15, TRUE, TRUE, TRUE, FALSE
     END IF
     z$(6, 1) = "Features:"
     z$(6, 2) = "Title bar"
     z$(6, 3) = "Moveable window"
     z$(6, 4) = "Closeable window"
     z$(6, 5) = "Resizeable window"
     z$(6, 6) = "Double-line border"
     ValidLines = 6
     GOSUB DemoReDrawText

     ' =======================================================================
     ' Show alert box describing what is going on
     ' =======================================================================

          a$ = "WINDOWS:  This demo displays six windows, each representing on
     a$ = a$ + "or more of the features that are available.  You may use the "
     a$ = a$ + "mouse to select windows, move windows, resize windows, or clos
     a$ = a$ + "windows. You can also select border characters and define your
     a$ = a$ + "window title.| |You should know that this demo "
     a$ = a$ + "consists of only six window open commands, and a 12 line "
     a$ = a$ + "Select Case statement to handle the actual processing."

     choice = Alert(3, a$, 7, 15, 18, 65, "OK", "Cancel", "")

     IF choice = 1 THEN
         ExitFlag = FALSE
     ELSE
         ExitFlag = TRUE
     END IF

     ' =======================================================================
     ' Process window events...
     '  IMPORTANT:  Window moving, and re-sizing is handled automatically
     '  The windowtype dictates when this is allowed to happen.
     ' =======================================================================

     WHILE NOT ExitFlag
         WindowDo 0, 0
         SELECT CASE Dialog(0)
             CASE 3
                 WindowSetCurrent Dialog(3)        'Change current window
             CASE 4
                 WindowClose WindowCurrent         'Close current window
             CASE 5
                 GOSUB DemoReDrawText              'Redraw text when resizing
             CASE 9
                 ExitFlag = TRUE                   'Exit if escape key pressed
             CASE 20
                 ExitFlag = TRUE                   'Exit if menu action
             CASE ELSE
         END SELECT
     WEND

     WindowClose 0

 EXIT SUB

 DemoReDrawText:
     WindowCls

     FOR a = 1 TO ValidLines
         IF a <= WindowRows(WindowCurrent) THEN
             WindowLocate a, 1
             WindowPrint -1, z$(WindowCurrent, a)
         END IF
     NEXT a
 RETURN

 END SUB

 FUNCTION GetFileCount (FileSpec$)
     count = 0
     fileName$ = DIR$(FileSpec$)
     DO WHILE fileName$ <> ""
         count = count + 1
         fileName$ = DIR$
     LOOP
     GetFileCount = count
 END FUNCTION

 SUB MonoDisplay
     DisplayType = FALSE
     MouseHide
     SetupMenu
     MenuSetState 2, 1, 1
     MenuSetState 2, 2, 2
     SetupDesktop
     MenuShow
     MouseShow
 END SUB

 DEFSNG A-Z
 SUB SetupDesktop STATIC

     MouseHide

     WIDTH , 25

     IF DisplayType THEN
         COLOR 15, 1      'Color
     ELSE
         COLOR 15, 0      'Monochrome
     END IF
     CLS

     FOR a = 2 TO 80 STEP 4
         FOR B = 2 TO 25 STEP 2
             LOCATE B, a
             PRINT CHR$(250);
         NEXT B
     NEXT a

     MouseShow
 END SUB

 DEFINT A-Z
 SUB SetupMenu

     MenuSet 1, 0, 1, "Demos", 1
     MenuSet 1, 1, 1, "Alert Window         F1", 1
     MenuSet 1, 2, 1, "Dialog Box (Simple)  F2", 13
     MenuSet 1, 3, 1, "Dialog Box (Complex) F3", 13
     MenuSet 1, 4, 1, "List Boxes           F4", 1
     MenuSet 1, 5, 1, "List Box w/File List F5", 12
     MenuSet 1, 6, 1, "Scroll Bars          F6", 8
     MenuSet 1, 7, 1, "Windows - Multiple   F7", 11
     MenuSet 1, 8, 1, "Window - Resizable   F8", 10
     MenuSet 1, 9, 1, "-", 1
     MenuSet 1, 10, 1, "Exit             Ctrl-X", 2

     MenuSet 2, 0, 1, "Options", 1
     MenuSet 2, 1, 1, "Color", 1
     MenuSet 2, 2, 1, "Monochrome", 1


     MenuSet 3, 0, 1, "Help", 1
     MenuSet 3, 1, 1, "About This Demo", 12
     MenuSet 3, 2, 1, "About The User Interface", 11
     MenuSet 3, 3, 1, "About the Windows", 11
     MenuSet 3, 4, 1, "Using the Mouse", 11
     MenuSet 3, 5, 1, "Using Access Keys", 7
     MenuSet 3, 6, 1, "Using Quick Keys", 7

     ShortCutKeySet 1, 1, CHR$(0) + CHR$(59) ' F1
     ShortCutKeySet 1, 2, CHR$(0) + CHR$(60) ' F2
     ShortCutKeySet 1, 3, CHR$(0) + CHR$(61) ' F3
     ShortCutKeySet 1, 4, CHR$(0) + CHR$(62) ' F4
     ShortCutKeySet 1, 5, CHR$(0) + CHR$(63) ' F5
     ShortCutKeySet 1, 6, CHR$(0) + CHR$(64) ' F6
     ShortCutKeySet 1, 7, CHR$(0) + CHR$(65) ' F7
     ShortCutKeySet 1, 8, CHR$(0) + CHR$(66) ' F8

     ShortCutKeySet 1, 10, CHR$(24)          ' Ctrl-X

     IF NOT DisplayType THEN
         MenuColor 0, 7, 15, 8, 7, 0, 15   'Best for monochrome and colors
     ELSE
         MenuColor 0, 7, 4, 8, 15, 0, 12   'Best for color
     END IF

     MenuPreProcess

 END SUB



 WHEREIS.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\WHEREIS.BAS

 DEFINT A-Z

 ' Declare symbolic constants used in program:
 CONST EOFTYPE = 0, FILETYPE = 1, DIRTYPE = 2, ROOT = "TWH"

 DECLARE SUB ScanDir (PathSpec$, Level, FileSpec$, Row)

 DECLARE FUNCTION MakeFileName$ (Num)
 DECLARE FUNCTION GetEntry$ (FileNum, EntryType)
 CLS
 INPUT "File to look for"; FileSpec$
 PRINT
 PRINT "Enter the directory where the search should start"
 PRINT "(optional drive + directories). Press <ENTER> to "
 PRINT "begin search in root directory of current drive."
 PRINT
 INPUT "Starting directory"; PathSpec$
 CLS

 RightCh$ = RIGHT$(PathSpec$, 1)

 IF PathSpec$ = "" OR RightCh$ = ":" OR RightCh$ <> "\" THEN
         PathSpec$ = PathSpec$ + "\"
 END IF

 FileSpec$ = UCASE$(FileSpec$)
 PathSpec$ = UCASE$(PathSpec$)
 Level = 1
 Row = 3

 ' Make the top level call (level 1) to begin the search:
 ScanDir PathSpec$, Level, FileSpec$, Row

 KILL ROOT + ".*"        ' Delete all temporary files created
                         ' by the program.

 LOCATE Row + 1, 1: PRINT "Search complete."
 END
 ' ======================= GETENTRY ========================
 '    This procedure processes entry lines in a DIR listing
 '    saved to a file.

 '    This procedure returns the following values:
 ' ===================== MAKEFILENAME$ =====================
 '    This procedure makes a file name from a root string
 '    ("TWH," defined as a symbolic constant at the module
 '    level) and a number passed to it as an argument (Num).
 ' =========================================================

 ' ======================= SCANDIR =========================
 '   This procedure recursively scans a directory for the
 '   file name entered by the user.

 '   NOTE: The SUB header doesn't use the STATIC keyword
 '         since this procedure needs a new set of variables
 '         each time it is invoked.
 ' =========================================================

 '  GetEntry$   A valid file or directory name
 '  EntryType   If equal to 1, then GetEntry$
 '        is a file.
 '        If equal to 2, then GetEntry$
 '        is a directory.
 ' =========================================================
 FUNCTION GetEntry$ (FileNum, EntryType) STATIC

         ' Loop until a valid entry or end-of-file (EOF) is read:
         DO UNTIL EOF(FileNum)
                 LINE INPUT #FileNum, EntryLine$
                 IF EntryLine$ <> "" THEN

                         ' Get first character from the line for test:
          TestCh$ = LEFT$(EntryLine$, 1)
          IF TestCh$ <> " " AND TestCh$ <> "." THEN EXIT DO
                 END IF
         LOOP

         ' Entry or EOF found, decide which:
         IF EOF(FileNum) THEN    ' EOF, so return EOFTYPE
                 EntryType = EOFTYPE  ' in EntryType.
                 GetEntry$ = ""

         ELSE                 ' Not EOF, so it must be a
                                         ' file or a directory.

                 ' Build and return the entry name:
                 EntryName$ = RTRIM$(LEFT$(EntryLine$, 8))

                 ' Test for extension and add to name if there is one:
                 EntryExt$ = RTRIM$(MID$(EntryLine$, 10, 3))
                 IF EntryExt$ <> "" THEN
                         GetEntry$ = EntryName$ + "." + EntryExt$
                 ELSE
          GetEntry$ = EntryName$
                 END IF

                 ' Determine the entry type, and return that value
                 ' to the point where GetEntry$ was called:
                 IF MID$(EntryLine$, 15, 3) = "DIR" THEN
          EntryType = DIRTYPE            ' Directory
                 ELSE
          EntryType = FILETYPE           ' File
                 END IF

         END IF

 END FUNCTION

 FUNCTION MakeFileName$ (Num) STATIC

         MakeFileName$ = ROOT + "." + LTRIM$(STR$(Num))

 END FUNCTION

 SUB ScanDir (PathSpec$, Level, FileSpec$, Row)

         LOCATE 1, 1: PRINT "Now searching"; SPACE$(50);
         LOCATE 1, 15: PRINT PathSpec$;

         ' Make a file specification for the temporary file:
         TempSpec$ = MakeFileName$(Level)

         ' Get a directory listing of the current directory,
         ' and save it in the temporary file:
         SHELL "DIR " + PathSpec$ + " > " + TempSpec$

         ' Get the next available file number:
         FileNum = FREEFILE

         ' Open the DIR listing file and scan it:
         OPEN TempSpec$ FOR INPUT AS #FileNum
 ' Process the file, one line at a time:
         DO

                 ' Input an entry from the DIR listing file:
                 DirEntry$ = GetEntry$(FileNum, EntryType)

                 ' If entry is a file:
                 IF EntryType = FILETYPE THEN

          ' If the FileSpec$ string matches,
          ' print entry and exit this loop:
          IF DirEntry$ = FileSpec$ THEN
                  LOCATE Row, 1: PRINT PathSpec$; DirEntry$;
                  Row = Row + 1
                  EntryType = EOFTYPE
          END IF

                 ' If the entry is a directory, then make a recursive
                 ' call to ScanDir with the new directory:
                 ELSEIF EntryType = DIRTYPE THEN
          NewPath$ = PathSpec$ + DirEntry$ + "\"
          ScanDir NewPath$, Level + 1, FileSpec$, Row
          LOCATE 1, 1: PRINT "Now searching"; SPACE$(50);
          LOCATE 1, 15: PRINT PathSpec$;
                 END IF

         LOOP UNTIL EntryType = EOFTYPE

         ' Scan on this DIR listing file is finished, so close it:
         CLOSE FileNum
 END SUB



 WINDOW.BAS
 CD-ROM Disc Path:   \SAMPCODE\BASIC\WINDOW.BAS

 '============================================================================
 '
 '    WINDOW.BAS - Window Routines for the User Interface Toolbox in
 '           Microsoft BASIC 7.0, Professional Development System
 '              Copyright (C) 1987-1989, Microsoft Corporation
 '
 '  NOTE:
 '           This sample source code toolbox is intended to demonstrate some
 '           of the extended capabilities of Microsoft BASIC 7.0 Professional
 '           Development system that can help to leverage the professional
 '           developer's time more effectively.  While you are free to use,
 '           modify, or distribute the routines in this module in any way you
 '           find useful, it should be noted that these are examples only and
 '           should not be relied upon as a fully-tested "add-on" library.
 '
 '  PURPOSE: These routines provide dialog box and window support to the
 '           user interface toolbox.
 '
 '  For information on creating a library and QuickLib from the routines
 '  contained in this file, read the comment header of GENERAL.BAS.
 '
 '==========================================================================

 DEFINT A-Z

 '$INCLUDE: 'general.bi'
 '$INCLUDE: 'mouse.bi'
 '$INCLUDE: 'menu.bi'
 '$INCLUDE: 'window.bi'


 COMMON SHARED /uitools/ GloMenu           AS MenuMiscType
 COMMON SHARED /uitools/ GloTitle()        AS MenuTitleType
 COMMON SHARED /uitools/ GloItem()         AS MenuItemType
 COMMON SHARED /uitools/ GloWindow()       AS windowType
 COMMON SHARED /uitools/ GloButton()       AS buttonType
 COMMON SHARED /uitools/ GloEdit()         AS EditFieldType
 COMMON SHARED /uitools/ GloStorage        AS WindowStorageType
 COMMON SHARED /uitools/ GloWindowStack()  AS INTEGER
 COMMON SHARED /uitools/ GloBuffer$()

 FUNCTION Alert (style, text$, row1, col1, row2, col2, b1$, b2$, b3$)

     ' =======================================================================
     ' Open an alert window, then return the button that was pushed
     ' =======================================================================

     Alert = 0

     ' =======================================================================
     ' Make sure coordinates and butttons are valid
     ' =======================================================================

     IF row1 >= MINROW AND row2 <= MAXROW AND col1 >= MINCOL AND col2 <= MAXCO

         IF b1$ = "" THEN
             b1$ = "OK"
             b2$ = ""
             b3$ = ""
         END IF

         IF b2$ = "" THEN
             b3$ = ""
         END IF

         ' ===================================================================
         ' If a window is available, compute button locations
         ' ===================================================================

         alertWindow = WindowNext

         IF alertWindow <> 0 THEN

             minWidth = 3
             buttonTotal = 0

             IF b1$ <> "" THEN
                 minWidth = minWidth + 7 + LEN(b1$):
                 buttonTotal = buttonTotal + 1
             END IF

             IF b2$ <> "" THEN
                 minWidth = minWidth + 7 + LEN(b2$)
                 buttonTotal = buttonTotal + 1
             END IF

             IF b3$ <> "" THEN
                 minWidth = minWidth + 7 + LEN(b3$)
                 buttonTotal = buttonTotal + 1
             END IF

             actualWidth = col2 - col1 + 1
             actualHeight = row2 - row1 + 1

             ' ===============================================================
             ' If size is valid, open window, print text, open buttons
             ' ===============================================================

             IF actualWidth >= minWidth AND actualHeight >= 3 THEN

                 WindowOpen alertWindow, row1, col1, row2, col2, 0, 7, 0, 7, 1
                 WindowLine actualHeight - 1

                 text$ = text$ + "|"
                 WHILE text$ <> ""
                     x$ = LEFT$(text$, INSTR(text$, "|") - 1)
                     text$ = RIGHT$(text$, LEN(text$) - LEN(x$) - 1)
                     WindowPrint style, x$
                 WEND

                 charTotal = LEN(b1$) + LEN(b2$) + LEN(b3$) + 4 * buttonTotal
                 avgSpace = INT((actualWidth - charTotal) / (buttonTotal + 1))

                 IF LEN(b1$) > 0 THEN
                     ButtonOpen 1, 2, b1$, actualHeight, avgSpace + 1, 0, 0, 1
                 END IF

                 IF LEN(b2$) > 0 THEN
                     ButtonOpen 2, 1, b2$, actualHeight, avgSpace * 2 + LEN(b1
                 END IF

                 IF LEN(b3$) > 0 THEN
                     ButtonOpen 3, 1, b3$, actualHeight, avgSpace * 3 + LEN(b1
                 END IF

                 ' ===========================================================
                 ' Main window processing loop
                 ' ===========================================================

                 currButton = 1

                 ExitFlag = FALSE
                 WHILE NOT ExitFlag
                     WindowDo currButton, 0
                     SELECT CASE Dialog(0)
                         CASE 1                      'Button Pressed
                             Alert = Dialog(1)
                             ExitFlag = TRUE
                         CASE 6, 14                  'Enter or Space
                             Alert = currButton
                             ExitFlag = TRUE
                         CASE 7                      'Tab
                             ButtonSetState currButton, 1
                             currButton = (currButton) MOD buttonTotal + 1
                             ButtonSetState currButton, 2
                         CASE 8                      'BackTab
                             ButtonSetState currButton, 1
                             currButton = (currButton + buttonTotal - 2) MOD b
                             ButtonSetState currButton, 2
                         CASE 9
                             IF UCASE$(b1$) = "CANCEL" THEN
                                 Alert = 1
                             END IF
                             IF UCASE$(b2$) = "CANCEL" THEN
                                 Alert = 2
                             END IF
                             IF UCASE$(b3$) = "CANCEL" THEN
                                 Alert = 3
                             END IF
                             ExitFlag = TRUE
                         CASE ELSE
                     END SELECT
                 WEND

                 WindowClose alertWindow

             END IF
         END IF
     END IF

 END FUNCTION

 SUB BackgroundRefresh (handle)

     ' =======================================================================
     ' Refresh the background behind a window
     ' =======================================================================

     IF GloWindow(handle).handle > 0 THEN
         MouseHide
         PutBackground GloWindow(handle).row1 - 1, GloWindow(handle).col1 - 1,
         MouseShow
     END IF
 END SUB

 SUB BackgroundSave (handle)

     ' =======================================================================
     ' Save the background before a window opens, or is moved... etc
     ' =======================================================================

     IF GloWindow(handle).handle > 0 THEN
         MouseHide
         GetBackground GloWindow(handle).row1 - 1, GloWindow(handle).col1 - 1,
         MouseShow
     END IF
 END SUB

 SUB ButtonClose (handle)

     ' =======================================================================
     ' Make sure a window is actually opened
     ' =======================================================================

     windo = WindowCurrent

     IF windo > 0 THEN

         ' ===================================================================
         ' If handle=0, recursively close all buttons in the CURRENT WINDOW on
         ' ===================================================================

         IF handle = 0 THEN
             IF GloStorage.numButtonsOpen > 0 THEN
                 FOR A = GloStorage.numButtonsOpen TO 1 STEP -1
                     IF GloButton(A).windowHandle = windo THEN
                         ButtonClose GloButton(A).handle
                     END IF
                 NEXT A
             END IF
         ELSE
             ' ===============================================================
             ' Get the index into the global array based on handle, and
             ' currWindow
             ' ===============================================================

             button = FindButton(handle)

             ' ===============================================================
             ' If valid, hide button, then squeeze array, decrement totals
             ' ===============================================================

             IF button > 0 THEN

                 COLOR GloWindow(windo).fore, GloWindow(windo).back
                 SELECT CASE GloButton(button).buttonType
                     CASE 1, 2, 3
                         LOCATE GloWindow(windo).row1 + GloButton(button).row1
                         MouseHide
                         PRINT SPACE$(4 + LEN(RTRIM$(GloButton(button).text$))
                         MouseShow
                     CASE 6
                         MouseHide
                         FOR A = 1 TO GloButton(button).row2 - GloButton(butto
                             LOCATE GloWindow(windo).row1 + GloButton(button).
                             PRINT " ";
                         NEXT A
                         MouseShow
                     CASE 7
                         LOCATE GloWindow(windo).row1 + GloButton(button).row1
                         MouseHide
                         PRINT SPACE$(GloButton(button).col2 - GloButton(butto
                         MouseShow
                     CASE ELSE
                 END SELECT


                 GloStorage.numButtonsOpen = GloStorage.numButtonsOpen - 1
                 WHILE button <= GloStorage.numButtonsOpen
                     GloButton(button).row1 = GloButton(button + 1).row1
                     GloButton(button).col1 = GloButton(button + 1).col1
                     GloButton(button).row2 = GloButton(button + 1).row2
                     GloButton(button).col2 = GloButton(button + 1).col2
                     GloButton(button).text = GloButton(button + 1).text
                     GloButton(button).handle = GloButton(button + 1).handle
                     GloButton(button).state = GloButton(button + 1).state
                     GloButton(button).buttonType = GloButton(button + 1).butt
                     GloButton(button).windowHandle = GloButton(button + 1).wi
                     button = button + 1
                 WEND
             END IF
         END IF
     END IF

 END SUB

 FUNCTION ButtonInquire (handle)

     ' =======================================================================
     ' If valid, return then state of the button
     ' =======================================================================

     button = FindButton(handle)

     IF button > 0 THEN
         ButtonInquire = GloButton(button).state
     ELSE
         ButtonInquire = 0
     END IF

 END FUNCTION

 SUB ButtonOpen (handle, state, title$, row1, col1, row2, col2, buttonType)

     ' =======================================================================
     ' Open a button - first check if window can be resized - If so, do not
     ' open!
     ' =======================================================================

     IF MID$(WindowBorder$(GloWindow(WindowCurrent).windowType), 9, 1) = "+" T
         resize = TRUE
     END IF

     IF (resize AND buttonType >= 6) OR NOT resize THEN

         ' ===================================================================
         ' If scroll bar, then make sure "state" is valid, given bar length
         ' ===================================================================

         IF buttonType = 6 THEN
             length = (row2 - row1) - 1
             IF state < 1 THEN state = 1
             IF state > length THEN state = length
         END IF

         IF buttonType = 7 THEN
             length = (col2 - col1) - 1
             IF state < 1 THEN state = 1
             IF state > length THEN state = length
         END IF


         ' ===================================================================
         ' If valid state and type, increment totals, and store button info
         ' ===================================================================

         IF (buttonType = 1 AND state >= 1 AND state <= 3) OR (buttonType >= 2
             ButtonClose handle

             GloStorage.numButtonsOpen = GloStorage.numButtonsOpen + 1
             GloButton(GloStorage.numButtonsOpen).row1 = row1
             GloButton(GloStorage.numButtonsOpen).col1 = col1
             GloButton(GloStorage.numButtonsOpen).row2 = row2
             GloButton(GloStorage.numButtonsOpen).col2 = col2
             GloButton(GloStorage.numButtonsOpen).text = title$
             GloButton(GloStorage.numButtonsOpen).state = state
             GloButton(GloStorage.numButtonsOpen).handle = handle
             GloButton(GloStorage.numButtonsOpen).buttonType = buttonType
             GloButton(GloStorage.numButtonsOpen).windowHandle = WindowCurrent
             ButtonShow handle
         ELSE
             PRINT "Cannot open button on window that can be re-sized!"
             END
         END IF
     END IF
 END SUB

 SUB ButtonSetState (handle, state)

     button = FindButton(handle)
     windo = WindowCurrent

     ' =======================================================================
     ' If valid state for the type of button, assign the new state, and re-sho
     ' =======================================================================

     IF button > 0 AND windo > 0 THEN
         SELECT CASE GloButton(button).buttonType
             CASE 1
                 IF state >= 1 AND state <= 3 THEN
                     GloButton(button).state = state
                 END IF
             CASE 2, 3
                 IF state = 1 OR state = 2 THEN
                     GloButton(button).state = state
                 END IF
             CASE 4, 5
             CASE 6
                 IF state <> GloButton(button).state THEN
                     MouseHide
                     COLOR 0, 7
                     LOCATE GloWindow(windo).row1 + GloButton(button).row1 - 1
                     PRINT CHR$(176);
                     GloButton(button).state = state
                     LOCATE GloWindow(windo).row1 + GloButton(button).row1 - 1
                     PRINT CHR$(219);
                     MouseShow
                 END IF
             CASE 7
                 IF state <> GloButton(button).state THEN
                     MouseHide
                     COLOR 0, 7
                     LOCATE GloWindow(windo).row1 + GloButton(button).row1 - 1
                     PRINT CHR$(176);
                     GloButton(button).state = state
                     LOCATE GloWindow(windo).row1 + GloButton(button).row1 - 1
                     PRINT CHR$(219);
                     MouseShow
                 END IF
             CASE ELSE
         END SELECT
     END IF

     ButtonShow handle
 END SUB

 SUB ButtonShow (handle)

     button = FindButton(handle)
     windo = WindowCurrent

     ' =======================================================================
     ' If valid, show the button based on button type and button state
     ' =======================================================================

     IF button > 0 THEN
         LOCATE GloWindow(windo).row1 + GloButton(button).row1 - 1, GloWindow(

         MouseHide
         SELECT CASE GloButton(button).buttonType
             CASE 1
                 SELECT CASE GloButton(button).state
                     CASE 1
                         COLOR GloWindow(windo).textFore, GloWindow(windo).tex
                         PRINT "< " + RTRIM$(GloButton(button).text$) + " >";
                     CASE 2
                         COLOR GloWindow(windo).highlight, GloWindow(windo).te
                         PRINT "<";
                         COLOR GloWindow(windo).textFore, GloWindow(windo).tex
                         PRINT " "; RTRIM$(GloButton(button).text$); " ";
                         COLOR GloWindow(windo).highlight, GloWindow(windo).te
                         PRINT ">";
                     CASE 3
                         COLOR GloWindow(windo).textBack, GloWindow(windo).tex
                         PRINT "< " + RTRIM$(GloButton(button).text$) + " >";
                 END SELECT
             CASE 2
                 SELECT CASE GloButton(button).state
                     CASE 1
                         COLOR GloWindow(windo).textFore, GloWindow(windo).tex
                         PRINT "[ ] " + RTRIM$(GloButton(button).text$);
                     CASE 2
                         COLOR GloWindow(windo).textFore, GloWindow(windo).tex
                         PRINT "[X] " + RTRIM$(GloButton(button).text$);
                 END SELECT
             CASE 3
                 SELECT CASE GloButton(button).state
                     CASE 1
                         COLOR GloWindow(windo).textFore, GloWindow(windo).tex
                         PRINT "( ) " + RTRIM$(GloButton(button).text$);
                     CASE 2
                         COLOR GloWindow(windo).textFore, GloWindow(windo).tex
                         PRINT "() " + RTRIM$(GloButton(button).text$);
                 END SELECT
             CASE 4, 5
             CASE 6
                 COLOR 0, 7
                 PRINT CHR$(24);
                 FOR A = 1 TO GloButton(button).row2 - GloButton(button).row1
                     LOCATE GloWindow(windo).row1 + GloButton(button).row1 - 1
                     IF A = GloButton(button).state THEN
                         PRINT CHR$(219);
                     ELSE
                         PRINT CHR$(176);
                     END IF
                 NEXT A
                 LOCATE GloWindow(windo).row1 + GloButton(button).row1 - 1 + A
                 PRINT CHR$(25);
             CASE 7
                 COLOR 0, 7
                 PRINT CHR$(27); STRING$(GloButton(button).col2 - GloButton(bu
                 LOCATE GloWindow(windo).row1 + GloButton(button).row1 - 1, Gl
                 PRINT CHR$(219);
             CASE ELSE
                 PRINT "Error in Button Parameter";
         END SELECT
         MouseShow
     END IF
 END SUB

 SUB ButtonToggle (handle)

     button = FindButton(handle)
     windo = WindowCurrent

     ' =======================================================================
     ' If valid button, and state is 1 or 2, toggle button
     ' =======================================================================

     IF button > 0 THEN
         IF GloButton(button).state = 1 OR GloButton(button).state = 2 THEN
            GloButton(button).state = 3 - GloButton(button).state
         END IF
     END IF

     ButtonShow handle

 END SUB

 FUNCTION Dialog (op)

     ' =======================================================================
     ' Based on global variables set in WindowDo, return proper event ID/Info
     ' =======================================================================

     SELECT CASE op

         ' ===================================================================
         ' Return event ID, and reset all variables.
         ' ===================================================================

         CASE 0
             GloStorage.DialogButton = GloStorage.oldDialogButton
             GloStorage.DialogEdit = GloStorage.oldDialogEdit
             GloStorage.DialogWindow = GloStorage.oldDialogWindow
             GloStorage.DialogClose = GloStorage.oldDialogClose
             GloStorage.DialogScroll = GloStorage.oldDialogScroll
             GloStorage.DialogRow = GloStorage.oldDialogRow
             GloStorage.DialogCol = GloStorage.oldDialogCol
             Dialog = GloStorage.oldDialogEvent

             GloStorage.oldDialogButton = 0
             GloStorage.oldDialogEdit = 0
             GloStorage.oldDialogWindow = 0
             GloStorage.oldDialogClose = 0
             GloStorage.oldDialogScroll = 0
             GloStorage.oldDialogRow = 0
             GloStorage.oldDialogCol = 0

         ' ===================================================================
         ' If button is pressed, dialog(0) is 1, and dialog(1) is the button
         ' number
         ' ===================================================================

         CASE 1
             Dialog = GloStorage.DialogButton


         ' ===================================================================
         ' If edit field is clicked, dialog(0) is 2, and dialog(2) is the edit
         ' field number
         ' ===================================================================

         CASE 2
             Dialog = GloStorage.DialogEdit

         ' ===================================================================
         ' If another window is clicked, dialog(0)=3, and dialog(3)=window
         ' number
         ' ===================================================================

         CASE 3
             Dialog = GloStorage.DialogWindow

         ' ===================================================================
         ' If a field button was pressed This returns the row (relative to
         ' window position) of the click
         ' ===================================================================

         CASE 17
             Dialog = GloStorage.DialogRow

         ' ===================================================================
         ' If a field button was pressed This returns the column (relative to
         ' window position) of the click
         ' ===================================================================

         CASE 18
             Dialog = GloStorage.DialogCol

         ' ===================================================================
         ' If a scroll bar was clicked, return new position of marker
         ' ===================================================================

         CASE 19
             Dialog = GloStorage.DialogScroll

         ' ===================================================================
         ' Bad call, so return 0
         ' ===================================================================

         CASE ELSE
             Dialog = 0
     END SELECT


 END FUNCTION

 SUB EditFieldClose (handle)

     ' =======================================================================
     ' Close an edit field
     ' =======================================================================

     windo = WindowCurrent

     IF windo > 0 THEN
         IF handle = 0 THEN

             ' ===============================================================
             ' If handle = 0, then recursivily close all edit fields
             ' ===============================================================

             IF GloStorage.numEditFieldsOpen > 0 THEN
                 FOR A = GloStorage.numEditFieldsOpen TO 1 STEP -1
                     IF GloEdit(A).windowHandle = windo THEN
                         EditFieldClose GloEdit(A).handle
                     END IF
                 NEXT A
             END IF
         ELSE

             ' ===============================================================
             ' else, erase edit field, then squeeze array, decrement total
             ' variables
             ' ===============================================================

             editField = FindEditField(handle)

             IF editField > 0 THEN
                 LOCATE GloWindow(windo).row1 + GloEdit(editField).row - 1, Gl
                 COLOR GloWindow(windo).fore, GloWindow(windo).back
                 MouseHide
                 PRINT SPACE$(GloEdit(editField).visLength);
                 MouseShow

                 GloStorage.numEditFieldsOpen = GloStorage.numEditFieldsOpen -
                 WHILE editField <= GloStorage.numEditFieldsOpen
                     GloEdit(editField).row = GloEdit(editField + 1).row
                     GloEdit(editField).col = GloEdit(editField + 1).col
                     GloEdit(editField).text = GloEdit(editField + 1).text
                     GloEdit(editField).handle = GloEdit(editField + 1).handle
                     GloEdit(editField).visLength = GloEdit(editField + 1).vis
                     GloEdit(editField).maxLength = GloEdit(editField + 1).max
                     GloEdit(editField).windowHandle = GloEdit(editField + 1).
                     editField = editField + 1
                 WEND
             END IF
         END IF
     END IF
 END SUB

 FUNCTION EditFieldInquire$ (handle)

     ' =======================================================================
     ' If valid edit field, return the value.  Note edit$ is terminated
     ' by a CHR$(0), or maxLength, or 255 chars.
     ' =======================================================================

     editField = FindEditField(handle)
     windo = WindowCurrent
     EditFieldInquire$ = ""

     IF editField > 0 THEN
         x$ = GloEdit(editField).text$
         x = INSTR(x$, CHR$(0)) - 1
         IF x >= 0 THEN
             EditFieldInquire$ = LEFT$(x$, x)
         ELSE
             EditFieldInquire$ = x$
         END IF
     END IF

 END FUNCTION

 SUB EditFieldOpen (handle, text$, row, col, fore, back, visLength, maxLength)

     ' =======================================================================
     ' If window can be re-sized, do not open edit field
     ' =======================================================================

     IF MID$(WindowBorder$(GloWindow(WindowCurrent).windowType), 9, 1) <> "+"

         ' ===================================================================
         ' Close edit field by the same handle if it exists
         ' ===================================================================

         EditFieldClose handle

         windo = WindowCurrent

         ' ===================================================================
         ' If no colors given, use default window colors
         ' ===================================================================

         IF fore = 0 AND back = 0 THEN
             fore = GloWindow(windo).fore
             back = GloWindow(windo).back
         END IF

         ' ===================================================================
         ' Increment totals, and store edit field info
         ' ===================================================================

         GloStorage.numEditFieldsOpen = GloStorage.numEditFieldsOpen + 1
         GloEdit(GloStorage.numEditFieldsOpen).row = row
         GloEdit(GloStorage.numEditFieldsOpen).col = col
         GloEdit(GloStorage.numEditFieldsOpen).fore = fore
         GloEdit(GloStorage.numEditFieldsOpen).back = back
         GloEdit(GloStorage.numEditFieldsOpen).text = text$ + CHR$(0)
         GloEdit(GloStorage.numEditFieldsOpen).visLength = visLength
         GloEdit(GloStorage.numEditFieldsOpen).maxLength = maxLength
         GloEdit(GloStorage.numEditFieldsOpen).windowHandle = windo
         GloEdit(GloStorage.numEditFieldsOpen).handle = handle

         LOCATE GloWindow(windo).row1 + row - 1, GloWindow(windo).col1 + col -
         COLOR fore, back

         'Create temp$ so that padding with spaces doesn't alter the original
         IF LEN(text$) < visLength THEN
             temp$ = text$ + SPACE$(visLength - LEN(text$))
         ELSE
             temp$ = LEFT$(text$, visLength)
         END IF
         PRINT temp$;

     ELSE
         PRINT "EditField cannot be opened on a window that can be re-sized!"
     END IF
 END SUB

 FUNCTION FindButton (handle)

     ' =======================================================================
     ' Given a handle, return the index into the global array that stores
     ' buttons.  Each button is uniquely described by a handle, and a window#
     ' This SUB program assumes that you want the current window.
     ' =======================================================================

     FindButton = 0

     IF GloStorage.numButtonsOpen > 0 THEN
         A = 0
         curr = WindowCurrent
         DO
             A = A + 1
         LOOP UNTIL (GloButton(A).handle = handle AND GloButton(A).windowHandl

         IF GloButton(A).handle = handle AND GloButton(A).windowHandle = curr
             FindButton = A
         END IF
     END IF

 END FUNCTION

 FUNCTION FindEditField (handle)

     ' =======================================================================
     ' Given a handle, return the index into the global array that stores
     ' edit fields.  Each button is uniquely described by a handle, and a
     ' window number. This SUB program assumes the you want the current window
     ' =======================================================================

     FindEditField = 0

     IF GloStorage.numEditFieldsOpen > 0 THEN
         A = 0
         curr = WindowCurrent
         DO
             A = A + 1
         LOOP UNTIL (GloEdit(A).handle = handle AND GloEdit(A).windowHandle =

         IF GloEdit(A).handle = handle AND GloEdit(A).windowHandle = curr THEN
             FindEditField = A
         END IF
     END IF

 END FUNCTION

 ' ==========================================================================
 ' The ListBox FUNCTION can be modified to accept a box width parameter. This
 ' will enable you to specify the width of a listbox when you call the ListBox
 ' FUNCTION. Below you will find two FUNCTION statements. The first is the
 ' default ListBox FUNCTION that takes only two arguments.  The second allows
 ' you to specify a box width parameter. As configured, the listbox width is
 ' assumed to be 14. This default is idal for listboxes that contain file
 ' names. To use the second form of the ListBox FUNCTION, that
 ' lets you specify the listbox width, comment out the first FUNCTION
 ' statement and remove the ' from the beginning of the second FUNCTION
 ' statement. Change the WINDOW.BI file so that the DECLARE statement matches
 ' the actual FUNCTION as follows:
 '
 ' DECLARE FUNCTION ListBox (Text$(), MaxRec%, BoxWidth%)
 '
 ' You also need to comment out the "BoxWidth = 14" statement that occurs just
 ' after second FUNCTION statement.
 '
 ' When you use the ListBox FUNCTION be sure to include a box width parameter
 ' as the third argument.  All calculations will be automatically performed
 ' to properly display the listbox.
 '
 ' ===========================================================================
 '
 FUNCTION ListBox (text$(), MaxRec)
 'FUNCTION ListBox (text$(), MaxRec, BoxWidth)

     ' Comment out the following line if you modify this function to allow
     ' specification of a ListBox width parameter in the function call.

     BoxWidth = 14

     GOSUB ListBoxWidthCalc

     ' =======================================================================
     ' Open up a modal window and put the right buttons in it
     ' =======================================================================

     WindowOpen 1, 4, StartRowPos, 20, StopRowPos, 0, 7, 0, 7, 15, 0, 0, 0, 1,

     WindowBox 1, 6, 14, BoxEndPos
     ButtonOpen 1, 1, "", 2, BoxEndPos, 13, BoxEndPos, 6     'Scroll Bar
     ButtonOpen 2, 2, "OK", 16, 6, 0, 0, 1                   'OK button
     ButtonOpen 3, 1, "Cancel", 16, BoxEndPos - 9, 0, 0, 1   'Cancel button
     ButtonOpen 4, 1, "", 1, 8, 1, AreaEndPos, 4             'Area above box
     ButtonOpen 5, 1, "", 2, 7, 13, AreaEndPos + 1, 4        'Area of box
     ButtonOpen 6, 1, "", 14, 8, 14, AreaEndPos, 4           'Area below box

     currTop = 1
     currPos = 1
     currButton = 2

     GOSUB ListBoxDrawText

     ExitFlag = FALSE

     ' =======================================================================
     ' Process window events...
     '  IMPORTANT:  Window moving, and re-sizing is handled automatically
     '  The window type dictates when this is allowed to happen.
     ' =======================================================================

     WHILE NOT ExitFlag
         WindowDo currButton, 0
         x = Dialog(0)

         SELECT CASE x
             CASE 1
                 button = Dialog(1)
                 SELECT CASE button
                     CASE 1
                         scrollCode = Dialog(19)
                         SELECT CASE scrollCode
                             CASE -1:   GOSUB ListBoxUp
                             CASE -2:   GOSUB ListBoxDown
                             CASE ELSE: GOSUB ListBoxMove
                         END SELECT
                     CASE 2
                         ListBox = currTop + currPos - 1
                         ExitFlag = TRUE
                     CASE 3
                         ListBox = 0
                         ExitFlag = TRUE
                     CASE 4
                         GOSUB ListBoxUp
                     CASE 5
                         GOSUB ListBoxAssign
                     CASE 6
                         GOSUB ListBoxDown
                 END SELECT
             CASE 6, 14
                 SELECT CASE currButton
                     CASE 0, 2
                         ListBox = currTop + currPos - 1
                         ExitFlag = TRUE
                     CASE 3
                         ListBox = 0
                         ExitFlag = TRUE
                     CASE ELSE
                 END SELECT
             CASE 7
                 SELECT CASE currButton
                     CASE 0
                         currButton = 2
                     CASE 2
                         ButtonToggle 2
                         ButtonToggle 3
                         currButton = 3
                     CASE 3
                         ButtonToggle 2
                         ButtonToggle 3
                         currButton = 0
                 END SELECT
             CASE 8
                 SELECT CASE currButton
                     CASE 0
                         ButtonToggle 2
                         ButtonToggle 3
                         currButton = 3
                     CASE 2
                         currButton = 0
                     CASE 3
                         ButtonToggle 2
                         ButtonToggle 3
                         currButton = 2
                 END SELECT
             CASE 9
                 ListBox = 0
                 ExitFlag = TRUE
             CASE 10, 12
                 IF currButton = 0 THEN
                     GOSUB ListBoxUp
                 END IF
             CASE 11, 13
                 IF currButton = 0 THEN
                     GOSUB ListBoxDown
                 END IF
             CASE 16
                 scrollCode = 1
                 GOSUB ListBoxMove
             CASE 17
                 scrollCode = 10
                 GOSUB ListBoxMove
             CASE 18
                 GOSUB ListBoxPgUp
             CASE 19
                 GOSUB ListBoxPgDn
             CASE ELSE
         END SELECT
     WEND

     WindowClose 0
     EXIT FUNCTION

 ListBoxUp:
     oldRec = currTop + currPos - 1
     currPos = currPos - 1
     IF currPos < 1 THEN
         currPos = 1
         currTop = currTop - 1
         IF currTop < 1 THEN
             currTop = 1
         END IF
     END IF
     newRec = currTop + currPos - 1
     IF oldRec <> newRec THEN
         GOSUB ListBoxDrawText
         GOSUB ListBoxNewBarPos
     END IF
 RETURN

 ListBoxDown:
     oldRec = currTop + currPos - 1
     IF MaxRec > 12 THEN
         currPos = currPos + 1
         IF currPos > 12 THEN
             currPos = 12
             currTop = currTop + 1
             IF currTop + currPos - 1 > MaxRec THEN
                 currTop = currTop - 1
             END IF
         END IF
     ELSE
         IF currPos + 1 <= MaxRec THEN
             currPos = currPos + 1
         END IF
     END IF

     newRec = currTop + currPos - 1
     IF oldRec <> newRec THEN
         GOSUB ListBoxDrawText
         GOSUB ListBoxNewBarPos
     END IF
 RETURN

 ListBoxPgUp:
     oldRec = currTop + currPos - 1
     currTop = currTop - 12
     IF currTop < 1 THEN
         currTop = 1
         currPos = 1
     END IF
     newRec = currTop + currPos - 1
     IF oldRec <> newRec THEN
         GOSUB ListBoxDrawText
         GOSUB ListBoxNewBarPos
     END IF
 RETURN

 ListBoxPgDn:
     oldRec = currTop + currPos - 1
     IF MaxRec > 12 THEN
         currTop = currTop + 12
             IF currTop + 12 > MaxRec THEN
                 currTop = MaxRec - 11
                 currPos = 12
             END IF
     ELSE
         currPos = MaxRec
     END IF

     newRec = currTop + currPos - 1
     IF oldRec <> newRec THEN
         GOSUB ListBoxDrawText
         GOSUB ListBoxNewBarPos
     END IF
 RETURN

 ListBoxAssign:
     currPos = Dialog(17)
     IF currPos > MaxRec THEN currPos = MaxRec
     GOSUB ListBoxDrawText
     GOSUB ListBoxNewBarPos

 RETURN

 ListBoxMove:
     SELECT CASE scrollCode
         CASE 1:      newPos = 1
         CASE 2 TO 9: newPos = scrollCode * MaxRec / 10
         CASE 10:     newPos = MaxRec
     END SELECT

     IF newPos < 1 THEN newPos = 1
     IF newPos > MaxRec THEN newPos = MaxRec

     currPos = newPos - currTop + 1
     IF currPos <= 0 THEN
         currTop = newPos
         currPos = 1
     ELSEIF currPos > 12 THEN
         currPos = 12
         currTop = newPos - 11
     END IF
     GOSUB ListBoxDrawText
     GOSUB ListBoxNewBarPos
 RETURN

 ListBoxDrawText:
     FOR A = currTop TO currTop + 11
         IF A <= MaxRec THEN
             IF currTop + currPos - 1 = A THEN
                 WindowColor 7, 0
             ELSE
                 WindowColor 0, 7
             END IF

             WindowLocate A - currTop + 2, 8
             WindowPrint -1, LEFT$(text$(A) + STRING$(BoxWidth + 1, " "), BoxW
         END IF
     NEXT A
     WindowColor 0, 7
     RETURN

 ListBoxNewBarPos:
     IF currPos = 1 AND currTop = 1 THEN
         newState = 1
     ELSE
         newState = (currTop + currPos - 1) * 10 / MaxRec
         IF newState < 1 THEN newState = 1
         IF newState > 10 THEN newState = 10
     END IF
     ButtonSetState 1, newState
 RETURN

 ListBoxWidthCalc:
     IF BoxWidth < 14 THEN BoxWidth = 14
     IF BoxWidth > 55 THEN BoxWidth = 55
     StartRowPos = 40 - ((BoxWidth + 14) / 2)
     StopRowPos = StartRowPos + BoxWidth + 14
     BoxEndPos = BoxWidth + 10
     AreaEndPos = BoxWidth + 8
 RETURN

 END FUNCTION

 FUNCTION MaxScrollLength (handle)

     ' =======================================================================
     ' If valid, return then maximum length of scroll bar
     ' =======================================================================

     button = FindButton(handle)

     IF button > 0 THEN
         SELECT CASE GloButton(button).buttonType
             CASE 6
                 MaxScrollLength = GloButton(button).row2 - GloButton(button).
             CASE 7
                 MaxScrollLength = GloButton(button).col2 - GloButton(button).
             CASE ELSE
                 MaxScrollLength = 0
         END SELECT
     ELSE
         MaxScrollLength = 0
     END IF

 END FUNCTION

 FUNCTION WhichWindow (row, col)

     ' =======================================================================
     ' Returns the window number where the row,col points to.  Takes into
     ' account which windows overlap which other windows by going down
     ' the GloWindowStack from the top.
     ' =======================================================================

     x = GloStorage.numWindowsOpen
     Found = FALSE
     WhichWindow = 0

     WHILE x > 0 AND NOT Found
         handle = GloWindowStack(x)
         row1 = GloWindow(handle).row1 - 1
         col1 = GloWindow(handle).col1 - 1
         row2 = GloWindow(handle).row2 + 1
         col2 = GloWindow(handle).col2 + 1

         IF row >= row1 AND row <= row2 AND col >= col1 AND col <= col2 THEN
             WhichWindow = handle
             Found = TRUE
         ELSE
             x = x - 1
         END IF
     WEND

 END FUNCTION

 FUNCTION WindowBorder$ (windowType)

     ' =======================================================================
     ' Returns a window border for the given window type.
     ' You may customize this to create custom windows.  See external
     ' documentation for a discussion of window borders
     ' =======================================================================

     SELECT CASE ABS(windowType)
         CASE 1
             WindowBorder$ = " ░          ST"
         CASE 2
             WindowBorder$ = "=           ST"
         CASE 3
             WindowBorder$ = "=░          ST"
         CASE 4
             WindowBorder$ = "        +   ST"
         CASE 5
             WindowBorder$ = " ░      +   ST"
         CASE 6
             WindowBorder$ = "=       +   ST"
         CASE 7
             WindowBorder$ = "=░      +   ST"
         CASE 8
             WindowBorder$ = "┌─┐│ │└─┘├─┤ST"
         CASE 9
             WindowBorder$ = "┌░┐│ │└─┘├─┤ST"
         CASE 10
             WindowBorder$ = "=─┐│ │└─┘├─┤ST"
         CASE 11
             WindowBorder$ = "=░┐│ │└─┘├─┤ST"
         CASE 12
             WindowBorder$ = "┌─┐│ │└─+├─┤ST"
         CASE 13
             WindowBorder$ = "┌░┐│ │└─+├─┤ST"
         CASE 14
             WindowBorder$ = "=─┐│ │└─+├─┤ST"
         CASE 15
             WindowBorder$ = "=░┐│ │└─+├─┤ST"
         CASE 16
             WindowBorder$ = "╔═╗║ ║╚═╝╠═╣ST"
         CASE 17
             WindowBorder$ = "╔░╗║ ║╚═╝╠═╣ST"
         CASE 18
             WindowBorder$ = "=═╗║ ║╚═╝╠═╣ST"
         CASE 19
             WindowBorder$ = "=░╗║ ║╚═╝╠═╣ST"
         CASE 20
             WindowBorder$ = "╔═╗║ ║╚═+╠═╣ST"
         CASE 21
             WindowBorder$ = "╔░╗║ ║╚═+╠═╣ST"
         CASE 22
             WindowBorder$ = "=═╗║ ║╚═+╠═╣ST"
         CASE 23
             WindowBorder$ = "=░╗║ ║╚═+╠═╣ST"

         ' ===================================================================
         ' Put any custom-designed border styles after this point and before
         ' the CASE ELSE statement.
         ' ===================================================================

         CASE ELSE
             WindowBorder$ = "            ST"

     END SELECT

 END FUNCTION

 SUB WindowBox (boxRow1, boxCol1, boxRow2, boxCol2)

     ' =======================================================================
     ' Draw a box, given coordinates based on the current window
     ' =======================================================================

     windo = WindowCurrent
     IF windo > 0 THEN
         row1 = GloWindow(windo).row1 + boxRow1 - 1
         row2 = GloWindow(windo).row1 + boxRow2 - 1
         col1 = GloWindow(windo).col1 + boxCol1 - 1
         col2 = GloWindow(windo).col1 + boxCol2 - 1
         fore = GloWindow(windo).fore
         back = GloWindow(windo).back
         border$ = "┌─┐│ │└─┘"

         Box row1, col1, row2, col2, fore, back, border$, 0
     END IF

 END SUB

 SUB WindowClose (handle)

     ' =======================================================================
     ' Close window # handle.  If handle is 0, recursively close all windows
     ' =======================================================================

     IF handle = 0 THEN
         IF GloStorage.numWindowsOpen > 0 THEN
             FOR x = GloStorage.numWindowsOpen TO 1 STEP -1
                 WindowClose GloWindowStack(x)
             NEXT x
         END IF
     ELSE

         ' ===================================================================
         ' If valid window,
         ' ===================================================================

         IF GloWindow(handle).handle <> -1 THEN

             ' ===============================================================
             ' Make the window you want to close the top window
             ' ===============================================================

             WindowSetCurrent handle

             ' ===============================================================
             ' If top window has shadow, hide shadow
             ' ===============================================================

             IF INSTR(WindowBorder$(GloWindow(GloStorage.currWindow).windowTyp
                 WindowShadowRefresh
             END IF

             ' ===============================================================
             ' Close all edit fields, and button on top window
             ' ===============================================================

             EditFieldClose 0
             ButtonClose 0
             MouseHide

             ' ===============================================================
             ' Restore the background of the window + clear data
             ' ===============================================================

             BackgroundRefresh handle

             GloBuffer$(handle, 1) = ""
             GloBuffer$(handle, 2) = ""

             GloWindow(handle).handle = -1

             ' ===============================================================
             ' Decrement total number of windows
             ' ===============================================================

             GloStorage.numWindowsOpen = GloStorage.numWindowsOpen - 1

             ' ===============================================================
             ' If some windows still open, assign curr Window to top window,
             ' show shadow is the currWindow has a shadow
             ' ===============================================================

             IF GloStorage.numWindowsOpen > 0 THEN
                 GloStorage.currWindow = GloWindowStack(GloStorage.numWindowsO

                 IF INSTR(WindowBorder$(GloWindow(GloStorage.currWindow).windo
                     WindowShadowSave
                 END IF
             ELSE

                 ' ===========================================================
                 ' If no more windows open, assign 0 to the currWindow variabl
                 ' ===========================================================

                 GloStorage.currWindow = 0
             END IF
             MouseShow
         END IF
     END IF

 END SUB

 SUB WindowCls

     ' =======================================================================
     ' If curr window is valid, clear the window
     ' =======================================================================

     windo = WindowCurrent
     IF windo > 0 THEN
         WindowScroll 0
     END IF

 END SUB

 SUB WindowColor (fore, back)

     ' =======================================================================
     ' If curr window is valid, assign the colors to the variables
     ' =======================================================================

     windo = WindowCurrent
     IF windo > 0 THEN
         GloWindow(windo).textFore = fore
         GloWindow(windo).textBack = back
     END IF

 END SUB

 FUNCTION WindowCols (handle)

     ' =======================================================================
     ' If window Handle is valid, return number of columns in that window
     ' =======================================================================

     IF GloWindow(handle).handle > 0 THEN
         WindowCols = GloWindow(handle).col2 - GloWindow(handle).col1 + 1
     END IF

 END FUNCTION

 FUNCTION WindowCurrent

     ' =======================================================================
     ' Simply return the current window, as stored in the global array
     ' =======================================================================

     WindowCurrent = GloStorage.currWindow

 END FUNCTION

 SUB WindowDo (startButton, startEdit)

   DIM RB$(1 TO 4)

     ' =======================================================================
     ' Main Processing loop.  Init, go to proper mode, exit
     ' =======================================================================

     GOSUB WindowDoInit
     GOSUB WindowDoComputeHotSpots

     IF WindowDoMode = 1 THEN
         GOSUB WindowDoEditMode
     ELSE
         GOSUB WindowDoButtonMode
     END IF
     LOCATE , , 0
     EXIT SUB

 ' ===========================================================================
 ' If startEdit is=0 then do button mode.  In button mode, we wait
 ' for any keyboard event or mouse event that flips the ExitFlag.
 ' Then we exit.  It's very simple really, don't try to make it complicated.
 ' ===========================================================================

 WindowDoButtonMode:
     GOSUB WindowDoShowTextCursor
     WHILE NOT ExitFlag
         GOSUB WindowDoMouse
         GOSUB WindowDoButtonKbd
     WEND
     GOSUB WindowDoHideTextCursor
 RETURN

 ' ===========================================================================
 ' If startEdit>0 then go to edit mode.  Here we also wait for a mouse event
 ' or kbd event to flip the ExitFlag, but in the mean time, we trap the
 ' alphanumberic keys, and arrow keys, and use them to edit the current
 ' edit field.  (StartEdit is the current edit field.)  Again, there's no magi
 ' (well maybe just a little...)
 ' ===========================================================================

 WindowDoEditMode:
     GOSUB WindowDoEditInit
     WHILE NOT ExitFlag
         GOSUB WindowDoMouse
         GOSUB WindowDoEditKbd
     WEND
     GOSUB WindowDoEditExit
 RETURN

 ' ===========================================================================
 ' Set initial flags, determine where cursor should be located, and figure
 ' out which mode we should be in (edit mode or button mode)
 ' ===========================================================================

 WindowDoInit:

     ' =======================================================================
     ' Simply abort if there is no window open.
     ' =======================================================================

     windo = WindowCurrent
     IF windo = 0 THEN EXIT SUB

     REDIM HSClick(MAXHOTSPOT) AS hotSpotType
     REDIM HSRel(MAXHOTSPOT) AS hotSpotType

     ExitFlag = FALSE
     ButtonHighLight = FALSE

     border$ = WindowBorder$(GloWindow(windo).windowType)
     WindowDoMode = 2

     ' =======================================================================
     ' If startEdit>0, assign the index value to currEditField, and set
     ' WindowDoMode to 1
     ' =======================================================================

     IF startEdit > 0 THEN
         index = FindEditField(startEdit)
         IF index > 0 THEN
             currEditField = index
             WindowDoMode = 1
             origCursorRow = GloWindow(windo).row1 + GloEdit(index).row - 1
             origCursorCol = GloWindow(windo).col1 + GloEdit(index).col - 1
         END IF
     END IF

     ' =======================================================================
     ' If start button>0, then set current cursor location properly
     ' =======================================================================

     IF startButton > 0 THEN
         index = FindButton(startButton)
         IF index > 0 THEN
             currButton = index
             origCursorRow = GloWindow(windo).row1 + GloButton(index).row1 - 1
             origCursorCol = GloWindow(windo).col1 + GloButton(index).col1

             ' ===============================================================
             ' For area buttons decrement the cursor position
             ' ===============================================================

             SELECT CASE GloButton(index).buttonType
                 CASE 4
                     origCursorCol = origCursorCol - 1
                 CASE ELSE
             END SELECT

         END IF
     END IF

     currCursorRow = origCursorRow
     currCursorCol = origCursorCol
 RETURN

 ' ===========================================================================
 ' Checks buttons, editfields, etc. and stores where the hot spots are
 ' ===========================================================================

 WindowDoComputeHotSpots:
     numHSClick = 0
     numHSRel = 0

     ' =======================================================================
     ' If upper left corder of border is "=", then that's a close box
     ' Furthermore, a close box is a release type event so store in HSRel
     ' =======================================================================

     IF MID$(border$, 1, 1) = "=" THEN
         numHSRel = numHSRel + 1
         HSRel(numHSRel).row1 = GloWindow(windo).row1 - 1
         HSRel(numHSRel).row2 = GloWindow(windo).row1 - 1
         HSRel(numHSRel).col1 = GloWindow(windo).col1 - 1
         HSRel(numHSRel).col2 = GloWindow(windo).col1 - 1
         HSRel(numHSRel).action = 4
         HSRel(numHSRel).misc = windo
     END IF

     ' =======================================================================
     ' If lower right corner is "+", then that's a re-size box
     ' Further more, a re-size box is a click event, so store in HSClick
     ' =======================================================================

     IF MID$(border$, 9, 1) = "+" THEN
         numHSClick = numHSClick + 1
         HSClick(numHSClick).row1 = GloWindow(windo).row2 + 1
         HSClick(numHSClick).row2 = GloWindow(windo).row2 + 1
         HSClick(numHSClick).col1 = GloWindow(windo).col2 + 1
         HSClick(numHSClick).col2 = GloWindow(windo).col2 + 1
         HSClick(numHSClick).action = 5
         HSClick(numHSClick).misc = 0
     END IF

     ' =======================================================================
     ' Likewise, a "░" chr$(176) is a move bar.  That's also a click event
     ' =======================================================================

     IF MID$(border$, 2, 1) = "░" THEN
         numHSClick = numHSClick + 1
         HSClick(numHSClick).row1 = GloWindow(windo).row1 - 1
         HSClick(numHSClick).row2 = GloWindow(windo).row1 - 1
         HSClick(numHSClick).col1 = GloWindow(windo).col1
         HSClick(numHSClick).col2 = GloWindow(windo).col2
         HSClick(numHSClick).action = 15
         HSClick(numHSClick).misc = 0
     END IF

     ' =======================================================================
     ' Buttons are click, and release events.
     ' Click, and the cursor goes there, and the button is highlighted.
     ' Release, and the selection is made
     ' =======================================================================

     IF GloStorage.numButtonsOpen > 0 THEN
         button = 0
         WHILE button < GloStorage.numButtonsOpen
             button = button + 1
             IF GloButton(button).windowHandle = windo THEN
                 numHSClick = numHSClick + 1
                 HSClick(numHSClick).row1 = GloWindow(windo).row1 + GloButton(
                 HSClick(numHSClick).row2 = GloWindow(windo).row1 + GloButton(
                 HSClick(numHSClick).col1 = GloWindow(windo).col1 + GloButton(
                 HSClick(numHSClick).col2 = GloWindow(windo).col1 + GloButton(
                 HSClick(numHSClick).action = 1
                 HSClick(numHSClick).misc = GloButton(button).handle
                 HSClick(numHSClick).misc2 = GloButton(button).buttonType

                 numHSRel = numHSRel + 1
                 HSRel(numHSRel).row1 = GloWindow(windo).row1 + GloButton(butt
                 HSRel(numHSRel).row2 = GloWindow(windo).row1 + GloButton(butt
                 HSRel(numHSRel).col1 = GloWindow(windo).col1 + GloButton(butt
                 HSRel(numHSRel).col2 = GloWindow(windo).col1 + GloButton(butt
                 HSRel(numHSRel).action = 1
                 HSRel(numHSRel).misc = GloButton(button).handle
                 HSRel(numHSRel).misc2 = GloButton(button).buttonType

                 ' ===========================================================
                 ' Adjust previous info to handle special cases for
                 ' "field" buttons, and "scroll bar" buttons.
                 ' ===========================================================

                 SELECT CASE GloButton(button).buttonType
                     CASE 4
                         numHSRel = numHSRel - 1
                         HSClick(numHSClick).row2 = GloWindow(windo).row1 + Gl
                         HSClick(numHSClick).col2 = GloWindow(windo).col1 + Gl
                     CASE 5
                         numHSClick = numHSClick - 1
                         HSRel(numHSRel).row2 = GloWindow(windo).row1 + GloBut
                         HSRel(numHSRel).col2 = GloWindow(windo).col1 + GloBut
                     CASE 6
                         numHSRel = numHSRel - 1
                         HSClick(numHSClick).row2 = GloWindow(windo).row1 + Gl
                         HSClick(numHSClick).col2 = GloWindow(windo).col1 + Gl
                     CASE 7
                         numHSRel = numHSRel - 1
                         HSClick(numHSClick).row2 = GloWindow(windo).row1 + Gl
                         HSClick(numHSClick).col2 = GloWindow(windo).col1 + Gl
                     CASE ELSE
                 END SELECT
             END IF
         WEND
     END IF

     ' =======================================================================
     ' EditFields are Click events
     ' =======================================================================

     IF GloStorage.numEditFieldsOpen > 0 THEN
         editField = 0
         WHILE editField < GloStorage.numEditFieldsOpen
             editField = editField + 1
             IF GloEdit(editField).windowHandle = windo THEN
                 numHSClick = numHSClick + 1
                 HSClick(numHSClick).row1 = GloWindow(windo).row1 + GloEdit(ed
                 HSClick(numHSClick).row2 = GloWindow(windo).row1 + GloEdit(ed
                 HSClick(numHSClick).col1 = GloWindow(windo).col1 + GloEdit(ed
                 HSClick(numHSClick).col2 = GloWindow(windo).col1 + GloEdit(ed
                 HSClick(numHSClick).action = 2
                 HSClick(numHSClick).misc = GloEdit(editField).handle
             END IF
         WEND
     END IF

     ' =======================================================================
     ' Feel free to add your own hot spots!  One good idea is if the
     ' right hand side of the border is ▓, make that a scroll bar!  Adding
     ' that would be good practice -- and fun too!
     ' =======================================================================

 RETURN

 ' ===========================================================================
 ' Polls the mouse
 ' ===========================================================================

 WindowDoMouse:

     MousePoll MouseRow, MouseCol, lButton, rButton

     ' =======================================================================
     ' If lButton is down, then keep checking for click events until it's rele
     ' =======================================================================

     IF lButton THEN
         WHILE lButton AND MouseRow <> 1 AND NOT ExitFlag
             GOSUB WindowDoCheckClickEvent
             IF Found THEN
                 GOSUB WindowDoClickEvent
             END IF

             MousePoll MouseRow, MouseCol, lButton, rButton
         WEND

         ' ===================================================================
         ' If the button was released (and no click event occured) then check
         ' for a release event!
         ' ===================================================================

         IF NOT lButton AND MouseRow <> 1 AND NOT ExitFlag THEN
             GOSUB WindowDoCheckReleaseEvent
             IF Found THEN
                 GOSUB WindowDoReleaseEvent
             ELSE

                 ' ===========================================================
                 ' If no release event, then see if mouse was released in anot
                 ' window.  This is a special case release event
                 ' ===========================================================

                 GOSUB WindowDoCheckOtherWindow
             END IF

             ' ===============================================================
             ' Un highlight the button if the mouse was released for any reaso
             ' ===============================================================

             GOSUB WindowDoUnHighlightButton

         END IF


     END IF

     ' =======================================================================
     ' If in button mode, return cursor to original spot.
     ' =======================================================================

     IF WindowDoMode = 2 THEN
         currCursorRow = origCursorRow
         currCursorCol = origCursorCol
         GOSUB WindowDoShowTextCursor
     END IF

 RETURN

 ' ===========================================================================
 ' Used only in Button mode.  Checks for menu event with MenuInkey$,
 ' then checks for all the misc events.  See below
 ' If an event is found, the proper event ID is stored, and ExifFlag is set
 ' ===========================================================================

 WindowDoButtonKbd:

     ' =======================================================================
     ' Only check menu if window type > 0.
     ' =======================================================================

     IF GloWindow(windo).windowType < 0 THEN
         kbd$ = INKEY$
     ELSE
         kbd$ = MenuInkey$
     END IF

     ' =======================================================================
     ' The following is a list of key strokes that can be detected. You can
     ' add more as needed, but you will need to change any programs that use
     ' the existing configuration.  The numbers associated with each key are
     ' the numbers that are returned by Dialog(0).
     ' =======================================================================

     SELECT CASE kbd$
         CASE CHR$(13)
             GloStorage.oldDialogEvent = 6          'Return
             ExitFlag = TRUE
         CASE CHR$(9)
             GloStorage.oldDialogEvent = 7          'Tab
             ExitFlag = TRUE
         CASE CHR$(0) + CHR$(15)
             GloStorage.oldDialogEvent = 8          'Back Tab
             ExitFlag = TRUE
         CASE CHR$(27)
             GloStorage.oldDialogEvent = 9          'Escape
             ExitFlag = TRUE
         CASE CHR$(0) + "H"
             GloStorage.oldDialogEvent = 10         'Up
             ExitFlag = TRUE
         CASE CHR$(0) + "P"
             GloStorage.oldDialogEvent = 11         'Down
             ExitFlag = TRUE
         CASE CHR$(0) + "K"
             GloStorage.oldDialogEvent = 12         'Left
             ExitFlag = TRUE
         CASE CHR$(0) + "M"
             GloStorage.oldDialogEvent = 13         'Right
             ExitFlag = TRUE
         CASE " "
             GloStorage.oldDialogEvent = 14         'Space
             ExitFlag = TRUE
         CASE CHR$(0) + "G"
             GloStorage.oldDialogEvent = 16         'Home
             ExitFlag = TRUE
         CASE CHR$(0) + "O"
             GloStorage.oldDialogEvent = 17         'End
             ExitFlag = TRUE
         CASE CHR$(0) + "I"
             GloStorage.oldDialogEvent = 18         'PgUp
             ExitFlag = TRUE
         CASE CHR$(0) + "Q"
             GloStorage.oldDialogEvent = 19         'PgDn
             ExitFlag = TRUE
         CASE "menu"
             GloStorage.oldDialogEvent = 20         'Menu
             ExitFlag = TRUE
         CASE ELSE
     END SELECT
 RETURN

 ' ===========================================================================
 ' Checks mouseRow, mouseCol against all the click events stored in HSClick
 ' ===========================================================================

 WindowDoCheckClickEvent:
     currEvent = 1
     Found = FALSE

     WHILE NOT Found AND currEvent <= numHSClick
         IF MouseRow >= HSClick(currEvent).row1 AND MouseRow <= HSClick(currEv
             Found = TRUE
         ELSE
             currEvent = currEvent + 1
         END IF
     WEND

     IF NOT Found THEN
         GOSUB WindowDoUnHighlightButton
     END IF

 RETURN

 ' ===========================================================================
 ' Checks mouseRow,mouseCol against all the release events in HSRel
 ' ===========================================================================

 WindowDoCheckReleaseEvent:
     currEvent = 1
     Found = FALSE

     WHILE NOT Found AND currEvent <= numHSRel
         IF MouseRow >= HSRel(currEvent).row1 AND MouseRow <= HSRel(currEvent)
             Found = TRUE
         ELSE
             currEvent = currEvent + 1
         END IF
     WEND
 RETURN

 ' ===========================================================================
 ' Calls WhichWindow to see if mouseRow, mouseCol is in another window
 ' If it is, that's event ID #3, so set it, and set ExitFlag to TRUE
 ' ===========================================================================

 WindowDoCheckOtherWindow:
     IF GloWindow(windo).windowType > 0 THEN
         otherWindow = WhichWindow(MouseRow, MouseCol)
         IF otherWindow AND (otherWindow <> windo) THEN
             GloStorage.oldDialogEvent = 3
             GloStorage.oldDialogWindow = otherWindow
             ExitFlag = TRUE
         END IF
     END IF
 RETURN

 ' ===========================================================================
 ' If there was a release event, this routine handles it
 ' ===========================================================================

 WindowDoReleaseEvent:

     SELECT CASE HSRel(currEvent).action
         CASE 1                                      'Released on Button
             GloStorage.oldDialogEvent = 1
             GloStorage.oldDialogButton = HSRel(currEvent).misc
             ExitFlag = TRUE
         CASE 4                                      'Released on Close Box
             GloStorage.oldDialogEvent = 4
             GloStorage.oldDialogClose = HSRel(currEvent).misc
             ExitFlag = TRUE
         CASE ELSE
     END SELECT
 RETURN

 ' ===========================================================================
 ' If there was a click event, this routine handles it
 ' ===========================================================================

 WindowDoClickEvent:

     SELECT CASE HSClick(currEvent).action
         CASE 1                                          'ButtonClick
             SELECT CASE HSClick(currEvent).misc2
                 CASE 1
                     IF ButtonHighLight THEN
                         IF currButton <> HSClick(currEvent).misc THEN
                             ButtonSetState currButton, origState
                             currButton = HSClick(currEvent).misc
                             ButtonSetState currButton, 3
                         END IF
                     ELSE
                         currButton = HSClick(currEvent).misc
                         origState = ButtonInquire(currButton)
                         ButtonHighLight = TRUE
                         ButtonSetState currButton, 3
                     END IF

                     currCursorRow = HSClick(currEvent).row1
                     currCursorCol = HSClick(currEvent).col1 + 1
                     GOSUB WindowDoShowTextCursor
                 CASE 2, 3
                     currCursorRow = HSClick(currEvent).row1
                     currCursorCol = HSClick(currEvent).col1 + 1
                     GOSUB WindowDoShowTextCursor
                 CASE 4
                     IF ButtonHighLight THEN
                         ButtonSetState currButton, origState
                     END IF

                     GloStorage.oldDialogEvent = 1
                     GloStorage.oldDialogButton = HSClick(currEvent).misc
                     GloStorage.oldDialogRow = MouseRow - HSClick(currEvent).r
                     GloStorage.oldDialogCol = MouseCol - HSClick(currEvent).c
                     ExitFlag = TRUE
                 CASE 6
                     GloStorage.oldDialogEvent = 1
                     GloStorage.oldDialogButton = HSClick(currEvent).misc

                     IF MouseRow = HSClick(currEvent).row1 THEN
                         GloStorage.oldDialogScroll = -1
                     ELSEIF MouseRow = HSClick(currEvent).row2 THEN
                         GloStorage.oldDialogScroll = -2
                     ELSE
                         GloStorage.oldDialogScroll = MouseRow - HSClick(currE
                     END IF

                     ExitFlag = TRUE
                 CASE 7
                     GloStorage.oldDialogEvent = 1
                     GloStorage.oldDialogButton = HSClick(currEvent).misc

                     IF MouseCol = HSClick(currEvent).col1 THEN
                         GloStorage.oldDialogScroll = -1
                     ELSEIF MouseCol = HSClick(currEvent).col2 THEN
                         GloStorage.oldDialogScroll = -2
                     ELSE
                         GloStorage.oldDialogScroll = MouseCol - HSClick(currE
                     END IF

                     ExitFlag = TRUE
                 CASE ELSE
             END SELECT
         CASE 2                                      'Edit Field Click
             GloStorage.oldDialogEvent = 2           'Event ID #2
             GloStorage.oldDialogEdit = HSClick(currEvent).misc
             ExitFlag = TRUE
         CASE 5
             GOSUB WindowDoSize                      'Internally handle Re-Siz
             ExitFlag = TRUE
             GloStorage.oldDialogEvent = 5
         CASE 15
             GOSUB WindowDoHideTextCursor
             GOSUB WindowDoMove                      'Internally handle Move
             ExitFlag = TRUE
             GloStorage.oldDialogEvent = 15
         CASE ELSE

     END SELECT

     IF HSClick(currEvent).action <> 1 THEN
         GOSUB WindowDoUnHighlightButton
     END IF

 RETURN

 ' ===========================================================================
 ' Un-highlight a button
 ' ===========================================================================

 WindowDoUnHighlightButton:
     IF ButtonHighLight THEN
         ButtonSetState currButton, origState
         ButtonHighLight = FALSE
         GOSUB WindowDoShowTextCursor
     END IF
 RETURN

 ' ===========================================================================
 ' Handle the move window click -- drag the window around until button release
 ' ===========================================================================

 WindowDoMove:
     MouseHide
     WindowSave windo
     BackgroundRefresh windo
     IF INSTR(WindowBorder$(GloWindow(windo).windowType), "S") THEN
       WindowShadowRefresh
     END IF

     oldWinrow1 = GloWindow(windo).row1
     oldWincol1 = GloWindow(windo).col1
     oldWinrow2 = GloWindow(windo).row2
     oldWincol2 = GloWindow(windo).col2

     GOSUB DrawRubberBand

     WindowPrintTitle
     MouseShow

     MouseBorder MINROW, (MouseCol - GloWindow(windo).col1 + 1 + MINCOL), (MAX

     oldMouseRow = MouseRow
     oldMouseCol = MouseCol

     DO
         MousePoll MouseRow, MouseCol, lButton, rButton
         IF MouseRow <> oldMouseRow OR MouseCol <> oldMouseCol THEN
             MouseHide

             GOSUB EraseRubberBand

             oldWinrow1 = oldWinrow1 - oldMouseRow + MouseRow
             oldWinrow2 = oldWinrow2 - oldMouseRow + MouseRow
             oldWincol1 = oldWincol1 - oldMouseCol + MouseCol
             oldWincol2 = oldWincol2 - oldMouseCol + MouseCol

             oldMouseRow = MouseRow
             oldMouseCol = MouseCol

             GOSUB DrawRubberBand
             MouseShow
         END IF

     LOOP UNTIL NOT lButton

     MouseHide
     GOSUB EraseRubberBand
     GloWindow(windo).row1 = oldWinrow1
     GloWindow(windo).row2 = oldWinrow2
     GloWindow(windo).col1 = oldWincol1
     GloWindow(windo).col2 = oldWincol2
     BackgroundSave windo
     WindowRefresh windo
     IF INSTR(WindowBorder$(GloWindow(windo).windowType), "S") THEN
         WindowShadowSave
     END IF
     GloBuffer$(windo, 2) = ""
     MouseShow
     MouseBorder 1, 1, MAXROW, MAXCOL
     GOSUB WindowDoComputeHotSpots
 RETURN

 ' ===========================================================================
 ' Re-Size window -- Drag box around until button released, then exit
 ' with eventID #5  -- Window need refreshing
 ' ===========================================================================

 WindowDoSize:
     ButtonClose 0
     MouseHide
     WindowSave windo

     ' ======================================================================
     ' Comment out the next line if you want to retain the window contents
     ' while resizing the window.
     ' ======================================================================

     BackgroundRefresh windo

     IF INSTR(WindowBorder$(GloWindow(windo).windowType), "S") THEN
       WindowShadowRefresh
     END IF

     oldWinrow1 = GloWindow(windo).row1
     oldWincol1 = GloWindow(windo).col1
     oldWinrow2 = GloWindow(windo).row2
     oldWincol2 = GloWindow(windo).col2

     GOSUB DrawRubberBand

     MouseShow
     MouseBorder GloWindow(windo).row1 + 3, GloWindow(windo).col1 + 6, MAXROW,

     oldMouseRow = MouseRow
     oldMouseCol = MouseCol

     DO
         MousePoll MouseRow, MouseCol, lButton, rButton
         IF MouseRow <> oldMouseRow OR MouseCol <> oldMouseCol THEN
             MouseHide

             GOSUB EraseRubberBand

             oldWinrow2 = oldWinrow2 - oldMouseRow + MouseRow
             oldWincol2 = oldWincol2 - oldMouseCol + MouseCol

             oldMouseRow = MouseRow
             oldMouseCol = MouseCol

             GOSUB DrawRubberBand
             MouseShow
         END IF
     LOOP UNTIL NOT lButton

     MouseHide
     GOSUB EraseRubberBand
     WindowShadowRefresh
     BackgroundRefresh windo
     GloWindow(windo).row2 = oldWinrow2
     GloWindow(windo).col2 = oldWincol2
     BackgroundSave windo
     Box GloWindow(windo).row1 - 1, GloWindow(windo).col1 - 1, GloWindow(windo
     GloBuffer$(windo, 2) = ""
     WindowPrintTitle

     IF INSTR(WindowBorder$(GloWindow(windo).windowType), "S") THEN
         WindowShadowSave
     END IF
     MouseShow

     MouseBorder 1, 1, MAXROW, MAXCOL
 RETURN

 ' ===========================================================================
 ' Draw rubber band of current window
 ' ===========================================================================

 DrawRubberBand:
   GetBackground oldWinrow1 - 1, oldWincol1 - 1, oldWinrow1 - 1, oldWincol2 +
   GetBackground oldWinrow2 + 1, oldWincol1 - 1, oldWinrow2 + 1, oldWincol2 +
   GetBackground oldWinrow1 - 1, oldWincol1 - 1, oldWinrow2 + 1, oldWincol1 -
   GetBackground oldWinrow1 - 1, oldWincol2 + 1, oldWinrow2 + 1, oldWincol2 +
   Box oldWinrow1 - 1, oldWincol1 - 1, oldWinrow2 + 1, oldWincol2 + 1, GloWind
 RETURN

 ' ===========================================================================
 ' Erase rubber band of current window
 ' ===========================================================================

 EraseRubberBand:
   PutBackground oldWinrow1 - 1, oldWincol1 - 1, RB$(1)
   PutBackground oldWinrow2 + 1, oldWincol1 - 1, RB$(2)
   PutBackground oldWinrow1 - 1, oldWincol1 - 1, RB$(3)
   PutBackground oldWinrow1 - 1, oldWincol2 + 1, RB$(4)
   RETURN

 WindowDoHideTextCursor:
     LOCATE , , 0
 RETURN


 WindowDoShowTextCursor:
     IF currCursorRow <> 0 AND currCursorCol <> 0 THEN
         LOCATE currCursorRow, currCursorCol, 1
     ELSE
         LOCATE , , 0
     END IF
 RETURN

 ' ===========================================================================
 ' If in edit mode, this routine gets info from the global arrays
 ' ===========================================================================

 WindowDoEditInit:
     row = GloWindow(windo).row1 + GloEdit(currEditField).row - 1
     col = GloWindow(windo).col1 + GloEdit(currEditField).col - 1
     fore = GloEdit(currEditField).fore
     back = GloEdit(currEditField).back
     visLength = GloEdit(currEditField).visLength
     maxLength = GloEdit(currEditField).maxLength
     editField$ = LEFT$(GloEdit(currEditField).text$, maxLength)
     insertMode = TRUE
     InsertKey = GetShiftState(7)

     ' =======================================================================
     ' Make sure everything's the right length
     ' =======================================================================

     x = INSTR(editField$, CHR$(0)) - 1
     IF x >= 0 THEN
         editField$ = LEFT$(editField$, x)
     END IF

     IF LEN(editField$) >= visLength THEN
         firstchar = LEN(editField$) - visLength + 2
         cursor = visLength - 1
     ELSE
         firstchar = 1
         cursor = LEN(editField$)
     END IF

     GOSUB WindowDoEditPrint

 RETURN

 ' ===========================================================================
 ' Handles the edit kbd event trapping.  Some keys trigger events
 ' (e.g. TAB is event ID #7)  Others affect the current edit field string (DEL
 ' ===========================================================================

 WindowDoEditKbd:
     IF GetShiftState(7) = InsertKey THEN
         insertMode = TRUE
         LOCATE , , , 6, 7
     ELSE
         insertMode = FALSE
         LOCATE , , , 0, 7
     END IF

     LOCATE row, col + cursor, 1

     GOSUB WindowDoMouse

     ' =======================================================================
     ' Only call MenuInkey$ if menuType > 0
     ' =======================================================================

     IF GloWindow(windo).windowType < 0 THEN
         kbd$ = INKEY$
     ELSE
         kbd$ = MenuInkey$
     END IF

     ' =======================================================================
     ' Either key is an event, and the exitFlag is set, or something happens
     ' to the current edit string.
     ' =======================================================================

     SELECT CASE kbd$
         CASE CHR$(13)
             GloStorage.oldDialogEvent = 6          'Return
             ExitFlag = TRUE
         CASE CHR$(9)
             GloStorage.oldDialogEvent = 7          'Tab
             ExitFlag = TRUE
         CASE CHR$(0) + CHR$(15)
             GloStorage.oldDialogEvent = 8          'Back Tab
             ExitFlag = TRUE
         CASE CHR$(27)
             GloStorage.oldDialogEvent = 9          'Escape
             ExitFlag = TRUE
         CASE CHR$(0) + "H"
             GloStorage.oldDialogEvent = 10         'Up
             ExitFlag = TRUE
         CASE CHR$(0) + "P"
             GloStorage.oldDialogEvent = 11         'Down
             ExitFlag = TRUE
         CASE CHR$(0) + "M"                         'Right
             GOSUB WindowDoEditRight
         CASE CHR$(0) + "K"
             cursor = cursor - 1
             IF cursor < 0 THEN
                 cursor = cursor + 1
                 IF firstchar > 1 THEN
                     firstchar = firstchar - 1
                     GOSUB WindowDoEditPrint
                 END IF
             END IF

         CASE CHR$(0) + "S"
             IF cursor + firstchar <= LEN(editField$) THEN
                 editField$ = LEFT$(editField$, cursor + firstchar - 1) + RIGH
                 GOSUB WindowDoEditPrint
             END IF
         CASE CHR$(8)
             IF firstchar + cursor > 1 THEN
                 editField$ = LEFT$(editField$, cursor + firstchar - 2) + RIGH
                 GOSUB WindowDoEditPrint
                 SELECT CASE cursor
                     CASE 0
                         firstchar = firstchar - 1
                         GOSUB WindowDoEditPrint
                     CASE 1
                         IF firstchar > 1 THEN
                             firstchar = firstchar - 1
                             GOSUB WindowDoEditPrint
                         ELSE
                             cursor = cursor - 1
                         END IF
                     CASE ELSE
                         cursor = cursor - 1
                 END SELECT
             END IF
         CASE CHR$(0) + "G"                         'Home
             firstchar = 1
             cursor = 0
             GOSUB WindowDoEditPrint
         CASE CHR$(0) + "O"                         'End
             IF LEN(editField$) >= visLength THEN
                 cursor = visLength - 1
                 firstchar = LEN(editField$) - visLength + 2
                 GOSUB WindowDoEditPrint
             ELSE
                 firstchar = 1
                 cursor = LEN(editField$)
             END IF
         CASE CHR$(0) + "u"                         'Ctrl+end
             editField$ = LEFT$(editField$, firstchar + cursor - 1)
             GOSUB WindowDoEditPrint
         CASE "menu"
             GloStorage.oldDialogEvent = 20         'Menu
             ExitFlag = TRUE

         CASE CHR$(32) TO CHR$(255)                 'Alphanumeric
             IF insertMode THEN
                 IF LEN(editField$) < maxLength THEN
                     editField$ = LEFT$(editField$, cursor + firstchar - 1) +
                     GOSUB WindowDoEditPrint
                     GOSUB WindowDoEditRight
                 ELSE
                     BEEP
                 END IF
             ELSE
                 IF cursor + firstchar > LEN(editField$) THEN
                     IF LEN(editField$) < maxLength THEN
                         editField$ = editField$ + kbd$
                         MouseHide
                         PRINT kbd$;
                         MouseShow
                     END IF
                 ELSE
                     MID$(editField$, cursor + firstchar, 1) = kbd$
                     MouseHide
                     PRINT kbd$;
                     MouseShow
                 END IF

                 GOSUB WindowDoEditRight
             END IF

     END SELECT
 RETURN

 ' ===========================================================================
 ' Moves the cursor right 1 space.  This is used twice, so it is its own
 ' routine
 ' ===========================================================================

 WindowDoEditRight:
     cursor = cursor + 1
     IF cursor + firstchar - 1 > LEN(editField$) THEN
         cursor = cursor - 1
     ELSEIF cursor + firstchar - 1 > maxLength THEN
         cursor = cursor - 1
     ELSEIF cursor = visLength THEN
         firstchar = firstchar + 1
         cursor = cursor - 1
         GOSUB WindowDoEditPrint
     END IF
 RETURN

 ' ===========================================================================
 ' Upon exit, store the current edit field string back into the global array
 ' ===========================================================================

 WindowDoEditExit:
     GloEdit(currEditField).text$ = editField$ + CHR$(0)
     LOCATE , , 0, 6, 7
 RETURN

 ' ===========================================================================
 ' Prints the edit field in the proper color, at the proper location
 ' ===========================================================================

 WindowDoEditPrint:
     MouseHide
     COLOR fore, back
     LOCATE row, col
     PRINT MID$(editField$ + SPACE$(visLength), firstchar, visLength);
     MouseShow
 RETURN

 END SUB

 SUB WindowInit

     ' =======================================================================
     ' Initialize totals
     ' =======================================================================

     GloStorage.currWindow = -1
     GloStorage.numWindowsOpen = 0
     GloStorage.numButtonsOpen = 0
     GloStorage.numEditFieldsOpen = 0

     ' =======================================================================
     ' Clear all windows
     ' =======================================================================

     FOR A = 1 TO MAXWINDOW
         GloWindow(A).handle = -1
         GloWindow(A).row1 = 0
         GloWindow(A).col1 = 0
         GloWindow(A).row2 = 0
         GloWindow(A).col2 = 0
         GloWindow(A).fore = 0
         GloWindow(A).back = 0
         GloWindow(A).windowType = 0
         GloWindow(A).title = ""
         GloWindowStack(A) = -1
     NEXT A

     ' =======================================================================
     ' Clear all buttons
     ' =======================================================================

     FOR A = 1 TO MAXBUTTON
         GloButton(A).handle = -1
         GloButton(A).windowHandle = -1
         GloButton(A).text = ""
         GloButton(A).state = 0
         GloButton(A).buttonOn = FALSE
         GloButton(A).row1 = 0
         GloButton(A).col1 = 0
         GloButton(A).row2 = 0
         GloButton(A).col2 = 0
         GloButton(A).buttonType = 0
     NEXT A

     ' =======================================================================
     ' Clear all edit fields
     ' =======================================================================

     FOR A = 1 TO MAXEDITFIELD
         GloEdit(A).handle = 0
         GloEdit(A).windowHandle = 0
         GloEdit(A).text = ""
         GloEdit(A).row = 0
         GloEdit(A).col = 0
         GloEdit(A).visLength = 0
         GloEdit(A).maxLength = 0
         GloEdit(A).fore = 0
         GloEdit(A).back = 0
     NEXT A

 END SUB

 SUB WindowLine (row)

     ' =======================================================================
     ' If window is valid, draw a horizontal line at the row which is passed
     ' =======================================================================

     windo = WindowCurrent

     IF windo > 0 THEN
         IF row >= 1 OR row <= WindowRows(windo) THEN

             topRow = GloWindow(windo).row1
             leftCol = GloWindow(windo).col1 - 1
             rightCol = GloWindow(windo).col2 + 1
             border$ = WindowBorder$(GloWindow(windo).windowType)

             LOCATE topRow + row - 1, leftCol
             MouseHide
             COLOR GloWindow(windo).fore, GloWindow(windo).back

             IF MID$(border$, 11, 1) = " " THEN
                 PRINT STRING$(rightCol - leftCol + 1, CHR$(196))
             ELSE
                 PRINT MID$(border$, 10, 1); STRING$(rightCol - leftCol - 1, M
             END IF

             MouseShow
         END IF
     END IF

 END SUB

 SUB WindowLocate (row, col)

     ' =======================================================================
     ' If window is valid, assign the passed row and col to the global variabl
     ' =======================================================================

     windo = WindowCurrent
     IF windo > 0 THEN
         GloWindow(windo).cursorRow = row
         GloWindow(windo).cursorCol = col
     END IF

 END SUB

 FUNCTION WindowNext

     ' =======================================================================
     ' Loop through window array, and find first unused window, return handle
     ' If no window found, return 0
     ' =======================================================================

     Found = FALSE
     A = 1
     WHILE A <= MAXWINDOW AND NOT Found
         IF GloWindow(A).handle = -1 THEN
             Found = TRUE
         ELSE
             A = A + 1
         END IF
     WEND

     IF Found THEN
         WindowNext = A
     ELSE
         WindowNext = 0
     END IF

 END FUNCTION

 SUB WindowOpen (handle, row1, col1, row2, col2, textFore, textBack, fore, bac

     ' =======================================================================
     ' Open Window!   First make sure coordinates are valid
     ' =======================================================================
     IF row1 > row2 THEN SWAP row1, row2
     IF col1 > col2 THEN SWAP col1, col2

     IF col1 >= MINCOL + 1 AND row1 >= MINROW + 1 AND col2 <= MAXCOL - 1 AND r

         ' ===================================================================
         ' Close window by save number if it already exists
         ' ===================================================================

         WindowClose handle

         ' ===================================================================
         ' Evaluate argument list to determine windowType
         ' ===================================================================

         IF movewin THEN windowType = 1
         IF closewin THEN windowType = windowType + 2
         IF sizewin THEN windowType = windowType + 4
         IF borderchar = 1 THEN windowType = windowType + 8
         IF borderchar = 2 THEN windowType = windowType + 16
         IF windowType = 0 THEN windowType = 99
         IF modalwin THEN windowType = -windowType

         border$ = WindowBorder(windowType)

         ' ===================================================================
         ' hide current window's shadow if it has one
         ' ===================================================================

         MouseHide
         IF GloStorage.numWindowsOpen > 0 THEN
             IF INSTR(WindowBorder$(GloWindow(GloWindowStack(GloStorage.numWin
                 WindowShadowRefresh
             END IF
         END IF

         ' ===================================================================
         ' Assign new values to window array
         ' ===================================================================

         GloWindow(handle).handle = handle
         GloWindow(handle).row1 = row1
         GloWindow(handle).col1 = col1
         GloWindow(handle).row2 = row2
         GloWindow(handle).col2 = col2
         GloWindow(handle).cursorRow = 1
         GloWindow(handle).cursorCol = 1
         GloWindow(handle).fore = fore
         GloWindow(handle).back = back
         GloWindow(handle).textFore = textFore
         GloWindow(handle).textBack = textBack
         GloWindow(handle).highlight = highlight
         GloWindow(handle).windowType = windowType
         GloWindow(handle).title = title$

         ' ===================================================================
         ' Save background, then draw window
         ' ===================================================================

         BackgroundSave handle
         Box row1 - 1, col1 - 1, row2 + 1, col2 + 1, fore, back, border$, 1
         MouseShow

         ' ===================================================================
         ' Assign handle to currWindow, incr total windows, push handle on sta
         ' ===================================================================

         GloStorage.currWindow = handle
         GloStorage.numWindowsOpen = GloStorage.numWindowsOpen + 1
         GloWindowStack(GloStorage.numWindowsOpen) = handle

         ' ===================================================================
         ' Print window title, and shadow
         ' ===================================================================

         WindowPrintTitle
         IF INSTR(border$, "S") THEN
             WindowShadowSave
         END IF
     END IF

 END SUB

 SUB WindowPrint (printMode, text$)

     ' =======================================================================
     ' If window is valid, print text$ using mode printMode%.  See
     ' External documentation for details on printMode%
     ' =======================================================================

     windo = WindowCurrent

     IF windo > 0 THEN
         SELECT CASE printMode

             ' ===============================================================
             ' Truncate printing
             ' ===============================================================

             CASE 1, -1
                 length = WindowCols(windo) - GloWindow(windo).cursorCol + 1
                 LOCATE GloWindow(windo).row1 + GloWindow(windo).cursorRow - 1
                 COLOR GloWindow(windo).textFore, GloWindow(windo).textBack
                 MouseHide
                 PRINT LEFT$(text$, length);
                 MouseShow
                 IF printMode < 0 THEN
                     GloWindow(windo).cursorCol = GloWindow(windo).cursorCol +
                     IF GloWindow(windo).cursorCol > WindowCols(windo) THEN
                         GloWindow(windo).cursorCol = WindowCols(windo) + 1
                     END IF
                 ELSE
                     GloWindow(windo).cursorRow = GloWindow(windo).cursorRow +
                     GloWindow(windo).cursorCol = 1
                     IF GloWindow(windo).cursorRow > WindowRows(windo) THEN
                         WindowScroll 1
                         GloWindow(windo).cursorRow = WindowRows(windo)
                     END IF
                 END IF
             ' ===============================================================
             ' Character wrapping
             ' ===============================================================

             CASE 2, -2
                 COLOR GloWindow(windo).textFore, GloWindow(windo).textBack
                 A$ = text$
                 WHILE LEN(A$) > 0
                     length = WindowCols(windo) - GloWindow(windo).cursorCol +
                     LOCATE GloWindow(windo).row1 + GloWindow(windo).cursorRow

                     MouseHide
                     PRINT LEFT$(A$, length);
                     MouseShow

                     IF length < LEN(A$) THEN
                         A$ = RIGHT$(A$, LEN(A$) - length)
                         GloWindow(windo).cursorRow = GloWindow(windo).cursorR
                         GloWindow(windo).cursorCol = 1
                         IF GloWindow(windo).cursorRow > WindowRows(windo) THE
                             WindowScroll 1
                             GloWindow(windo).cursorRow = WindowRows(windo)
                         END IF
                     ELSE
                         IF printMode < 0 THEN
                             GloWindow(windo).cursorCol = GloWindow(windo).cur
                             IF GloWindow(windo).cursorCol > WindowCols(windo)
                                 GloWindow(windo).cursorCol = WindowCols(windo
                             END IF
                         ELSE
                             GloWindow(windo).cursorRow = GloWindow(windo).cur
                             GloWindow(windo).cursorCol = GloWindow(windo).cur
                             IF GloWindow(windo).cursorRow > WindowRows(windo)
                                 WindowScroll 1
                                 GloWindow(windo).cursorRow = WindowRows(windo
                             END IF
                         END IF
                         A$ = ""
                     END IF
                 WEND

             ' ===============================================================
             ' Word wrapping
             ' ===============================================================

             CASE 3, -3
                 COLOR GloWindow(windo).textFore, GloWindow(windo).textBack
                 A$ = text$
                 WHILE LEN(A$) > 0
                     length = WindowCols(windo) - GloWindow(windo).cursorCol +
                     LOCATE GloWindow(windo).row1 + GloWindow(windo).cursorRow

                     IF length < LEN(A$) THEN
                         x = length + 1
                         b$ = " " + A$
                         WHILE MID$(b$, x, 1) <> " "
                             x = x - 1
                         WEND
                         x = x - 1

                         MouseHide
                         IF x = 0 THEN
                             PRINT LEFT$(A$, length);
                             A$ = RIGHT$(A$, LEN(A$) - length)
                         ELSE
                             PRINT LEFT$(A$, x);
                             A$ = RIGHT$(A$, LEN(A$) - x)
                         END IF
                         MouseShow

                         x = 1
                         b$ = A$ + " "
                         WHILE MID$(b$, x, 1) = " "
                             x = x + 1
                         WEND

                         IF x = LEN(b$) THEN
                             A$ = ""
                         ELSEIF x > 1 THEN
                             A$ = RIGHT$(A$, LEN(A$) - x + 1)
                         END IF

                         GloWindow(windo).cursorRow = GloWindow(windo).cursorR
                         GloWindow(windo).cursorCol = 1
                         IF GloWindow(windo).cursorRow > WindowRows(windo) THE
                             WindowScroll 1
                             GloWindow(windo).cursorRow = WindowRows(windo)
                         END IF
                     ELSE

                     MouseHide
                     PRINT LEFT$(A$, length);
                     MouseShow
                         IF printMode < 0 THEN
                             GloWindow(windo).cursorCol = GloWindow(windo).cur
                             IF GloWindow(windo).cursorCol > WindowCols(windo)
                                 GloWindow(windo).cursorCol = WindowCols(windo
                             END IF
                         ELSE
                             GloWindow(windo).cursorRow = GloWindow(windo).cur
                             GloWindow(windo).cursorCol = GloWindow(windo).cur
                             IF GloWindow(windo).cursorRow > WindowRows(windo)
                                 WindowScroll 1
                                 GloWindow(windo).cursorRow = WindowRows(windo
                             END IF
                         END IF
                         A$ = ""
                     END IF
                 WEND

             ' ===============================================================
             ' Centered text printing
             ' ===============================================================

             CASE 4
                 COLOR GloWindow(windo).textFore, GloWindow(windo).textBack
                 IF LEN(text$) >= WindowCols(windo) THEN
                     LOCATE GloWindow(windo).row1 + GloWindow(windo).cursorRow
                     MouseHide
                     PRINT LEFT$(text$, length);
                     MouseShow
                 ELSE
                     LOCATE GloWindow(windo).row1 + GloWindow(windo).cursorRow
                     MouseHide
                     PRINT text$
                     MouseShow
                 END IF

                 GloWindow(windo).cursorRow = GloWindow(windo).cursorRow + 1
                 GloWindow(windo).cursorCol = 1
                 IF GloWindow(windo).cursorRow > WindowRows(windo) THEN
                     WindowScroll 1
                     GloWindow(windo).cursorRow = WindowRows(windo)
                 END IF
         END SELECT
     END IF

 END SUB

 SUB WindowPrintTitle

     ' =======================================================================
     ' Print title of current window if the border$ says it's valid
     ' =======================================================================

     windo = WindowCurrent
     IF windo > 0 THEN

         title$ = GloWindow(windo).title
         border$ = WindowBorder$(GloWindow(windo).windowType)


         IF INSTR(border$, "T") THEN
             tx$ = RTRIM$(title$)
             IF LEN(tx$) > 0 THEN
                 COLOR GloWindow(windo).highlight, GloWindow(windo).back
                 MouseHide
                 length = WindowCols(windo)
                 IF (LEN(tx$) + 2) < length THEN
                     LOCATE GloWindow(windo).row1 - 1, GloWindow(windo).col1 +
                     PRINT " "; tx$; " ";
                 ELSE
                     LOCATE GloWindow(windo).row1 - 1, GloWindow(windo).col1
                     PRINT LEFT$(" " + tx$ + " ", (GloWindow(windo).col2 - Glo
                 END IF
                 MouseShow
             END IF
         END IF
     END IF

 END SUB

 SUB WindowRefresh (handle)

     ' =======================================================================
     ' Refresh the window -- used for window move, window resize, and
     ' WindowSetCurrent
     ' =======================================================================

     IF GloWindow(handle).handle > 0 THEN
         MouseHide
         PutBackground GloWindow(handle).row1 - 1, GloWindow(handle).col1 - 1,
         MouseShow
     END IF

 END SUB

 FUNCTION WindowRows (handle)

     ' =======================================================================
     ' Returns number of rows if handle is a valid window
     ' =======================================================================

     IF GloWindow(handle).handle > 0 THEN
         WindowRows = GloWindow(handle).row2 - GloWindow(handle).row1 + 1
     END IF

 END FUNCTION

 SUB WindowSave (handle)

     ' =======================================================================
     ' Saves the window handle%
     ' =======================================================================

     IF GloWindow(handle).handle > 0 THEN
         MouseHide
         GetBackground GloWindow(handle).row1 - 1, GloWindow(handle).col1 - 1,
         MouseShow
     END IF

 END SUB

 SUB WindowScroll (lines)

     ' =======================================================================
     ' Scroll just the window area.
     ' =======================================================================

     windo = WindowCurrent
     IF windo > 0 THEN
         MouseHide
         CALL Scroll(GloWindow(windo).row1, GloWindow(windo).col1, GloWindow(w
         MouseShow
     END IF

 END SUB

 SUB WindowSetCurrent (handle)

     ' =======================================================================
     ' If window is valid, and not already the current window
     ' =======================================================================

     IF GloWindow(handle).handle <> -1 AND handle <> WindowCurrent THEN

         ' ===================================================================
         ' If current window has a shadow, hide the shadow
         ' ===================================================================

         MouseHide
         IF INSTR(WindowBorder$(GloWindow(GloStorage.currWindow).windowType),
             WindowShadowRefresh
         END IF

         ' ===================================================================
         ' Save all windows on top of the one to be current, and refresh the
         ' background of each
         ' ===================================================================

         x = GloStorage.numWindowsOpen
         WHILE GloWindowStack(x) <> handle
             WindowSave GloWindowStack(x)
             BackgroundRefresh GloWindowStack(x)
             x = x - 1
         WEND

         ' ===================================================================
         ' Save the window to be made the current window
         ' ===================================================================

         WindowSave handle
         BackgroundRefresh handle

         ' ===================================================================
         ' Replace each window that was on top of handle, and squeeze stack
         ' ===================================================================

         IF handle <> GloWindowStack(GloStorage.numWindowsOpen) THEN
             FOR A = x + 1 TO GloStorage.numWindowsOpen
                 BackgroundSave GloWindowStack(A)
                 WindowRefresh GloWindowStack(A)
                 GloBuffer$(GloWindowStack(A), 2) = ""
                 GloWindowStack(A - 1) = GloWindowStack(A)
             NEXT A
         END IF

         ' ===================================================================
         ' Save new background of new current window.
         ' ===================================================================

         BackgroundSave handle
         WindowRefresh handle
         GloBuffer$(handle, 2) = ""
         MouseShow

         GloStorage.currWindow = handle
         GloWindowStack(GloStorage.numWindowsOpen) = handle

         ' ===================================================================
         ' Show shadow if current window has one
         ' ===================================================================

         IF INSTR(WindowBorder$(GloWindow(handle).windowType), "S") THEN
             WindowShadowSave
         END IF

     END IF

 END SUB

 SUB WindowShadowRefresh

     ' =======================================================================
     ' If window is current, replace what was under the shadow
     ' =======================================================================

     windo = WindowCurrent
     IF windo > 0 THEN
         row1 = GloWindow(windo).row1
         row2 = GloWindow(windo).row2
         col1 = GloWindow(windo).col1
         col2 = GloWindow(windo).col2

         ' ===================================================================
         ' If shadow partially (or fully) off screen, adjust coordinates
         ' ===================================================================

         MouseHide
         IF col1 <= MAXCOL - 2 THEN
             PutBackground row1, col2 + 2, GloBuffer$(MAXWINDOW + 1, 1)
         END IF
         IF row2 <= MAXROW - 2 THEN
             PutBackground row2 + 2, col1 + 1, GloBuffer$(MAXWINDOW + 1, 2)
         END IF
         MouseShow
     END IF

 END SUB

 SUB WindowShadowSave

     ' =======================================================================
     ' If current window valid, draw the shadow, storing what is underneath
     ' it first.
     ' =======================================================================

     windo = WindowCurrent

     IF windo > 0 THEN
         row1 = GloWindow(windo).row1
         row2 = GloWindow(windo).row2
         col1 = GloWindow(windo).col1
         col2 = GloWindow(windo).col2

         ' ===================================================================
         ' If shadow is partially, or fully off screen, adjust coordinates
         ' ===================================================================

         IF col2 > MAXCOL - 2 THEN
             shadowWidth = -1
         ELSEIF col2 = MAXCOL - 2 THEN
             shadowWidth = 0
         ELSE
             shadowWidth = 1
         END IF

         MouseHide

         ' ===================================================================
         ' Save background, the draw shadow
         ' ===================================================================

         IF col2 <= MAXCOL - 2 THEN
             GetBackground row1, col2 + 2, row2 + 1, col2 + 2 + shadowWidth, G
             AttrBox row1, col2 + 2, row2 + 1, col2 + 2 + shadowWidth, 8
         END IF

         IF row2 <= MAXROW - 2 THEN
             GetBackground row2 + 2, col1 + 1, row2 + 2, col2 + 2 + shadowWidt
             AttrBox row2 + 2, col1 + 1, row2 + 2, col2 + 2 + shadowWidth, 8
         END IF
         MouseShow
     END IF

 END SUB

 Microsoft Quick-BASIC Sample Code


 ABSOLUTE.ASM
 CD-ROM Disc Path:   \SAMPCODE\QB\ABSOLUTE.ASM

         TITLE   ABSOLUTE - helper for assembly routines
 ;***
 ; ABSOLUTE - Helper for calling BASIC interpreter assembly routines
 ;
 ;       Copyright <C> 1986, Microsoft Corporation
 ;
 ;Purpose:
 ; Allow a BASIC program to call a routine which is located at an
 ; absolute memory address in the DEF SEG.
 ;
 ; The form of the call is:
 ;
 ;       CALL ABSOLUTE(<param>,...,<loc>)
 ;
 ; where
 ;       <param>,...   -  zero or more parameters for the assembly routine
 ;       <loc>         -  an Integer variable that contains the
 ;                        location in the DEF SEG of the start of
 ;                        the assembly routine
 ;
 ; The location parameter will be removed, and the routine at DEF SEG:<loc>
 ; will be called with the remaining parameters.
 ;
 ; Notes:
 ;       - The parameters are not checked or verified before being passed
 ;         to the assembly routine.
 ;       - CALL must be used.  CALLS will cause execution to jump to a
 ;         random location.
 ;       - The DOSSEG, .MODEL, .CODE, and .DATA? directives are part of
 ;         the simplified segment system of MASM 5.0. If you have an
 ;         earlier version of MASM, you must modify the source to define
 ;         the segments required by Microsoft high-level languages. These
 ;         segments are discussed in Appendix C of "Learning and Using
 ;         QuickBASIC."
 ;
 ;****************************************************************************
 ;
         DOSSEG                ;requires MASM 5.0 or higher
         .MODEL  medium

 ;       Define the routine as public.

         PUBLIC  ABSOLUTE

 ;       Define the seg segment

         .DATA?

         EXTRN  b$seg:WORD     ;seg segment

 ;***
 ; ABSOLUTE - Call absolute address
 ;
 ;Purpose:
 ; Routine which can be directly called from the basic level which in turn
 ; calls an absolute address.
 ;
 ;Entry:
 ; The actual number of parameters is variable, and depends on the routine
 ; that ABSOLUTE will in turn call. The LAST parameter pushed MUST be the DS
 ; offset of an integer variable containing the offset of the routine to be
 ; called. The current DEF SEG is used as the segment for the call.
 ;
 ;Exit:
 ; Whatever the called routine elects. We do NOT return here.
 ;
 ;Uses:
 ; This routine follows convention, but does no saving or checking of the code
 ; actually called.
 ;
 ;Notes:
 ; The called routine receives control with all parameters passed to ABSOLUTE,
 ; except the offset integer, on the stack in Pascal convention. The return
 ; address present is back to the BASIC level code which CALLed ABSOLUTE.
 ;
 ; Stack on call to ABSOLUTE:
 ;
 ;
 ;               \       Variable number of parameters           \
 ;               |          to routine to be CALLed              |
 ;               +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
 ;               |       Near pointer to I2 var containing       |
 ;               |       the offset of the routine to CALL       |
 ;               +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
 ;               |CS                                             |
 ;               +    Far return address to caller of ABSOLUTE   +
 ;       [SP] -> |IP                                             |
 ;               +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
 ;
 ; Stack on transfer to called routine:
 ;
 ;               \       Variable number of parameters           \
 ;               |          to routine to be CALLed              |
 ;               +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
 ;               |CS                                             |
 ;               +    Far return address to caller of ABSOLUTE   +
 ;       [SP] -> |IP                                             |
 ;               +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
 ;
 ;****************************************************************************

         .CODE

 ABSOLUTE PROC FAR

         POP     AX              ;return offset
         POP     DX              ;return segment
         POP     BX              ;get pointer to routine address
         PUSH    DX              ;restore return address
         PUSH    AX
         PUSH    [b$seg]         ;stack DEF SEG segment
         PUSH    [BX]            ;stack routine offset

         RET                     ;jump to ABSOLUTE routine

 ABSOLUTE ENDP

         END


 ATTRIB.BAS
 CD-ROM Disc Path:   \SAMPCODE\QB\TOOLBOX\DISK1\ATTRIB.BAS

   ' ************************************************
   ' **  Name:          ATTRIB                     **
   ' **  Type:          Program                    **
   ' **  Module:        ATTRIB.BAS                 **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Displays all combinations of text mode character
   ' attributes on the screen for review.
   '
   ' USAGE:           No command line parameters
   ' REQUIREMENTS:    CGA
   ' .MAK FILE:       (none)
   ' FUNCTIONS:       (none)
   ' PARAMETERS:      (none)
   ' VARIABLES:       (none)

     DECLARE SUB Attrib ()

   ' Call the subprogram
     Attrib

   ' All done
     END

   ' ************************************************
   ' **  Name:          Attrib                     **
   ' **  Type:          Subprogram                 **
   ' **  Module:        ATTRIB.BAS                 **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Displays table of color attributes for text mode.
   '
   ' EXAMPLE OF USE:  Attrib
   ' PARAMETERS:      (none)
   ' VARIABLES:       bgd%        Background number for COLOR statement
   '                  fgd%        Foreground number for COLOR statement
   ' MODULE LEVEL
   '   DECLARATIONS:              DECLARE SUB Attrib ()
   '
     SUB Attrib STATIC
         SCREEN 0
         CLS
         PRINT "Attributes for the COLOR statement in text mode (SCREEN 0)."
         PRINT "Add 16 to the foreground to cause the character to blink."
         FOR bgd% = 0 TO 7
             COLOR bgd% XOR 7, bgd%
             PRINT
             PRINT "Background%"; STR$(bgd%),
             PRINT "Foreground% ..."; SPACE$(41)
             FOR fgd% = 0 TO 15
                 COLOR fgd%, bgd%
                 PRINT STR$(fgd%); "  ";
             NEXT fgd%
         NEXT bgd%
         COLOR 7, 0
         PRINT
     END SUB



 BALLPSET.BAS
 CD-ROM Disc Path:   \SAMPCODE\QB\SRCDISK\BALLPSET.BAS

 DECLARE FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom)

 SCREEN 2
 CLS

 ' Define a viewport and draw a border around it:
 VIEW (20, 10)-(620, 190), , 1

 CONST PI = 3.141592653589#

 ' Redefine the coordinates of the viewport with logical
 ' coordinates:
 WINDOW (-3.15, -.14)-(3.56, 1.01)

 ' Arrays in program are now dynamic:
 ' $DYNAMIC

 ' Calculate the logical coordinates for the top and bottom of a
 ' rectangle large enough to hold the image that will be drawn
 ' with CIRCLE and PAINT:
 WLeft = -.21
 WRight = .21
 WTop = .07
 WBottom = -.07

 ' Call the GetArraySize function, passing it the rectangle's
 ' logical coordinates:
 ArraySize% = GetArraySize(WLeft, WRight, WTop, WBottom)

 DIM Array(1 TO ArraySize%) AS INTEGER

 ' Draw and paint the circle:
 CIRCLE (0, 0), .18
 PAINT (0, 0)

 ' Store the rectangle in Array:
 GET (WLeft, WTop)-(WRight, WBottom), Array
 CLS

 ' Draw a box and fill it with a pattern:
 LINE (-3, .8)-(3.4, .2), , B
 Pattern$ = CHR$(126) + CHR$(0) + CHR$(126) + CHR$(126)
 PAINT (0, .5), Pattern$

 LOCATE 21, 29
 PRINT "Press any key to end"

 ' Initialize loop variables:
 StepSize = .02
 StartLoop = -PI
 Decay = 1

 DO
    EndLoop = -StartLoop
    FOR X = StartLoop TO EndLoop STEP StepSize

       ' Each time the ball "bounces" (hits the bottom of the
       ' viewport), the Decay variable gets smaller, making the
       ' height of the next bounce smaller:
       Y = ABS(COS(X)) * Decay - .14
       IF Y < -.13 THEN Decay = Decay * .9

       ' Stop if a key pressed or if Decay is less than .01:
       Esc$ = INKEY$
       IF Esc$ <> "" OR Decay < .01 THEN EXIT FOR

       ' Put the image on the screen.  The StepSize offset is
       ' smaller than the border around the circle, so each time
       ' the image moves, it erases any traces left from the
       ' previous PUT (it also erases anything else on the
       ' screen):
       PUT (X, Y), Array, PSET
    NEXT X

    ' Reverse direction:
    StepSize = -StepSize
    StartLoop = -StartLoop
 LOOP UNTIL Esc$ <> "" OR Decay < .01

 Pause$ = INPUT$(1)
 END
 REM $STATIC
 REM $DYNAMIC
 FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) STATIC

    ' Map the logical coordinates passed to this function to
    ' their physical-coordinate equivalents:
    VLeft = PMAP(WLeft, 0)
    VRight = PMAP(WRight, 0)
    VTop = PMAP(WTop, 1)
    VBottom = PMAP(WBottom, 1)

    ' Calculate the height and width in pixels of the
    ' enclosing rectangle:
    RectHeight = ABS(VBottom - VTop) + 1
    RectWidth = ABS(VRight - VLeft) + 1

    ' Calculate size in bytes of array:
    ByteSize = 4 + RectHeight * INT((RectWidth + 7) / 8)

    ' Array is integer, so divide bytes by two:
    GetArraySize = ByteSize \ 2 + 1
 END FUNCTION


 BALLXOR.BAS
 CD-ROM Disc Path:   \SAMPCODE\QB\SRCDISK\BALLXOR.BAS

 DECLARE FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom)

 SCREEN 2
 CLS
 VIEW (20, 10)-(620, 190), , 1

 CONST PI = 3.141592653589#

 WINDOW (-3.15, -.14)-(3.56, 1.01)

 ' $DYNAMIC
 ' The rectangle is smaller than the one in the previous
 ' program, which means Array is also smaller:
 WLeft = -.18
 WRight = .18
 WTop = .05
 WBottom = -.05

 ArraySize% = GetArraySize(WLeft, WRight, WTop, WBottom)

 DIM Array(1 TO ArraySize%) AS INTEGER

 CIRCLE (0, 0), .18
 PAINT (0, 0)

 GET (WLeft, WTop)-(WRight, WBottom), Array
 CLS

 LINE (-3, .8)-(3.4, .2), , B
 Pattern$ = CHR$(126) + CHR$(0) + CHR$(126) + CHR$(126)
 PAINT (0, .5), Pattern$

 LOCATE 21, 29
 PRINT "Press any key to end"

 StepSize = .02
 StartLoop = -PI
 Decay = 1

 DO
    EndLoop = -StartLoop
    FOR X = StartLoop TO EndLoop STEP StepSize
       Y = ABS(COS(X)) * Decay - .14

       ' The first PUT statement places the image on
       ' the screen:
       PUT (X, Y), Array, XOR

       ' An empty FOR...NEXT loop to delay the program and
       ' reduce image flicker:
       FOR I = 1 TO 5: NEXT I

       IF Y < -.13 THEN Decay = Decay * .9
       Esc$ = INKEY$
       IF Esc$ <> "" OR Decay < .01 THEN EXIT FOR

       ' The second PUT statement erases the image and
       ' restores the background:
       PUT (X, Y), Array, XOR
    NEXT X

    StepSize = -StepSize
    StartLoop = -StartLoop
 LOOP UNTIL Esc$ <> "" OR Decay < .01

 Pause$ = INPUT$(1)
 END
 REM $STATIC
 REM $DYNAMIC
 FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) STATIC
    VLeft = PMAP(WLeft, 0)
    VRight = PMAP(WRight, 0)
    VTop = PMAP(WTop, 1)
    VBottom = PMAP(WBottom, 1)

    RectHeight = ABS(VBottom - VTop) + 1
    RectWidth = ABS(VRight - VLeft) + 1

    ByteSize = 4 + RectHeight * INT((RectWidth + 7) / 8)
    GetArraySize = ByteSize \ 2 + 1
 END FUNCTION


 BAR.BAS
 CD-ROM Disc Path:   \SAMPCODE\QB\SRCDISK\BAR.BAS

 ' Define type for the titles:
 TYPE TitleType
    MainTitle AS STRING * 40
    XTitle AS STRING * 40
    YTitle AS STRING * 18
 END TYPE

 DECLARE SUB InputTitles (T AS TitleType)
 DECLARE FUNCTION DrawGraph$ (T AS TitleType, Label$(), Value!(), N%)
 DECLARE FUNCTION InputData% (Label$(), Value!())

 ' Variable declarations for titles and bar data:
 DIM Titles AS TitleType, Label$(1 TO 5), Value(1 TO 5)

 CONST FALSE = 0, TRUE = NOT FALSE

 DO
    InputTitles Titles
    N% = InputData%(Label$(), Value())
    IF N% <> FALSE THEN
       NewGraph$ = DrawGraph$(Titles, Label$(), Value(), N%)
    END IF
 LOOP WHILE NewGraph$ = "Y"

 END
 REM $STATIC
 '
 ' ========================== DRAWGRAPH =========================
 '   Draws a bar graph from the data entered in the INPUTTITLES
 '   and INPUTDATA procedures.
 ' ==============================================================
 '
 FUNCTION DrawGraph$ (T AS TitleType, Label$(), Value(), N%) STATIC

    ' Set size of graph:
    CONST GRAPHTOP = 24, GRAPHBOTTOM = 171
    CONST GRAPHLEFT = 48, GRAPHRIGHT = 624
    CONST YLENGTH = GRAPHBOTTOM - GRAPHTOP

    ' Calculate max/min values:
    YMax = 0
    YMin = 0
    FOR I% = 1 TO N%
       IF Value(I%) < YMin THEN YMin = Value(I%)
       IF Value(I%) > YMax THEN YMax = Value(I%)
    NEXT I%

    ' Calculate width of bars and space between them:
    BarWidth = (GRAPHRIGHT - GRAPHLEFT) / N%
    BarSpace = .2 * BarWidth
    BarWidth = BarWidth - BarSpace

    SCREEN 2
    CLS

    ' Draw y axis:
    LINE (GRAPHLEFT, GRAPHTOP)-(GRAPHLEFT, GRAPHBOTTOM), 1

    ' Draw main graph title:
    Start% = 44 - (LEN(RTRIM$(T.MainTitle)) / 2)
    LOCATE 2, Start%
    PRINT RTRIM$(T.MainTitle);

    ' Annotate Y axis:
    Start% = CINT(13 - LEN(RTRIM$(T.YTitle)) / 2)
    FOR I% = 1 TO LEN(RTRIM$(T.YTitle))
       LOCATE Start% + I% - 1, 1
       PRINT MID$(T.YTitle, I%, 1);
    NEXT I%

    ' Calculate scale factor so labels aren't bigger than 4 digits:
    IF ABS(YMax) > ABS(YMin) THEN
       Power = YMax
    ELSE
       Power = YMin
    END IF
    Power = CINT(LOG(ABS(Power) / 100) / LOG(10))
    IF Power < 0 THEN Power = 0

    ' Scale min and max down:
    ScaleFactor = 10 ^ Power
    YMax = CINT(YMax / ScaleFactor)
    YMin = CINT(YMin / ScaleFactor)

    ' If power isn't zero then put scale factor on chart:
    IF Power <> 0 THEN
       LOCATE 3, 2
       PRINT "x 10^"; LTRIM$(STR$(Power))
    END IF

    ' Put tic mark and number for Max point on Y axis:
    LINE (GRAPHLEFT - 3, GRAPHTOP)-STEP(3, 0)
    LOCATE 4, 2
    PRINT USING "####"; YMax

    ' Put tic mark and number for Min point on Y axis:
    LINE (GRAPHLEFT - 3, GRAPHBOTTOM)-STEP(3, 0)
    LOCATE 22, 2
    PRINT USING "####"; YMin

    ' Scale min and max back up for charting calculations:
    YMax = YMax * ScaleFactor
    YMin = YMin * ScaleFactor

    ' Annotate X axis:
    Start% = 44 - (LEN(RTRIM$(T.XTitle)) / 2)
    LOCATE 25, Start%
    PRINT RTRIM$(T.XTitle);

    ' Calculate the pixel range for the Y axis:
    YRange = YMax - YMin

    ' Define a diagonally striped pattern:
    Tile$ = CHR$(1) + CHR$(2) + CHR$(4) + CHR$(8) + CHR$(16) + CHR$(32) + CHR$

    ' Draw a zero line if appropriate:
    IF YMin < 0 THEN
       Bottom = GRAPHBOTTOM - ((-YMin) / YRange * YLENGTH)
       LOCATE INT((Bottom - 1) / 8) + 1, 5
       PRINT "0";
    ELSE
       Bottom = GRAPHBOTTOM
    END IF

    ' Draw x axis:
    LINE (GRAPHLEFT - 3, Bottom)-(GRAPHRIGHT, Bottom)

    ' Draw bars and labels:
    Start% = GRAPHLEFT + (BarSpace / 2)
    FOR I% = 1 TO N%

       ' Draw a bar label:
       BarMid = Start% + (BarWidth / 2)
       CharMid = INT((BarMid - 1) / 8) + 1
       LOCATE 23, CharMid - INT(LEN(RTRIM$(Label$(I%))) / 2)
       PRINT Label$(I%);

       ' Draw the bar and fill it with the striped pattern:
       BarHeight = (Value(I%) / YRange) * YLENGTH
       LINE (Start%, Bottom)-STEP(BarWidth, -BarHeight), , B
       PAINT (BarMid, Bottom - (BarHeight / 2)), Tile$, 1

       Start% = Start% + BarWidth + BarSpace
    NEXT I%

    LOCATE 1, 1, 1
    PRINT "New graph? ";
    DrawGraph$ = UCASE$(INPUT$(1))

 END FUNCTION
 '
 ' ========================= INPUTDATA ========================
 '         Gets input for the bar labels and their values
 ' ============================================================
 '
 FUNCTION InputData% (Label$(), Value()) STATIC

    ' Initialize the number of data values:
    NumData% = 0

    ' Print data-entry instructions:
    CLS
    PRINT "Enter data for up to 5 bars:"
    PRINT "   * Enter the label and value for each bar."
    PRINT "   * Values can be negative."
    PRINT "   * Enter a blank label to stop."
    PRINT
    PRINT "After viewing the graph, press any key ";
    PRINT "to end the program."

    ' Accept data until blank label or 5 entries:
    Done% = FALSE
    DO
       NumData% = NumData% + 1
       PRINT
       PRINT "Bar("; LTRIM$(STR$(NumData%)); "):"
       INPUT ; "        Label? ", Label$(NumData%)

       ' Only input value if label isn't blank:
       IF Label$(NumData%) <> "" THEN
          LOCATE , 35
          INPUT "Value? ", Value(NumData%)

       ' If label was blank, decrement data counter and
       ' set Done flag equal to TRUE:
       ELSE
          NumData% = NumData% - 1
          Done% = TRUE
       END IF
    LOOP UNTIL (NumData% = 5) OR Done%

    ' Return the number of data values input:
    InputData% = NumData%

 END FUNCTION
 '
 ' ======================= INPUTTITLES ========================
 '       Accepts input for the three different graph titles
 ' ============================================================
 '
 SUB InputTitles (T AS TitleType) STATIC

    ' Set text screen:
    SCREEN 0, 0

    ' Input Titles
    DO
       CLS
       INPUT "Enter main graph title: ", T.MainTitle
       INPUT "Enter X-Axis title    : ", T.XTitle
       INPUT "Enter Y-Axis title    : ", T.YTitle

       ' Check to see if titles are OK:
       LOCATE 7, 1
       PRINT "OK (Y to continue, N to change)? ";
       LOCATE , , 1
       OK$ = UCASE$(INPUT$(1))
    LOOP UNTIL OK$ = "Y"
 END SUB


 BIN2HEX.BAS
 CD-ROM Disc Path:   \SAMPCODE\QB\TOOLBOX\DISK1\BIN2HEX.BAS

   ' ************************************************
   ' **  Name:          BIN2HEX                    **
   ' **  Type:          Program                    **
   ' **  Module:        BIN2HEX.BAS                **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Reads in any file and writes out a hexadecimal format file
   ' suitable for rebuilding the original file using the HEX2BIN
   ' program.
   '
   ' USAGE:          BIN2HEX inFileName.ext outFileName.ext
   ' .MAK FILE:      BIN2HEX.BAS
   '                 PARSE.BAS
   ' PARAMETERS:     inFileName    Name of file to be duplicated in hexadecima
   '                               format
   '                 outFileName   Name of hexadecimal format file to be creat
   ' VARIABLES:      cmd$          Working copy of the command line
   '                 inFile$       Name of input file
   '                 outFile$      Name of output file
   '                 byte$         Buffer for binary file access
   '                 i&            Index to each byte of input file
   '                 h$            Pair of hexadecimal characters representing
   '                               each byte


     DECLARE SUB ParseWord (a$, sep$, word$)

   ' Initialization
     CLS
     PRINT "BIN2HEX "; COMMAND$
     PRINT

   ' Get the input and output filenames from the command line
     cmd$ = COMMAND$
     ParseWord cmd$, " ,", inFile$
     ParseWord cmd$, " ,", outFile$

   ' Verify that both filenames were given
     IF outFile$ = "" THEN
         PRINT
         PRINT "Usage: BIN2HEX inFileName outFileName"
         SYSTEM
     END IF

   ' Open the input file
     OPEN inFile$ FOR BINARY AS #1 LEN = 1
     IF LOF(1) = 0 THEN
         CLOSE #1
         KILL inFile$
         PRINT
         PRINT "File not found - "; inFile$
         SYSTEM
     END IF

   ' Open the output file
     OPEN outFile$ FOR OUTPUT AS #2

   ' Process each byte of the file
     byte$ = SPACE$(1)
     FOR i& = 1 TO LOF(1)
         GET #1, , byte$
         h$ = RIGHT$("0" + HEX$(ASC(byte$)), 2)
         PRINT #2, h$; SPACE$(1);
         IF i& = LOF(1) THEN
             PRINT #2, ""
         ELSEIF i& MOD 16 = 0 THEN
             PRINT #2, ""
         ELSEIF i& MOD 8 = 0 THEN
             PRINT #2, "- ";
         END IF
     NEXT i&

   ' Clean up and quit
     CLOSE
     END




 BIOSCALL.BAS
 CD-ROM Disc Path:   \SAMPCODE\QB\TOOLBOX\DISK1\BIOSCALL.BAS

   ' ************************************************
   ' **  Name:          BIOSCALL                   **
   ' **  Type:          Toolbox                    **
   ' **  Module:        BIOSCALL.BAS               **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Demonstrates several interrupt calls to the ROM BIOS.
   '
   ' USAGE: No command line parameters
   ' REQUIREMENTS:    MIXED.QLB/.LIB
   ' .MAK FILE:       (none)
   ' PARAMETERS:      (none)
   ' VARIABLES:       i%         Loop index for creating lines to scroll
   '                  equip      Structure of type EquipmentType
   '                  mode%      Video mode returned by VideoState
   '                  columns%   Video columns returned by VideoState
   '                  page%      Video page returned by VideoState
   '                  shift      Structure of type ShiftType


   ' Constants
     CONST FALSE = 0
     CONST TRUE = NOT FALSE

   ' Declare the Type structures
     TYPE RegType
         ax    AS INTEGER
         bx    AS INTEGER
         cx    AS INTEGER
         dx    AS INTEGER
         Bp    AS INTEGER
         si    AS INTEGER
         di    AS INTEGER
         flags AS INTEGER
     END TYPE

     TYPE RegTypeX
         ax    AS INTEGER
         bx    AS INTEGER
         cx    AS INTEGER
         dx    AS INTEGER
         Bp    AS INTEGER
         si    AS INTEGER
         di    AS INTEGER
         flags AS INTEGER
         ds    AS INTEGER
         es    AS INTEGER
     END TYPE

     TYPE EquipmentType
         printers     AS INTEGER
         gameAdapter  AS INTEGER
         serial       AS INTEGER
         floppies     AS INTEGER
         initialVideo AS INTEGER
         coprocessor  AS INTEGER
     END TYPE

     TYPE ShiftType
         right           AS INTEGER
         left            AS INTEGER
         ctrl            AS INTEGER
         alt             AS INTEGER
         scrollLockState AS INTEGER
         numLockState    AS INTEGER
         capsLockState   AS INTEGER
         insertState     AS INTEGER
     END TYPE

     DECLARE SUB Interrupt (intnum%, inreg AS RegType, outreg AS RegType)
     DECLARE SUB InterruptX (intnum%, inreg AS RegTypeX, outreg AS RegTypeX)
     DECLARE SUB PrintScreen ()
     DECLARE SUB Scroll (row1%, col1%, row2%, col2%, lines%, attribute%)
     DECLARE SUB Equipment (equip AS EquipmentType)
     DECLARE SUB VideoState (mode%, columns%, page%)
     DECLARE SUB GetShiftStates (shift AS ShiftType)
     DECLARE SUB ReBoot ()

   ' Demonstrate the Scroll subprogram
     CLS
     FOR i% = 1 TO 15
         COLOR i%, i% - 1
         PRINT STRING$(25, i% + 64)
     NEXT i%
     COLOR 7, 0
     PRINT
     PRINT "Press <Enter> to scroll part of the screen"
     DO
     LOOP UNTIL INKEY$ = CHR$(13)
     Scroll 2, 3, 6, 16, 3, SCREEN(2, 3, 1)

   ' Wait for user before continuing
     PRINT
     PRINT "Press any key to continue"
     DO
     LOOP UNTIL INKEY$ <> ""
     CLS

   ' Determine the equipment information
     DIM equip AS EquipmentType
     Equipment equip
     PRINT "Printers:", equip.printers
     PRINT "Game adapter:", equip.gameAdapter
     PRINT "Serial IO:", equip.serial
     PRINT "Floppies:", equip.floppies
     PRINT "Video:", equip.initialVideo
     PRINT "Coprocessor:", equip.coprocessor

   ' Determine the current video state
     PRINT
     VideoState mode%, columns%, page%
     PRINT "Video mode:", mode%
     PRINT "Text columns:", columns%
     PRINT "Video page:", page%

   ' Wait for user before continuing
     PRINT
     PRINT "Press any key to continue"
     DO
     LOOP UNTIL INKEY$ <> ""

   ' Demonstrate the shift key states
     CLS
     PRINT "(Press shift keys, then <Enter> to continue...)"
     DIM shift AS ShiftType
     DO
         LOCATE 4, 1
         PRINT "Shift states:"
         GetShiftStates shift
         PRINT
         PRINT "Left shift:", shift.left
         PRINT "Right shift:", shift.right
         PRINT "Ctrl:", shift.ctrl
         PRINT "Alt:", shift.alt
         PRINT "Scroll Lock:", shift.scrollLockState
         PRINT "Num Lock:", shift.numLockState
         PRINT "Caps Lock:", shift.capsLockState
         PRINT "Insert:", shift.insertState
     LOOP UNTIL INKEY$ = CHR$(13)

   ' Uncomment the following line to cause a screen dump to printer....
   ' PrintScreen

   ' Uncomment the following line only if you want to reboot....
   ' ReBoot

     END


   ' ************************************************
   ' **  Name:          Equipment                  **
   ' **  Type:          Subprogram                 **
   ' **  Module:        BIOSCALL.BAS               **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Returns equipment configuration information from BIOS.
   '
   ' EXAMPLE OF USE:  Equipment equip
   ' PARAMETERS:      equip      Structure of type EquipmentType
   ' VARIABLES:       reg        Structure of type RegType
   ' MODULE LEVEL
   '   DECLARATIONS:  TYPE RegType
   '                     ax    AS INTEGER
   '                     bx    AS INTEGER
   '                     cx    AS INTEGER
   '                     dx    AS INTEGER
   '                     Bp    AS INTEGER
   '                     si    AS INTEGER
   '                     di    AS INTEGER
   '                     flags AS INTEGER
   '                  END TYPE
   '
   '                  TYPE EquipmentType
   '                     printers     AS INTEGER
   '                     gameAdapter  AS INTEGER
   '                     serial       AS INTEGER
   '                     floppies     AS INTEGER
   '                     initialVideo AS INTEGER
   '                     coprocessor  AS INTEGER
   '                  END TYPE
   '
   '     DECLARE SUB Interrupt (intnum%, inreg AS RegType, outreg AS RegType)
   '     DECLARE SUB Equipment (equip AS EquipmentType)
   '
     SUB Equipment (equip AS EquipmentType) STATIC
         DIM reg AS RegType
         Interrupt &H11, reg, reg
         equip.printers = (reg.ax AND &HC000&) \ 16384
         equip.gameAdapter = (reg.ax AND &H1000) \ 4096
         equip.serial = (reg.ax AND &HE00) \ 512
         equip.floppies = (reg.ax AND &HC0) \ 64 + 1
         equip.initialVideo = (reg.ax AND &H30) \ 16
         equip.coprocessor = (reg.ax AND 2) \ 2
     END SUB

   ' ************************************************
   ' **  Name:          GetShiftStates             **
   ' **  Type:          Subprogram                 **
   ' **  Module:        BIOSCALL.BAS               **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Return state of the various shift keys.
   '
   ' EXAMPLE OF USE:  GetShiftStates shift
   ' PARAMETERS:      shift      Structure of type ShiftType
   ' VARIABLES:       reg        Structure of type RegType
   ' MODULE LEVEL
   '   DECLARATIONS:  TYPE RegType
   '                     ax    AS INTEGER
   '                     bx    AS INTEGER
   '                     cx    AS INTEGER
   '                     dx    AS INTEGER
   '                     Bp    AS INTEGER
   '                     si    AS INTEGER
   '                     di    AS INTEGER
   '                     flags AS INTEGER
   '                  END TYPE
   '
   '                  TYPE ShiftType
   '                     right           AS INTEGER
   '                     left            AS INTEGER
   '                     ctrl            AS INTEGER
   '                     alt             AS INTEGER
   '                     scrollLockState AS INTEGER
   '                     numLockState    AS INTEGER
   '                     capsLockState   AS INTEGER
   '                     insertState     AS INTEGER
   '                  END TYPE
   '
   '      DECLARE SUB Interrupt (intnum%, inreg AS RegType, outreg AS RegType)
   '      DECLARE SUB GetShiftStates (shift AS ShiftType)
   '
     SUB GetShiftStates (shift AS ShiftType) STATIC
         DIM reg AS RegType
         reg.ax = &H200
         Interrupt &H16, reg, reg
         shift.right = reg.ax AND 1
         shift.left = (reg.ax AND 2) \ 2
         shift.ctrl = (reg.ax AND 4) \ 4
         shift.alt = (reg.ax AND 8) \ 8
         shift.scrollLockState = (reg.ax AND 16) \ 16
         shift.numLockState = (reg.ax AND 32) \ 32
         shift.capsLockState = (reg.ax AND 64) \ 64
         shift.insertState = (reg.ax AND 128) \ 128
     END SUB

   ' ************************************************
   ' **  Name:          PrintScreen                **
   ' **  Type:          Subprogram                 **
   ' **  Module:        BIOSCALL.BAS               **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Activates interrupt 5 to cause a dump of the
   ' screen's contents to the printer.
   '
   ' EXAMPLE OF USE:  PrintScreen
   ' PARAMETERS:      (none)
   ' VARIABLES:       reg        Structure of type RegType
   ' MODULE LEVEL
   '   DECLARATIONS:  TYPE RegType
   '                     ax    AS INTEGER
   '                     bx    AS INTEGER
   '                     cx    AS INTEGER
   '                     dx    AS INTEGER
   '                     Bp    AS INTEGER
   '                     si    AS INTEGER
   '                     di    AS INTEGER
   '                     flags AS INTEGER
   '                  END TYPE
   '
   '      DECLARE SUB Interrupt (intnum%, inreg AS RegType, outreg AS RegType)
   '      DECLARE SUB PrintScreen ()
   '
     SUB PrintScreen STATIC
         DIM reg AS RegType
         Interrupt 5, reg, reg
     END SUB

   ' ************************************************
   ' **  Name:          ReBoot                     **
   ' **  Type:          Subprogram                 **
   ' **  Module:        BIOSCALL.BAS               **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Causes the computer to reboot.
   '
   ' EXAMPLE OF USE:  ReBoot
   ' PARAMETERS:      (none)
   ' VARIABLES:       reg        Structure of type RegType
   ' MODULE LEVEL
   '   DECLARATIONS:  TYPE RegType
   '                     ax    AS INTEGER
   '                     bx    AS INTEGER
   '                     cx    AS INTEGER
   '                     dx    AS INTEGER
   '                     Bp    AS INTEGER
   '                     si    AS INTEGER
   '                     di    AS INTEGER
   '                     flags AS INTEGER
   '                  END TYPE
   '
   '      DECLARE SUB Interrupt (intnum%, inreg AS RegType, outreg AS RegType)
   '      DECLARE SUB ReBoot ()
   '
     SUB ReBoot STATIC
         DIM reg AS RegType
         Interrupt &H19, reg, reg
     END SUB

   ' ************************************************
   ' **  Name:          Scroll                     **
   ' **  Type:          Subprogram                 **
   ' **  Module:        BIOSCALL.BAS               **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Scrolls the screen in the rectangular area defined
   ' by the row and col parameters.  Positive line count
   ' moves the lines up, leaving blank lines at bottom;
   ' negative line count moves the lines down.
   '
   ' EXAMPLE OF USE:  Scroll row1%, col1%, row2%, col2%, lines%, attr%
   ' PARAMETERS:      row1%    Upper left character row defining rectangular
   '                           scroll area
   '                  col1     Upper left character column defining rectangula
   '                           scroll area
   '                  row2%    Lower right character row defining rectangular
   '                           scroll area
   '                  col2%    Lower right character column defining
   '                           rectangular scroll area
   '                  lines%   Number of character lines to scroll
   '                  attr%    Color attribute byte to be used in new text
   '                           lines scrolled onto the screen
   ' VARIABLES:       reg      Structure of type RegType
   ' MODULE LEVEL
   '   DECLARATIONS:  TYPE RegType
   '                     ax    AS INTEGER
   '                     bx    AS INTEGER
   '                     cx    AS INTEGER
   '                     dx    AS INTEGER
   '                     Bp    AS INTEGER
   '                     si    AS INTEGER
   '                     di    AS INTEGER
   '                     flags AS INTEGER
   '                  END TYPE
   '      DECLARE SUB Interrupt (intnum%, inreg AS RegType, outreg AS RegType)
   '      DECLARE SUB Scroll (row1%, col1%, row2%, col2%, lines%, attribute%)
   '
     SUB Scroll (row1%, col1%, row2%, col2%, lines%, attribute%) STATIC
         DIM reg AS RegType
         IF lines% > 0 THEN
             reg.ax = &H600 + lines% MOD 256
         ELSE
             reg.ax = &H700 + ABS(lines%) MOD 256
         END IF
         reg.bx = (attribute% * 256&) AND &HFF00
         reg.cx = (row1% - 1) * 256 + col1% - 1
         reg.dx = (row2% - 1) * 256 + col2% - 1
         Interrupt &H10, reg, reg
     END SUB

   ' ************************************************
   ' **  Name:          VideoState                 **
   ' **  Type:          Subprogram                 **
   ' **  Module:        BIOSCALL.BAS               **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Determines the current video mode parameters.
   '
   ' EXAMPLE OF USE:  VideoState mode%, columns%, page%
   ' PARAMETERS:      mode%      Current video mode
   '                  columns%   Current number of text columns
   '                  page%      Current active display page
   ' VARIABLES:       reg        Structure of type RegType
   ' MODULE LEVEL
   '   DECLARATIONS:  TYPE RegType
   '                     ax    AS INTEGER
   '                     bx    AS INTEGER
   '                     cx    AS INTEGER
   '                     dx    AS INTEGER
   '                     Bp    AS INTEGER
   '                     si    AS INTEGER
   '                     di    AS INTEGER
   '                     flags AS INTEGER
   '                  END TYPE
   '
   '      DECLARE SUB Interrupt (intnum%, inreg AS RegType, outreg AS RegType)
   '      DECLARE SUB VideoState (mode%, columns%, page%)
   '
     SUB VideoState (mode%, columns%, page%) STATIC
         DIM reg AS RegType
         reg.ax = &HF00
         Interrupt &H10, reg, reg
         mode% = reg.ax AND &HFF
         columns% = (CLNG(reg.ax) AND &HFF00) \ 256
         page% = (CLNG(reg.bx) AND &HFF00) \ 256
     END SUB



 BITS.BAS
 CD-ROM Disc Path:   \SAMPCODE\QB\TOOLBOX\DISK1\BITS.BAS

   ' ************************************************
   ' **  Name:          BITS                       **
   ' **  Type:          Toolbox                    **
   ' **  Module:        BITS.BAS                   **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Demonstrates the bit manipulation functions
   ' and subprograms.
   '
   ' USAGE: No command line parameters
   ' .MAK FILE:       (none)
   ' PARAMETERS:      (none)
   ' VARIABLES:       max%       Upper limit for the prime number generator
   '                  b$         Bit string for finding prime numbers
   '                  n%         Loop index for sieve of Eratosthenes
   '                  bit%       Bit retrieved from b$
   '                  i%         Bit loop index
   '                  q$         The double quote character


     DECLARE FUNCTION BinStr2Bin% (b$)
     DECLARE FUNCTION Bin2BinStr$ (b%)

   ' Subprograms
     DECLARE SUB BitGet (a$, bitIndex%, bit%)
     DECLARE SUB BitPut (b$, bitIndex%, bit%)

   ' Prime numbers less than max%, using bit fields in B$
     CLS
     max% = 1000
     PRINT "Primes up to"; max%; "using BitGet and BitPut for sieve..."
     PRINT
     PRINT 1; 2;
     b$ = STRING$(max% \ 8 + 1, 0)
     FOR n% = 3 TO max% STEP 2
         BitGet b$, n%, bit%
         IF bit% = 0 THEN
             PRINT n%;
             FOR i% = 3 * n% TO max% STEP n% + n%
                 BitPut b$, i%, 1
             NEXT i%
         END IF
     NEXT n%
     PRINT

   ' Demonstration of the Bin2BinStr$ function
     PRINT
     PRINT "Bin2BinStr$(12345) = "; Bin2BinStr$(12345)

   ' Demonstration of the BinStr2Bin% function
     PRINT
     q$ = CHR$(34)
     PRINT "BinStr2Bin%("; q$; "1001011"; q$; ") = ";
     PRINT BinStr2Bin%("1001011")

   ' That's all
     END


   ' ************************************************
   ' **  Name:          Bin2BinStr$                **
   ' **  Type:          Function                   **
   ' **  Module:        BITS.BAS                   **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Returns a string of sixteen "0" and "1" characters
   ' that represent the binary value of b%.
   '
   ' EXAMPLE OF USE:  PRINT Bin2BinStr$(b%)
   ' PARAMETERS:      b%         Integer number
   ' VARIABLES:       t$         Working string space for forming binary strin
   '                  b%         Integer number
   '                  mask%      Bit isolation mask
   '                  i%         Looping index
   ' MODULE LEVEL
   '   DECLARATIONS:  DECLARE FUNCTION Bin2BinStr$ (b%)
   '
     FUNCTION Bin2BinStr$ (b%) STATIC
         t$ = STRING$(16, "0")
         IF b% THEN
             IF b% < 0 THEN
                 MID$(t$, 1, 1) = "1"
             END IF
             mask% = &H4000
             FOR i% = 2 TO 16
                 IF b% AND mask% THEN
                     MID$(t$, i%, 1) = "1"
                 END IF
                 mask% = mask% \ 2
             NEXT i%
         END IF
         Bin2BinStr$ = t$
     END FUNCTION

   ' ************************************************
   ' **  Name:          BinStr2Bin%                **
   ' **  Type:          Function                   **
   ' **  Module:        BITS.BAS                   **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Returns the integer represented by a string of up
   ' to 16 "0" and "1" characters.
   '
   ' EXAMPLE OF USE:  PRINT BinStr2Bin%(b$)
   ' PARAMETERS:      b$         Binary representation string
   ' VARIABLES:       bin%       Working variable for finding value
   '                  t$         Working copy of b$
   '                  mask%      Bit mask for forming value
   '                  i%         Looping index
   ' MODULE LEVEL
   '   DECLARATIONS:  DECLARE FUNCTION BinStr2Bin% (b$)
   '
     FUNCTION BinStr2Bin% (b$) STATIC
         bin% = 0
         t$ = RIGHT$(STRING$(16, "0") + b$, 16)
         IF LEFT$(t$, 1) = "1" THEN
             bin% = &H8000
         END IF
         mask% = &H4000
         FOR i% = 2 TO 16
             IF MID$(t$, i%, 1) = "1" THEN
                 bin% = bin% OR mask%
             END IF
             mask% = mask% \ 2
         NEXT i%
         BinStr2Bin% = bin%
     END FUNCTION

   ' ************************************************
   ' **  Name:          BitGet                     **
   ' **  Type:          Subprogram                 **
   ' **  Module:        BITS.BAS                   **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' Extracts the bit at bitIndex% into a$ and returns
   ' either 0 or 1 in bit%.  The value of bitIndex%
   ' can range from 1 to 8 * LEN(a$).
   '
   ' EXAMPLE OF USE:  BitGet a$, bitIndex%, bit%
   ' PARAMETERS:      a$         String where bit is stored
   '                  bitIndex%  Bit position in string
   '                  bit%       Extracted bit value, 0 or 1
   ' VARIABLES:       byte%      Byte location in string of the bit
   '                  mask%      Bit isolation mask for given bit
   ' MODULE LEVEL
   '   DECLARATIONS:  DECLARE SUB BitGet (a$, bitIndex%, bit%)
   '
     SUB BitGet (a$, bitIndex%, bit%) STATIC
         byte% = (bitIndex% - 1) \ 8 + 1
         SELECT CASE bitIndex% MOD 8
         CASE 1
             mask% = 128
         CASE 2
             mask% = 64
         CASE 3
             mask% = 32
         CASE 4
             mask% = 16
         CASE 5
             mask% = 8
         CASE 6
             mask% = 4
         CASE 7
             mask% = 2
         CASE 0
             mask% = 1
         END SELECT
         IF ASC(MID$(a$, byte%, 1)) AND mask% THEN
             bit% = 1
         ELSE
             bit% = 0
         END IF
     END SUB

   ' ************************************************
   ' **  Name:          BitPut                     **
   ' **  Type:          Subprogram                 **
   ' **  Module:        BITS.BAS                   **
   ' **  Language:      Microsoft QuickBASIC 4.00  **
   ' ************************************************
   '
   ' If bit% is non-zero, then the bit at bitIndex% into
   ' a$ is set to 1; otherwise, it's set to 0. The value
   ' of bitIndex% can range from 1 to 8 * LEN(a$).
   '
   ' EXAMPLE OF USE:  BitPut a$, bitIndex%, bit%
   ' PARAMETERS:      a$         String containing the bits
   '                  bitIndex%  Index to the bit of concern
   '                  bit%       Value of bit (1 to set, 0 to clear)
   ' VARIABLES:       bytePtr%   Pointer to the byte position in the string
   '                  mask%      Bit isolation mask
   '                  byteNow%   Current numeric value of string byte
   ' MODULE LEVEL
   '   DECLARATIONS:  DECLARE SUB BitPut (b$, bitIndex%, bit%)
   '
     SUB BitPut (a$, bitIndex%, bit%) STATIC
         bytePtr% = bitIndex% \ 8 + 1
         SELECT CASE bitIndex% MOD 8
         CASE 1
             mask% = 128
         CASE 2
             mask% = 64
         CASE 3
             mask% = 32
         CASE 4
             mask% = 16
         CASE 5
             mask% = 8
         CASE 6
             mask% = 4
         CASE 7
             mask% = 2
         CASE 0
             mask% = 1
             bytePtr% = bytePtr% - 1
         END SELECT
         byteNow% = ASC(MID$(a$, bytePtr%, 1))
         IF byteNow% AND mask% THEN
             IF bit% = 0 THEN
                 MID$(a$, bytePtr%, 1) = CHR$(byteNow% XOR mask%)
             END IF
         ELSE
             IF bit% THEN
                 MID$(a$, bytePtr%, 1) = CHR$(byteNow% XOR mask%)
             END IF
         END IF
     END SUB



 CAL.BAS
 CD-ROM Disc Path:   \SAMPCODE\QB\SRCDISK\CAL.BAS

 DEFINT A-Z               ' Default variable type is integer

 ' Define a data type for the names of the months and the
 ' number of days in each:
 TYPE MonthType
    Number AS INTEGER     ' Number of days in the month
    MName AS STRING * 9   ' Name of the month
 END TYPE

 ' Declare procedures used:
 DECLARE FUNCTION IsLeapYear% (N%)
 DECLARE FUNCTION GetInput% (Prompt$, Row%, LowVal%, HighVal%)

 DECLARE SUB PrintCalendar (Year%, Month%)
 DECLARE SUB ComputeMonth (Year%, Month%, StartDay%, TotalDays%)

 DIM MonthData(1 TO 12) AS MonthType

 ' Initialize month definitions from DATA statements below:
 FOR I = 1 TO 12
    READ MonthData(I).MName, MonthData(I).Number
 NEXT

 ' Main loop, repeat for as many months as desired:
 DO

    CLS

    ' Get year and month as input:
    Year = GetInput("Year (1899 to 2099): ", 1, 1899, 2099)
    Month = GetInput("Month (1 to 12): ", 2, 1, 12)

    ' Print the calendar:
    PrintCalendar Year, Month

    ' Another Date?
    LOCATE 13, 1         ' Locate in 13th row, 1st column
    PRINT "New Date? ";  ' Keep cursor on same line
    LOCATE , , 1, 0, 13  ' Turn cursor on and make it one
                         ' character high
    Resp$ = INPUT$(1)    ' Wait for a key press
    PRINT Resp$          ' Print the key pressed

 LOOP WHILE UCASE$(Resp$) = "Y"
 END

 ' Data for the months of a year:
 DATA January, 31, February, 28, March, 31
 DATA April, 30, May, 31, June, 30, July, 31, August, 31
 DATA September, 30, October, 31, November, 30, December, 31
 '
 ' ====================== COMPUTEMONTH ========================
 '     Computes the first day and the total days in a month.
 ' ============================================================
 '
 SUB ComputeMonth (Year, Month, StartDay, TotalDays) STATIC
    SHARED MonthData() AS MonthType
    CONST LEAP = 366 MOD 7
    CONST NORMAL = 365 MOD 7

    ' Calculate total number of days (NumDays) since 1/1/1899.

    ' Start with whole years:
    NumDays = 0
    FOR I = 1899 TO Year - 1
       IF IsLeapYear(I) THEN         ' If year is leap, add
          NumDays = NumDays + LEAP   ' 366 MOD 7.
       ELSE                          ' If normal year, add
          NumDays = NumDays + NORMAL ' 365 MOD 7.
       END IF
    NEXT

    ' Next, add in days from whole months:
    FOR I = 1 TO Month - 1
       NumDays = NumDays + MonthData(I).Number
    NEXT

    ' Set the number of days in the requested month:
    TotalDays = MonthData(Month).Number

    ' Compensate if requested year is a leap year:
    IF IsLeapYear(Year) THEN

       ' If after February, add one to total days:
       IF Month > 2 THEN
          NumDays = NumDays + 1

       ' If February, add one to the month's days:
       ELSEIF Month = 2 THEN
          TotalDays = TotalDays + 1

       END IF
    END IF

    ' 1/1/1899 was a Sunday, so calculating "NumDays MOD 7"
    ' gives the day of week (Sunday = 0, Monday = 1, Tuesday = 2,
    ' and so on) for the first day of the input month:
    StartDay = NumDays MOD 7
 END SUB
 '
 ' ======================== GETINPUT ==========================
 '       Prompts for input, then tests for a valid range.
 ' ============================================================
 '
 FUNCTION GetInput (Prompt$, Row, LowVal, HighVal) STATIC

    ' Locate prompt at specified row, turn cursor on and
    ' make it one character high:
    LOCATE Row, 1, 1, 0, 13
    PRINT Prompt$;

    ' Save column position:
    Column = POS(0)

    ' Input value until it's within range:
    DO
       LOCATE Row, Column   ' Locate cursor at end of prompt
       PRINT SPACE$(10)     ' Erase anything already there
       LOCATE Row, Column   ' Relocate cursor at end of prompt
       INPUT "", Value      ' Input value wi