'Crossword Generator (Multilingual) using _MEM by Qwerkey 7/10/19
'And uses checkingoff - tested, but caveat emptor

CONST False = 0, True = NOT False, MaxTries& = 14000 'The best compromise for all languages
DIM LesLettres&(26), Orient%%(1, 1), ULoc$(6), FillOrder%%(6), LangImg&(6)
_TITLE "Crossword Generator"
DATA 1,0,0,1
FOR D%% = 0 TO 1
    READ Orient%%(D%%, 0)
    READ Orient%%(D%%, 1)
NEXT D%%
DATA 10,9,8,7,6,4,5
FOR N%% = 0 TO 6
    READ FillOrder%%(N%%)
NEXT N%%
'Menu Screens
LangImg&(0) = _LOADIMAGE("UKEnglish.jpg", 32)
LangImg&(1) = _LOADIMAGE("USEnglish.jpg", 32)
LangImg&(2) = _LOADIMAGE("Deutsch.jpg", 32) '
LangImg&(3) = _LOADIMAGE("Espanol.jpg", 32)
LangImg&(4) = _LOADIMAGE("Francais.jpg", 32)
LangImg&(5) = _LOADIMAGE("Roman.jpg", 32)
LangImg&(6) = _LOADIMAGE("Nederlands.jpg", 32)
LangChosen%% = False
OPEN "xword.cfg" FOR INPUT AS #1
INPUT #1, Language%%
CLOSE #1

'Select Language
SCREEN _NEWIMAGE(301, 501, 32)
_DEST 0
_PUTIMAGE , LangImg&(Language%%)
WHILE NOT LangChosen%%
    _LIMIT 30
    k$ = INKEY$
    IF k$ <> "" THEN
        IF k$ = " " THEN
            Language%% = Language%% + 1
            IF Language%% > 6 THEN Language%% = 0
            CLS
            _PUTIMAGE , LangImg&(Language%%)
        ELSEIF ASC(k$) = 13 THEN
            LangChosen%% = True
        ELSEIF ASC(k$) = 27 THEN
            SYSTEM
        END IF
        k$ = ""
    END IF
WEND
OPEN "xword.cfg" FOR OUTPUT AS #1
PRINT #1, Language%%
CLOSE #1

