Black Box 4/BlackBox.cdr/progbas/qbnws103.arj/FRAME.BAS

BASIC Source File | 1990-05-15 | 7KB | 162 lines

SUB Frame (TopRow%, leftCol%, botRow%, rightCol%, boxType%, boxFg%, boxBg%, filFg%, filBg%, fillChar%, shadow%, header$) STATIC

'                     +******************************+    message 2 of 4
'                     *          FRAME.BAS           *
'                     *                              *
'                     *   by: Lawrence Stone, 1990   *
'                     +******************************+
'
'+**************************************************************************+
'*   boxType% 1 = ┌────┐  2 = ╔════╗  3 = ╓────╖  4 = ╒════╕                *
'*                │    │      ║    ║      ║    ║      │    │                *
'*                └────┘      ╚════╝      ╙────╜      ╘════╛                *
'*   header tees =  ┤├          ╡╞          ┤├          ╡╞                  *
'*                                                                          *
'*   If filFg% = 0 *AND* filBg% = 0 then the box does not clear the middle  *
'*   otherwise, the box clears the middle with the colors called for.       *
'*                                                                          *
'*   fillChar% is the ASCII number for the character to fill the box with.  *
'*   Example: fillChar% = 32 is " " or fillChar% = 176 is "░"               *
'*                                                                          *
'*   shadow% if true, computes the character and color attribute along the  *
'*   right and bottom side of the box and prints the appropriate shadow.    *
'*                                                                          *
'*   If header$ <> "" then box centers this message at the top and inside   *
'*   of the appropriate ┤ ├ characters.  Otherwise, if header$ = "" then    *
'*   the box is a non-titled box.                                           *
'*                                                                          *
'*   SPECIAL NOTE:  This subprogram is STATIC.  By making it STATIC, QB     *
'*   doesn't have to re-initialize variables after it is CALLed the first   *
'*   time.  This produces faster execution.  If your program is going to    *
'*   need all the memory it can grab then, remove the STATIC keyword from   *
'*   the top line of this subprogram.                                       *
'+**************************************************************************+
    DEFINT A-Z                       'message 3 of 4

    GOSUB InitiateBox

    '*** Is the box titled? If so then print it centered on top line of box.
    IF LEN(header$) THEN
        temp$ = leftT$ + " " + header$ + " " + rightT$

        '*** How long should horz$ be to left and right of the header$?
        portion = ((boxWide - LEN(temp$)) \ 2)

        '*** Print top-left side of box, as well as, the header string.
        PRINT topLeft$; STRING$(portion, horz$); temp$;

        '*** Adjust the right side if it isn't the same length as the left.
        IF ((boxWide - LEN(temp$)) MOD 2) THEN
            PRINT STRING$(portion + 1, horz$); topRight$;

        '*** No adjustments are needed if left and right side are equal length
        ELSE
            PRINT STRING$(portion, horz$); topRight$;
        END IF

    '*** If the box is untitled then draw the top line of box sans header
    ELSE
        PRINT topLeft$; STRING$(boxWide, horz$); topRight$;
    END IF

    '*** Draw the sides of the box
    FOR boxRow = TopRow + 1 TO botRow - 1
        COLOR boxFg, boxBg
        LOCATE boxRow, leftCol
        PRINT vert$;                            ' Draw left side of box
        IF clearBox THEN                        ' Do we clear the box?
            COLOR filFg, filBg
            PRINT STRING$(boxWide, fillChar);   ' Clear box with the fillChar
            COLOR boxFg, boxBg
        END IF
        LOCATE boxRow, rightCol
        PRINT vert$;                            ' Draw the right side of box
        IF shadow THEN                          ' Do we draw a shadow?
            FOR B = 1 TO 2
                csrPos = rightCol + B           ' Calculate the cursor column
                GOSUB ConfigShadow              ' Calculate and draw shadow
            NEXT
        END IF
    NEXT

    COLOR boxFg, boxBg: LOCATE botRow, leftCol
    PRINT botLeft$; STRING$(boxWide, horz$); botRight$;   ' Draw box bottom

    IF shadow THEN                              ' Do we draw the shadow?
        boxRow = botRow
        FOR B = 1 TO 2
            csrPos = rightCol + B               ' Finish bottom-right shadow
            GOSUB ConfigShadow
        NEXT
        boxRow = botRow + 1
        FOR csrPos = leftCol + 2 TO leftCol + boxWide + 3
            IF csrPos < 81 THEN LOCATE boxRow, csrPos   ' Prevent's an error
            GOSUB ConfigShadow                  ' Draw shadow below box
        NEXT
    END IF
    IF clearBox THEN COLOR filFg, filBg         ' Reset fill colors
    EXIT SUB
' message 4 of 4
'           +***************************************************+
'           *                     Subroutines                   *
'           +***************************************************+

InitiateBox:
    IF boxType = 1 THEN
        topLeft$ = "┌"
        topRight$ = "┐"
        botLeft$ = "└"
        botRight$ = "┘"
        vert$ = "│"
        horz$ = "─"
        leftT$ = "┤"
        rightT$ = "├"
    ELSEIF boxType = 2 THEN
        topLeft$ = "╔"
        topRight$ = "╗"
        botLeft$ = "╚"
        botRight$ = "╝"
        vert$ = "║"
        horz$ = "═"
        leftT$ = "╡"
        rightT$ = "╞"
    ELSEIF boxType = 3 THEN
        topLeft$ = "╓"
        topRight$ = "╖"
        botLeft$ = "╙"
        botRight$ = "╜"
        vert$ = "║"
        horz$ = "─"
        leftT$ = "┤"
        rightT$ = "├"
    ELSEIF boxType = 4 THEN
        topLeft$ = "╒"
        topRight$ = "╕"
        botLeft$ = "╘"
        botRight$ = "╛"
        vert$ = "│"
        horz$ = "═"
        leftT$ = "╡"
        rightT$ = "╞"
    END IF

    boxWide = rightCol - leftCol - 1
    IF (filFg = 0 AND filBg = 0) THEN clearBox = 0 ELSE clearBox = -1
    COLOR boxFg, boxBg
    LOCATE TopRow, leftCol
RETURN

ConfigShadow:
    IF ((csrPos < 81) AND (boxRow < 26)) THEN   ' Prevent an illegal function
        attribute = SCREEN(boxRow, csrPos, -1)  ' Obtain the color attribute
        char = SCREEN(boxRow, csrPos)           ' Obtain the charcter
        fg = attribute AND 15                   ' Calculate forground color.
        fg = fg - 8                             ' Remove bright from the color
        IF fg < 1 THEN fg = 8                   ' In case color wasn't bright
        COLOR fg, 0: PRINT CHR$(char);          ' Color and print shadow char
    END IF
RETURN

END SUB