Shareware Overload/ShartewareOverload.cdr/games/jots.zip/WORDS.BAS

BASIC Source File | 1989-03-15 | 9KB | 352 lines

' WORDS.BAS -- This module handles the word list and picking the secret
'  word.
' $INCLUDE: 'J.INC'

DECLARE SUB SetPrefPtr ()
DECLARE SUB WPstring (Msg$, Row)
DECLARE SUB FillDisplay ()
DECLARE SUB MarkWord (Num)
DECLARE SUB UnmarkWord (Num)
DECLARE SUB ViewList ()
DECLARE SUB AddToList ()
DIM SHARED MyBox AS BoxType, TopRow, BotRow, LftCol, RtCol
DIM SHARED FirstWord
DIM SHARED WordCount, ExtraCount, MaxAdds, AddedWordFlag
REDIM SHARED WordList(1) AS STRING * 5
REDIM SHARED PrefPtr(1, 1)
DIM SHARED PickedWord$

FileError:
    CLS
    PRINT "Error trying to read JWORDS.JOT file"
    PRINT "Program stopping."
    END

' File format of JWORDS.JOT:
' 2-byte count of # of words in file (binary integer format)
' |  Binary count 1 to 31 (1-byte) + 2-letter prefix (caps only)
' |  count tells how many 3-letter suffixes follow.
' |
' |_ repeat as necessary


SUB AddToList
    COLOR Normal, Background, Background
    CLS
    PRINT
    PRINT "   Enter the words you want to add, one per line."
    PRINT "   Press <Return> at the beginning of a line to end."
    PRINT
    DO
        LINE INPUT "==> ", NewWord$
        NewWord$ = UCASE$(RTRIM$(LTRIM$(NewWord$)))
        IF LEN(NewWord$) = 5 THEN
            IF WordExists(NewWord$) THEN
                PRINT CHR$(7); "          That word is already in the list"
            ELSEIF ExtraCount >= MaxAdds THEN
                PRINT CHR$(7); "          The word list is presently full."
                PRINT "          End the program and restart it to add more words"
                Pause
                EXIT SUB
            ELSE
                Valid = TRUE
                For lp = 1 to 5
                    Letter$ = Mid$(NewWord$,Lp,1)
                    If Letter$ < "A" or Letter$ > "Z" THEN
                        Valid = FALSE
                    END if
                Next Lp
                If Valid THEN
                    AddWord (NewWord$)
                ELSE
                    Print chr$(7); "         You may not use punctuation or numbers"
                END IF
            END IF
        ELSEIF LEN(NewWord$) <> 0 THEN
            PRINT CHR$(7); "          Words must be 5 letters long"
        END IF
    LOOP WHILE LEN(NewWord$)
END SUB

SUB AddWord (Word$)
    IF ExtraCount < MaxAdds THEN
        ExtraCount = ExtraCount + 1
        WordList$(WordCount + ExtraCount) = Word$
        AddedWordFlag = TRUE
    END IF
END SUB

SUB FillDisplay
    FOR Lp = 0 TO 7      'For 8 Cols
        Cword = FirstWord + Lp * 20
        Col = 3 + Lp * 10
        FOR Lp2 = 0 TO 19
            LOCATE Lp2 + 2, Col, 0
            PRINT WordList$(Cword + Lp2);
        NEXT Lp2
    NEXT Lp
END SUB

SUB InitWordList
    COLOR Normal, Background, Background
    PRINT
    PRINT "  One moment please...";
    OPEN "JWORDS.JOT" FOR BINARY AS 1
    GET 1, , WordCount
    MaxAdds = 200
    REDIM WordList(1 TO WordCount + MaxAdds) AS STRING * 5
    Instring$ = STRING$(3, " ")
    wcount = 0
    Print "reading"; WordCount; "words from JWORDS.JOT"
    DO WHILE wcount < WordCount
        GET 1, , Instring$
        PrefCount = ASC(Instring$)
        Prefix$ = MID$(Instring$, 2)
        FOR Lp = 1 TO PrefCount
            GET 1, , Instring$
            wcount = wcount + 1
            WordList$(wcount) = Prefix$ + Instring$
        NEXT Lp
    LOOP
    CLOSE #1
    SetPrefPtr
    ExtraPtr = WordCount + 1
    ExtraCount = 0
    AddedWordFlag = FALSE