'Create _MEM block dictionaries
'NonMid$:  Letters excluded from middle crossings.  NonEnd$:  Letters excluded from end crossings
DIM MDict(6) AS _MEM
DIM MNoWords(6) AS _MEM
SELECT CASE Language%%
    CASE 0 'UK English (Default)
        NonMid$ = "BFJKQVWXYZ"
        NonEnd$ = "BCFGHIJKMOPQUVWXZ"
        Rouge% = 235
        Vert% = 0
        Bleu% = 0
        'Open Dictionaries
        FOR K%% = 4 TO 10
            OPEN LTRIM$(STR$(K%%)) + "UKEng.rnd" FOR RANDOM AS #K%% LEN = K%%
            FIELD #K%%, K%% AS ULoc$(K%% - 4)
        NEXT K%%
    CASE 1 'US English
        NonMid$ = "BFJKQVWXYZ"
        NonEnd$ = "BCFGHIJKMOPQUVWXZ"
        Rouge% = 41
        Vert% = 46
        Bleu% = 139
        'Open Dictionaries
        FOR K%% = 4 TO 10
            OPEN LTRIM$(STR$(K%%)) + "USEng.rnd" FOR RANDOM AS #K%% LEN = K%%
            FIELD #K%%, K%% AS ULoc$(K%% - 4)
        NEXT K%%
    CASE 2 'German
        NonMid$ = "FJKMPQVWXYZ" 'K is nearly acceptable
        NonEnd$ = "ABCFHIJLOPQUVWXZ" 'A is high for <= 6 low for >= 7, G is high for >= 6 low for <= 5
        Rouge% = 120
        Vert% = 100
        Bleu% = 0
        'Open Dictionaries
        FOR K%% = 4 TO 10
            OPEN LTRIM$(STR$(K%%)) + "deutsch.rnd" FOR RANDOM AS #K%% LEN = K%%
            FIELD #K%%, K%% AS ULoc$(K%% - 4)
        NEXT K%%
    CASE 3 'Spanish
        NonMid$ = "FHJKPQVWXYZ"
        NonEnd$ = "BCDFGHIJKLMPQTUVWYXZ"
        Rouge% = 185
        Vert% = 2
        Bleu% = 31
        'Open Dictionaries
        FOR K%% = 4 TO 10
            OPEN LTRIM$(STR$(K%%)) + "palabras.rnd" FOR RANDOM AS #K%% LEN = K%%
            FIELD #K%%, K%% AS ULoc$(K%% - 4)
        NEXT K%%
    CASE 4 'French
        NonMid$ = "BFHJKQVWXYZ"
        NonEnd$ = "BCDFGHJKLMNOPQUVWX"
        Rouge% = 110
        Vert% = 0
        Bleu% = 110
        'Open Dictionaries
        FOR K%% = 4 TO 10
            OPEN LTRIM$(STR$(K%%)) + "mots.rnd" FOR RANDOM AS #K%% LEN = K%%
            FIELD #K%%, K%% AS ULoc$(K%% - 4)
        NEXT K%%
    CASE 5 'Italian
        NonMid$ = "FHJKQWXY"
        NonEnd$ = "BCDFGHJKLMNPQSUVWXZ" 'R/T doubtful
        Rouge% = 0
        Vert% = 215
        Bleu% = 0
        'Open Dictionaries
        FOR K%% = 4 TO 10
            OPEN LTRIM$(STR$(K%%)) + "ita.rnd" FOR RANDOM AS #K%% LEN = K%%
            FIELD #K%%, K%% AS ULoc$(K%% - 4)
        NEXT K%%
    CASE ELSE 'Dutch
        NonMid$ = "BCFGHJKMPQVWXYZ" 'G is low for <= 7, J&K nearly acceptable, S is low for 4
        NonEnd$ = "BCFGHIJMOPQUVWXZ" 'A is high for <= 5
        Rouge% = 215
        Vert% = 130
        Bleu% = 0
        'Open Dictionaries
        FOR K%% = 4 TO 10
            OPEN LTRIM$(STR$(K%%)) + "ned.rnd" FOR RANDOM AS #K%% LEN = K%%
            FIELD #K%%, K%% AS ULoc$(K%% - 4)
        NEXT K%%
END SELECT
'Read dictionaries into _MEM blocks
FOR K%% = 4 TO 10
    MDict(K%% - 4) = _MEMNEW(LOF(K%%))
    MNoWords(K%% - 4) = _MEMNEW(4)
    _MEMPUT MNoWords(K%% - 4), MNoWords(K%% - 4).OFFSET, (LOF(K%%) / K%%) AS _UNSIGNED LONG
    FOR Counter& = 1 TO LOF(K%%) / K%%
        GET #K%%, Counter&
        _MEMPUT MDict(K%% - 4), MDict(K%% - 4).OFFSET + ((Counter& - 1) * K%%), ULoc$(K%% - 4)
    NEXT Counter&
    CLOSE #K%%
NEXT K%%
'Read Mid/End straings into _MEM blocks
DIM MNEnd AS _MEM
MNEnd = _MEMNEW(LEN(NonEnd$))
DIM MNMid AS _MEM
MNMid = _MEMNEW(LEN(NonMid$))
FOR P%% = 1 TO LEN(NonEnd$)
    _MEMPUT MNEnd, MNEnd.OFFSET + P%% - 1, ASC(NonEnd$, P%%) AS _UNSIGNED _BYTE
NEXT P%%
FOR P%% = 1 TO LEN(NonMid$)
    _MEMPUT MNMid, MNMid.OFFSET + P%% - 1, ASC(NonMid$, P%%) AS _UNSIGNED _BYTE
NEXT P%%

