XProfan

WindowTitle "N-Queens Problem (ab 11x11 viel Geduld nötig!)"
'https://rosettacode.org/wiki/N-queens_problem#BBC_BASIC
WindowStyle 24
declare sl$,i%,j%,tmp%,co%,num%,Size%,Cell%

Proc Brett

    font 1
    declare i&

    whileloop Size%+4:i&=&Loop:whileloop Size%+4

        if between(i&,3,Size%+2) and between(&Loop,3,Size%+2)

            print if((i&+&Loop) mod 2," ",chr$(176));
            else :print "+";:endif:endwhile:print

        Endwhile

    EndProc

    Nochma:
    CLS:font 2
    print "\n Schachbrett-Breite = ";
    input sl$
    case val(sl$)<4:sl$=8
    Cls
    Size%=val(sl$)
    Cell%=32
    Brett
    locate Size%+6,3:Print " Rechnet ...";
    num%=FNqueens(Size%,Cell%)
    locate Size%+6,3
    font 2
    print " Für ein",size%," x ",size%,"Brett gibt es insgesamt "+STR$(num%)+" Lösungen!"
    beep
    WaitInput
    Goto "Nochma"

    Proc FNqueens :parameters n%,s%

        declare i%,j%,m%,p%,q%,r%,a%[n%],b%[n%],c%[4*n%-2]
        :whileloop n%:i%=&Loop:a%[i%]=i%:endwhile
        m%=0
        i%=1
        j%=0
        r%=2*n%-1

        REPEAT

            dec i%
            inc j%
            p%=0
            q%= -r%

            REPEAT

                inc i%
                c%[p%]=1
                c%[q%+r%]=1
                tmp%=a%[i%]:a%[i%]=a%[j%]:a%[j%]=tmp%
                p%=i%-a%[i%]+n%
                q%=i%+a%[i%]-1
                b%[i%]=j%
                j%=i%+1

            UNTIL (j%>n%) OR c%[p%] OR c%[q%+r%]

            IF c%[p%]=0

                IF c%[q%+r%]=0

                    IF m%=0'.te Lösung darstellen, =m% ... alle

                        Whileloop n%:p%=&Loop

                            LOCATE a%[p%]+2,p%+2
                            PRINT "D";

                        Endwhile

                    ENDIF

                    inc m%

                ENDIF

            ENDIF

            j%=b%[i%]

            WHILE (j%>=n%) AND (i%<>0)

                REPEAT

                    tmp%=a%[i%]:a%[i%]=a%[j%]:a%[j%]=tmp%
                    j%=j%-1

                UNTIL j%<i%

                dec i%
                p%=i%-a%[i%]+n%
                q%=i%+a%[i%]-1
                j%=b%[i%]
                c%[p%]=0
                c%[q%+r%]=0

            ENDWHILE

        UNTIL i%=0

        Return m%

    EndProc