| |
|
|
p.specht
| and again a Rosettacode-task in XProfan transfer: one place one n * n Schachbrett so voller lady-figures, that these not mutual to threaten.
Window Title "N-Queens trouble (ex 11x11 plenty patience necessary!)"
'https://rosettacode.org/wiki/n-queens_problem#BBC_BASIC
Window Style 24
declare sl$,i%,j%,tmp%,co%,num%,Size%,Cell%
Proc shelf
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-wide = ";
input sl$
case val(sl$)<4:sl$=8
Cls
Size%=val(sl$)
Cell%=32
shelf
locate Size%+6,3:Print " Rechnet ...";
num%=FNqueens(Size%,Cell%)
locate Size%+6,3
font 2
print " for ein",size%," x ",size%,"Brett there altogether "+STR$(num%)+" Solutions!"
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'.th Solution present, =m% ... any
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
|
|
|
| XProfan 11Computer: Gerät, daß es in Mikrosekunden erlaubt, 50.000 Fehler zu machen, zB 'daß' statt 'das'... | 05/29/21 ▲ |
|
|
|