'Character Images
DATA 2,2,2,2,2,2,2,2,8,6,2,2,0,4,2,2,2,2,4,2,2,2,0,2,2,2
FOR N%% = 1 TO 26
    READ CyberSpace%%
    LesLettres&(N%%) = _NEWIMAGE(34, 34, 32)
    _DEST LesLettres&(N%%)
    COLOR _RGB32(Rouge%, Vert%, Bleu%), _RGB32(255, 255, 255)
    CLS
    F& = _LOADFONT("cyberbit.ttf", 30, "bold")
    _FONT F&
    _PRINTSTRING (CyberSpace%%, 0), CHR$(N%% + 64)
    _FONT 16
    _FREEFONT F&
NEXT N%%
LesLettres&(0) = _NEWIMAGE(34, 34, 32)
_DEST LesLettres&(0)
COLOR _RGB32(Rouge%, Vert%, Bleu%), _RGB32(255, 255, 255)
CLS
F& = _LOADFONT("cyberbit.ttf", 30, "bold")
_FONT F&
_PRINTSTRING (6, 4), "*"
_FONT 16
_FREEFONT F&
'Crossword Screen
SCREEN _NEWIMAGE(800, 800, 32)
_SCREENMOVE 50, 10
_DEST 0
COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
CLS
PRINT "Generating Crossword Grid";
'!!! Use with care
$CHECKING:OFF