END SUB

SUB MarkWord (Num)
    Row = Num MOD 20
    IF Row = 0 THEN Row = 20
    Col = (Num - 1) \ 20
    Word$ = WordList$(FirstWord + Num - 1)
    LOCATE Row + 1, Col * 10 + 2, 0
    COLOR Known, Background, Background
    PRINT CHR$(175); Word$; CHR$(174);
    COLOR Normal, Background, Background
END SUB

SUB PickAWord
    RANDOMIZE TIMER
    DO
        Pick = INT(RND(1) * (WordCount + ExtraCount)) + 1
        PickedWord$ = WordList$(Pick)
    LOOP WHILE LEN(PickedWord$) <> 5
END SUB

SUB SaveWordList
    IF AddedWordFlag = FALSE THEN
        EXIT SUB
    END IF
    COLOR Normal, Background, Background
    CLS
    PRINT "Sorting and saving new word list ";

    Count = WordCount + ExtraCount
    FirstWordPtr = 1
    FOR Lp = 2 TO Count
        IF WordList$(Lp) < WordList$(FirstWordPtr) THEN
            FirstWordPtr = Lp
        END IF
    NEXT Lp
    IF FirstWordPtr <> 1 THEN
        SWAP WordList$(1), WordList$(FirstWordPtr)
    END IF
    FOR Lp = 2 TO Count
        Ptr = Lp
        DO WHILE WordList$(Ptr) < WordList$(Ptr - 1)
            SWAP WordList$(Ptr), WordList$(Ptr - 1)
            Ptr = Ptr - 1
        LOOP
        IF Lp MOD 100 = 0 THEN PRINT ".";
    NEXT Lp
    DO WHILE WordList$(Count) > "ZZZZZ"
        Count = Count - 1
    LOOP
    WordCount = Count
    ExtraCount = 0

    OPEN "JWORDS.JOT" FOR BINARY AS 1
    PUT 1, , Count
    Ptr = 1
    Suffix$ = STRING$(3, " ")
    DO WHILE Ptr <= Count
        PrefPtr = Ptr
        Prefix$ = LEFT$(WordList$(Ptr), 2)
        DO WHILE LEFT$(WordList$(PrefPtr + 1), 2) = Prefix$ AND PrefPtr < Ptr + 30
            PrefPtr = PrefPtr + 1
        LOOP
        PrefCount = PrefPtr - Ptr + 1
        Prefix$ = CHR$(PrefCount) + Prefix$
        PUT 1, , Prefix$
        FOR Lp = Ptr TO PrefPtr
            LSET Suffix$ = MID$(WordList$(Lp), 3)
            PUT 1, , Suffix$
        NEXT Lp
        Ptr = PrefPtr + 1
    LOOP
    CLOSE
    SetPrefPtr
    ExtraPtr = WordCount + 1
    ExtraCount = 0
    AddedWordFlag = FALSE
    MaxAdds = UBOUND(WordList$) - WordCount
END SUB

FUNCTION SecretWord$
    SecretWord$ = PickedWord$
END FUNCTION

SUB SetPrefPtr
    REDIM PrefPtr(ASC("A") TO ASC("Z"), ASC("A") TO ASC("Z"))
    Pref1$ = " "
    Pref2$ = " "
    Temp$ = STRING$(5, " ")
    FOR Lp = 1 TO WordCount
        LSET Temp$ = WordList$(Lp)
        IF LEFT$(Temp$, 1) <> Pref1$ OR MID$(Temp$, 2, 1) <> Pref2$ THEN
            Pref1$ = MID$(Temp$, 1, 1)
            Pref2$ = MID$(Temp$, 2, 1)
            PrefPtr(ASC(Pref1$), ASC(Pref2$)) = Lp
        END IF
    NEXT Lp
END SUB

SUB UnmarkWord (Num)
    Row = Num MOD 20
    IF Row = 0 THEN Row = 20
    Col = (Num - 1) \ 20
    Word$ = WordList$(FirstWord + Num - 1)
    LOCATE Row + 1, Col * 10 + 2, 0
    COLOR Normal, Background, Background
    PRINT " "; Word$; " ";
END SUB

