XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Labyrinth erstellen
declare x%,y%,x3%,y3%,l%[102,74],ly%,xx%[3],yy%[3],zz%,zz%[3],st%,stx%[1800],sty%[1800],stx%,sty%
declare titsik$

proc push  Stack

    stx%[st%]=x%
    sty%[st%]=y%
    inc st%

endproc

proc pull  Stack

    dec st%
    x%=stx%[st%]
    y%=sty%[st%]

endproc

proc findway  Anzahl der möglichen Richtungen ermitteln

    zz%=0

    whileloop 0,3

        casenot l%[x%+xx%[&loop]*2,y%+yy%[&loop]*2]:continue
        zz%[zz%]=&loop
        inc zz%

    endwhile

endproc

proc drawpath  Einen Pfad zeichnen, bis kein Platz mehr ist

    findway

    while zz%

        push
        zz%=zz%[rnd(zz%)]
        add x%,xx%[zz%]
        add y%,yy%[zz%]
        l%[x%,y%]=0
        add x%,xx%[zz%]
        add y%,yy%[zz%]
        l%[x%,y%]=0
        findway

    endwhile

endproc

proc Level

    parameters lxx1%,lyy1%
    declare lxx2%,lyy2%
    SetText %HWnd,Berechne Labyrinth ...
    lxx2%=lxx1%*2+1                Größe berechnen
    lyy2%=lyy1%*2+1
    clear l%[]                     Überall Wände setzen

    whileloop 1,lyy2%

        y%=&loop

        whileloop 1,lxx2%

            x%=&loop
            l%[x%,y%]=1

        endwhile

    endwhile

    st%=0                          Labyrinth generieren
    x%=rnd(lxx1%)*2+2
    y%=rnd(lyy1%)*2+2
    l%[x%,y%]=0
    drawpath

    while st%

        pull
        drawpath

    endwhile

    l%[1,rnd(lyy1%)*2+2]=0         Startposition (irgendwo ganz links)
    l%[lxx2%,rnd(lyy1%)*2+2]=0     Endposition (irgendwo ganz rechts)
    Labyrinth zeichnen:
    cls
    SetText %HWnd,Zeichne Labyrinth ...

    whileloop 1,73

        y%=&loop

        whileloop 1,101

            x%=&loop
            casenot l%[x%,y%]:continue
            x3%=sub(mul(x%,10),6)
            y3%=sub(mul(y%,10),4)
            usepen 0,1,0
            usebrush 1,8355711
            rectangle x3%,y3%-add(x3%,10),add(y3%,10)
            usepen 0,1,8355711
            case l%[x%,sub(y%,1)]:line add(x3%,1),y3%-add(x3%,9),y3%
            case l%[x%,add(y%,1)]:line add(x3%,1),add(y3%,9)-add(x3%,9),add(y3%,9)
            case l%[sub(x%,1),y%]:line x3%,add(y3%,1)-x3%,add(y3%,9)
            case l%[add(x%,1),y%]:line add(x3%,9),add(y3%,1)-add(x3%,9),add(y3%,9)

        endwhile

    endwhile

    SetText %HWnd,titsik$

endproc

windowstyle $1A
window 0,0-%maxx,%maxy
settruecolor 1
titsik$ = GetText$(%HWnd)
Richtungen definieren
yy%[0]=-1        0 = hoch
yy%[1]=1         1 = runter
xx%[2]=-1        2 = links
xx%[3]=1         3 = rechts
randomize

whilenot scankey(27)

    Level rnd(50)+1,rnd(36)+1
    waitinput

endwhile

WindowTitle "Einfacher Labyrinth-Generator"
'Q: https://rosettacode.org/wiki/Maze_generation#BASIC
WindowStyle 24:Window 0,0-%maxx,%maxy
declare width%,height%,x%,y%,currentx%,currenty%,done%
declare oldx%,oldy%,i%,wall$,maze$[190,56]
RANDOMIZE
REM must be even:
height%=10' 56 'max '6 min
width% =16'190 'max '6 min
wall$ = chr$(219)'= full block with font 1 , or "#","*",...
INIT:
::rem experimental:
::height%=height%+2:width%=width%+6
CLS rgb(180+rnd(76),180+rnd(76),180+rnd(76))
font 1
REM make array and fill

whileloop 0,width%:x%=&Loop

    whileloop 0,height%:y%=&Loop

        maze$[x%,y%]=wall$

    endwhile

endwhile

REM initial start location
currentx%=INT(RND()*(width%-1))
currenty%=INT(RND()*(height%-1))
REM value must be odd
casenot currentx% MOD 2:inc currentx%
casenot currenty% MOD 2:inc currenty%
maze$[currentx%,currenty%]=" "
::color 0,15:Draw_Maze
REM generate maze
done%=0

WHILENOT done%

    whileloop 0,99:i%=&Loop

        oldx%=currentx%
        oldy%=currenty%
        REM move in random direction

        SELECT RND(4)

            CASEof 0

            case (currentx%+2)<width%:currentx%=currentx%+2

            CASEof 1

            case (currenty%+2)<height%:currenty%=currenty%+2

            CASEof 2

            case (currentx%-2)>0:currentx%=currentx%-2

            CASEof 3

            case (currenty%-2)>0:currenty%=currenty%-2

        ENDSELECT

        REM if cell is unvisited then connect it

        IF maze$[currentx%,currenty%]=wall$

            maze$[currentx%,currenty%]=" "
            maze$[(currentx%+oldx%)\2,(currenty%+oldy%)\2]=" "
            ::locate currenty%+1,currentx%+1:print " ";
            ::locate (currenty%+oldy%+2)\2,(currentx%+oldx%+2)\2:print " ";

        ENDIF

    endwhile

    REM check if all cells are visited
    done% = 1

    whileloop 1,width%-1,2:x%=&Loop

        whileloop 1,height%-1,2:y%=&Loop

            case maze$[x%,y%]=wall$:done%=0

        endwhile

    endwhile

endwhile

rem Mache Eingang und Ausgang:
maze$[0,1+2*(rnd(height%-1)\2)]=" "
maze$[width%,1+2*(rnd(height%-1)\2)]=" "
::color rnd(15),15:Draw_Maze
waitinput
Goto "INIT"

proc Draw_Maze

    locate 1,1

    whileloop 0,height%:y%=&Loop

        whileloop 0,width%:x%=&Loop

            PRINT maze$[x%,y%];

        endwhile

        PRINT

    endwhile

endproc

PROGEND