Start! = TIMER
DoXWord%% = True
WHILE DoXWord%%
    'Create Temporary Grid
    REDIM CWord%%(16, 16)
    RANDOMIZE (TIMER)
    FOR N%% = 0 TO 16 STEP 16
        FOR M%% = 0 TO 16
            CWord%%(N%%, M%%) = True
        NEXT M%%
    NEXT N%%
    FOR N%% = 0 TO 16
        FOR M%% = 0 TO 16 STEP 16
            CWord%%(N%%, M%%) = True
        NEXT M%%
    NEXT N%%
    FOR N%% = 1 TO 15 STEP 2
        FOR M%% = 1 TO 15 STEP 2
            CWord%%(N%%, M%%) = True
        NEXT M%%
    NEXT N%%
    FOR N%% = 2 TO 6 STEP 2
        IF N%% = 6 THEN
            L%% = 5 + INT(3 * RND)
        ELSE
            IF RND < 0.5 THEN
                L%% = 5
            ELSE
                L%% = 7
            END IF
        END IF
        CWord%%(N%%, L%%) = True
        CWord%%(16 - N%%, 16 - L%%) = True
    NEXT N%%
    IF RND < 0.5 THEN
        CWord%%(8, 8) = True
    ELSE
        CWord%%(8, 5) = True
        CWord%%(8, 11) = True
    END IF
    'Place Additional Blanks
    FOR M%% = 2 TO 6 STEP 2
        'First check if line is already split
        BreakExists%% = False
        N%% = 1
        WHILE NOT BreakExists%% AND N%% <= 8
            IF CWord%%(N%%, M%%) THEN
                BreakExists%% = True
            ELSE
                N%% = N%% + 1
            END IF
        WEND
        IF NOT BreakExists%% THEN
            L%% = 5 + 2 * INT(4 * RND)
            CWord%%(L%%, M%%) = True
            CWord%%(16 - L%%, 16 - M%%) = True
        END IF
    NEXT M%%
    BreakExists%% = False
    N%% = 1
    WHILE NOT BreakExists%% AND N%% <= 8
        IF CWord%%(N%%, 8) THEN
            BreakExists%% = True
        ELSE
            N%% = N%% + 1
        END IF
    WEND
    IF NOT BreakExists%% THEN
        IF RND < 0.5 THEN
            CWord%%(5, 8) = True
            CWord%%(11, 8) = True
        ELSE
            CWord%%(7, 8) = True
            CWord%%(9, 8) = True
        END IF
    END IF
    'Check for Contiguousness
    Sweeping%% = True
    CWord%%(2, 1) = 1
    WHILE Sweeping%%
        Sweeping%% = False
        FOR N%% = 2 TO 14 STEP 2
            FOR M%% = 2 TO 14 STEP 2
                IF CWord%%(N%%, M%%) = 0 AND (CWord%%(N%% - 1, M%%) = 1 OR CWord%%(N%% + 1, M%%) = 1 OR CWord%%(N%%, M%% - 1) = 1 OR CWord%%(N%%, M%% + 1) = 1) THEN
                    Sweeping%% = True
                    CWord%%(N%%, M%%) = 1
                    IF CWord%%(N%% - 1, M%%) = 0 THEN CWord%%(N%% - 1, M%%) = 1
                    IF CWord%%(N%% + 1, M%%) = 0 THEN CWord%%(N%% + 1, M%%) = 1
                    IF CWord%%(N%%, M%% - 1) = 0 THEN CWord%%(N%%, M%% - 1) = 1
                    IF CWord%%(N%%, M%% + 1) = 0 THEN CWord%%(N%%, M%% + 1) = 1
                END IF
            NEXT M%%
        NEXT N%%
    WEND
    Contiguous%% = True
    M%% = 2
    N%% = 2
    WHILE Contiguous%% AND N%% <= 14 AND M%% <= 14
        IF CWord%%(N%%, M%%) = 0 THEN Contiguous%% = False
        N%% = N%% + 2
        IF N%% > 14 THEN
            N%% = 2
            M%% = M%% + 2
        END IF
    WEND
    'Copy Grid (if contiguous)
    IF Contiguous%% THEN
        REDIM XWord%%(16, 16), TWords%%(10, 1), AcrossDown%%(1, 10, 24, 1)
        NoWords%% = 0
        IF RND < 0.5 THEN
            FOR M%% = 0 TO 16
                FOR N%% = 0 TO 16
                    IF CWord%%(N%%, M%%) = 1 THEN
                        XWord%%(N%%, M%%) = False
                    ELSE
                        XWord%%(N%%, M%%) = True
                    END IF
                NEXT N%%
            NEXT M%%
        ELSE
            FOR M%% = 0 TO 16
                FOR N%% = 0 TO 16
                    IF CWord%%(16 - N%%, M%%) = 1 THEN
                        XWord%%(N%%, M%%) = False
                    ELSE
                        XWord%%(N%%, M%%) = True
                    END IF
                NEXT N%%
            NEXT M%%
        END IF
        'Find the positions where the words can be placed and how they are classified
        FOR N%% = 1 TO 14
            FOR M%% = 1 TO 14
                'Across & Down
                FOR D%% = 0 TO 1
                    IF NOT XWord%%(N%%, M%%) AND NOT XWord%%(N%% + Orient%%(D%%, 0), M%% + Orient%%(D%%, 1)) AND XWord%%(N%% - Orient%%(D%%, 0), M%% - Orient%%(D%%, 1)) THEN
                        WordEnd%% = False
                        K%% = 4
                        WHILE NOT WordEnd%%
                            IF XWord%%(N%% + K%% * Orient%%(D%%, 0), M%% + K%% * Orient%%(D%%, 1)) THEN
                                WordEnd%% = True
                            ELSE
                                K%% = K%% + 1
                            END IF
                        WEND
                        TWords%%(K%%, D%%) = TWords%%(K%%, D%%) + 1
                        AcrossDown%%(D%%, K%%, TWords%%(K%%, D%%), 0) = N%%
                        AcrossDown%%(D%%, K%%, TWords%%(K%%, D%%), 1) = M%%
                        NoWords%% = NoWords%% + 1
                    END IF
                NEXT D%%
            NEXT M%%
        NEXT N%%
        'Place Words in Grid Until No Cross-matches
        CanFill%% = True
        WordCount%% = 0
        REDIM GW(NoWords%%) AS _MEM 'Replaces REDIM GridWords$(NoWords%%)
        FOR P%% = 0 TO NoWords%%
            GW(P%%) = _MEMNEW(4) 'Seems to need this default size for corectly REDIMming
        NEXT P%%
        WHILE WordCount%% < NoWords%% AND CanFill%%
            FOR Index%% = 0 TO 6 'Cackhanded way to check if word starts here
                K%% = FillOrder%%(Index%%)
                K1%% = K%% - 1
                D%% = 0
                WHILE D%% <= 1 AND CanFill%%
                    WHILE TWords%%(K%%, D%%) > 0 AND CanFill%% 'Across&Down
                        L%% = TWords%%(K%%, D%%)
                        N%% = AcrossDown%%(D%%, K%%, L%%, 0)
                        M%% = AcrossDown%%(D%%, K%%, L%%, 1)
                        Crossed%% = False
                        GotBlanks%% = False
                        REDIM EWord%%(K1%%)
                        FOR P%% = 0 TO K1%%
                            IF XWord%%(N%% + P%% * Orient%%(D%%, 0), M%% + P%% * Orient%%(D%%, 1)) > 0 THEN
                                Crossed%% = True
                                EWord%%(P%%) = XWord%%(N%% + P%% * Orient%%(D%%, 0), M%% + P%% * Orient%%(D%%, 1))
                            ELSE
                                GotBlanks%% = True
                                EWord%%(P%%) = 42
                            END IF
                        NEXT P%%
                        IF GotBlanks%% THEN
                            'Insert Word if possible
                            DIM MInWord AS _MEM
                            MInWord = _MEMNEW(K%%)
                            NoTries& = 0
                            CanFill%% = False
                            WHILE NoTries& < MaxTries& AND NOT CanFill%%
                                GoodMidEnd%% = False
                                WHILE NOT GoodMidEnd%%
                                    'Check Middle&End Cross Letters
                                    GoodMidEnd%% = True
                                    _MEMCOPY MDict(K%% - 4), MDict(K%% - 4).OFFSET + K%% * INT(RND * (_MEMGET(MNoWords(K%% - 4), MNoWords(K%% - 4).OFFSET, _UNSIGNED LONG))), K%% TO MInWord, MInWord.OFFSET
                                    'Other methods to replace INSTR() are slower: See Trial 2C (Is it quicker with or without mid/end exclusion search?)
                                    P%% = 0
                                    WHILE P%% <= K1%% AND GoodMidEnd%%
                                        P1%% = N%% + P%% * Orient%%(D%%, 0)
                                        P2%% = M%% + P%% * Orient%%(D%%, 1)
                                        P3%% = P1%% - 1 * Orient%%(D%%, 1)
                                        P4%% = P2%% - 1 * Orient%%(D%%, 0)
                                        P5%% = P1%% + 1 * Orient%%(D%%, 1)
                                        P6%% = P2%% + 1 * Orient%%(D%%, 0)
                                        W$ = CHR$(_MEMGET(MInWord, MInWord.OFFSET + P%%, _UNSIGNED _BYTE))
                                        IF XWord%%(P1%%, P2%%) = 0 AND XWord%%(P3%%, P4%%) >= 0 AND XWord%%(P5%%, P6%%) >= 0 AND INSTR(NonMid$, W$) > 0 THEN
                                            GoodMidEnd%% = False
                                        ELSEIF XWord%%(P1%%, P2%%) = 0 AND XWord%%(P3%%, P4%%) >= 0 AND XWord%%(P5%%, P6%%) = -1 AND INSTR(NonEnd$, W$) > 0 THEN
                                            GoodMidEnd%% = False
                                        END IF
                                        P%% = P%% + 1
                                    WEND
                                    'Check if word exists in grid already
                                    IF WordCount%% > 0 AND GoodMidEnd%% THEN
                                        P%% = 1
                                        WHILE P%% <= WordCount%% AND GoodMidEnd%%
                                            'Replaces IF Wordy$ = GridWords$(P%%) THEN GoodMidEnd%% = False
                                            GoodMidEnd%% = MemEqu%%(GW(P%%), MInWord)
                                            P%% = P%% + 1
                                        WEND
                                    END IF
                                WEND
                                'Check the new word fits existing crossing words
                                CanFill%% = True
                                P%% = 0
                                WHILE CanFill%% AND P%% < K%%
                                    IF EWord%%(P%%) <> 42 AND EWord%%(P%%) <> _MEMGET(MInWord, MInWord.OFFSET + P%%, _UNSIGNED _BYTE) THEN
                                        CanFill%% = False
                                    ELSE
                                        P%% = P%% + 1
                                    END IF
                                WEND
                                IF CanFill%% THEN
                                    FOR P%% = 0 TO K1%%
                                        XWord%%(N%% + P%% * Orient%%(D%%, 0), M%% + P%% * Orient%%(D%%, 1)) = _MEMGET(MInWord, MInWord.OFFSET + P%%, _UNSIGNED _BYTE)
                                        'Don't print as we go in this version
                                    NEXT P%%
                                    WordCount%% = WordCount%% + 1
                                    GW(WordCount%%) = _MEMNEW(MInWord.SIZE) 'Replaces  GridWords$(WordCount%%) = Wordy$
                                    _MEMCOPY MInWord, MInWord.OFFSET, K%% TO GW(WordCount%%), GW(WordCount%%).OFFSET
                                    TWords%%(K%%, D%%) = TWords%%(K%%, D%%) - 1
                                ELSE
                                    NoTries& = NoTries& + 1
                                END IF
                            WEND
                            _MEMFREE MInWord
                        ELSE
                            TWords%%(K%%, D%%) = TWords%%(K%%, D%%) - 1 'Index TWords%%(K%%, D%%) if not GotBlanks%% (cf Trial 2 & previous)
                        END IF
                    WEND
                    D%% = D%% + 1
                WEND
            NEXT Index%%
        WEND
        'It has been demonstrated that  GW() is correctly REDIMed each renewal
        _MEMFREE GW()
        IF NOT CanFill%% THEN
            IF TIMER > Start! + 0.5 THEN
                PRINT ".";
                Start! = TIMER
            END IF
        ELSE
            'Completed grid displayed
            COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
            CLS
            FOR N%% = 0 TO 15
                LINE (10, N%% * 52 + 10)-(790, N%% * 52 + 10)
                LINE (N%% * 52 + 10, 10)-(N%% * 52 + 10, 790)
            NEXT N%%
            FOR N%% = 1 TO 15
                FOR M%% = 1 TO 15
                    IF XWord%%(N%%, M%%) = -1 THEN
                        LINE ((N%% - 1) * 52 + 10, (M%% - 1) * 52 + 10)-(N%% * 52 + 10, M%% * 52 + 10), , BF
                    ELSEIF XWord%%(N%%, M%%) > 0 THEN
                        _PUTIMAGE ((N%% - 1) * 52 + 22, (M%% - 1) * 52 + 22), LesLettres&(XWord%%(N%%, M%%) - 64)
                    END IF
                NEXT M%%
            NEXT N%%
            'Use up stray keypresses, display completed grid and/or wait for keypress
            WHILE INKEY$ <> ""
            WEND
            k$ = ""
            WHILE k$ = ""
                k$ = INKEY$
                _LIMIT 30
            WEND
            IF k$ <> "" THEN
                IF ASC(k$) = 27 THEN
                    DoXWord%% = False
                ELSE
                    COLOR _RGB32(0, 0, 0), _RGB32(255, 255, 255)
                    CLS
                    PRINT "Generating Crossword Grid";
                    Start! = TIMER
                END IF
            END IF
        END IF
    END IF
WEND

_MEMFREE MDict()
_MEMFREE MNoWords()
_MEMFREE MNEnd
_MEMFREE MNMid
FOR N%% = 0 TO 26
    _FREEIMAGE LesLettres&(N%%)
NEXT N%%

SYSTEM

'This function still takes longer than Word1$ <> Word2$ (see Trial 2D), but does not need conversion to String
FUNCTION MemEqu%% (G AS _MEM, W AS _MEM)
    IF W.SIZE <> G.SIZE THEN
        MemEqu%% = True
    ELSE
        C%% = 0
        MemEqu%% = False
        WHILE C%% < W.SIZE AND NOT MemEqu%%
            IF _MEMGET(W, W.OFFSET + C%%, _UNSIGNED _BYTE) <> _MEMGET(G, G.OFFSET + C%%, _UNSIGNED _BYTE) THEN
                MemEqu%% = True
            ELSE
                C%% = C%% + 1
            END IF
        WEND
    END IF
END FUNCTION