SUB ViewList
    COLOR Normal, Background, Background
    CLS
    InitMessage
    ShowMessage ("Use arrows, PgUp and PgDn, Del to delete, Esc to end")
    FirstWord = 1
    DO
        IF FirstWord > WordCount + ExtraCount - 159 THEN
            FirstWord = WordCount + ExtraCount - 159
        END IF
        IF FirstWord < 1 THEN FirstWord = 1
        FillDisplay
        Marked = 1
        DO
            DO
                Marked = (Marked + 160) MOD 160
            LOOP WHILE Marked < 0
            IF Marked = 0 THEN Marked = 160
            MarkWord (Marked)
            DO
                Char$ = INKEY$
            LOOP UNTIL LEN(Char$)
            IF Char$ = CHR$(27) THEN               'ESC
                EXIT SUB
            END IF
            IF LEN(Char$) = 2 THEN
                Char$ = MID$(Char$, 2)
                UnmarkWord (Marked)
                SELECT CASE Char$
                    CASE CHR$(73)                    'PgUp
                        FirstWord = FirstWord - 160
                        EXIT DO
                    CASE CHR$(81)                    'PgDn
                        FirstWord = FirstWord + 160
                        EXIT DO
                    CASE CHR$(72)                    'Up arrow
                        Marked = Marked - 1
                    CASE CHR$(80)                    'Dn Arrow
                        Marked = Marked + 1
                    CASE CHR$(75)                    'Left arrow
                        Marked = Marked - 20
                    CASE CHR$(77)                    'Right arrow
                        Marked = Marked + 20
                    CASE CHR$(71)                    'Home
                        Marked = 1
                    CASE CHR$(79)                    'End
                        Marked = 160
                    CASE CHR$(83)                    'DEL
                            MarkWord (Marked)
                        CurWord = FirstWord + Marked - 1
                        PushMsg
                        ShowMessage ("Do you want to delete " + WordList$(CurWord) + "?")
                        YN$ = YesNo$
                        PopMsg
                        UnmarkWord (Marked)
                        IF YN$ = "Y" THEN
                            WordList$(CurWord) = STRING$(5, 255)
                            AddedWordFlag = TRUE
                            FillDisplay
                        END IF
                    CASE ELSE
                        MarkWord (Marked)
                END SELECT
            END IF
        LOOP
    LOOP
END SUB

FUNCTION WordExists (Word$)
    Pref1$ = MID$(Word$, 1, 1)
    Pref2$ = MID$(Word$, 2, 1)
    Ptr = PrefPtr(ASC(Pref1$), ASC(Pref2$))
    DO WHILE WordList$(Ptr) < Word$
        Ptr = Ptr + 1
    LOOP
    IF WordList$(Ptr) = Word$ THEN
        WordExists = TRUE
        EXIT FUNCTION
    END IF
    ListEnd = WordCount + ExtraCount
    FOR Lp = WordCount + 1 TO ListEnd
        IF WordList$(Lp) = Word$ THEN
            WordExists = TRUE
            EXIT FUNCTION
        END IF
    NEXT Lp
    WordExists = FALSE
END FUNCTION

SUB WordMaintenance
    CALL BoxCoords(MaintMenuBox, MyBox)
    TopRow = MyBox.TopRow
    BotRow = MyBox.BotRow
    LftCol = MyBox.LftCol
    RtCol = MyBox.RtCol

    DO
        COLOR Normal, Background, Background
        CLS
        NormalBox (MaintMenuBox)
        CALL WPstring("Word List Maintenance", 1)
        CALL WPstring("1. View and Delete Words", 3)
        CALL WPstring("2. Add Words to List", 5)
        CALL WPstring("3. Return to Main Menu", 7)
        CALL WPstring("   Enter number of your choice", 9)
        DO
            choice$ = INPUT$(1)
        LOOP UNTIL choice$ >= "1" AND choice$ <= "4"
        SELECT CASE choice$
            CASE "1"
                    ViewList
            CASE "2"
                    AddToList
            CASE "3"
                SaveWordList
                EXIT SUB
            CASE ELSE
        END SELECT
    LOOP
END SUB

SUB WPstring (Msg$, Row)
    LOCATE TopRow + Row, LftCol + (RtCol - LftCol - LEN(Msg$)) / 2, 0
    PRINT Msg$;
END SUB