Deutsch
Quelltexte/ Codesnippets

Erstellen Labyrinth

 

KompilierenMarkierenSeparieren
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

 
16.07.2007  
 




p.specht

Einfacher Labyrinth-Generator
======================
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
 
XProfan 11
Computer: Gerät, daß es in Mikrosekunden erlaubt, 50.000 Fehler zu machen, zB 'daß' statt 'das'...
30.05.2021  
 



Zum Quelltext


Thementitel, max. 100 Zeichen.
 

Systemprofile:

Kein Systemprofil angelegt. [anlegen]

XProfan:

 Beitrag  Schrift  Smilies  ▼ 

Bitte anmelden um einen Beitrag zu verfassen.
 

Themenoptionen

2.963 Betrachtungen

Unbenanntvor 0 min.
Uwe Starke17.11.2023
p.specht21.11.2021
R.Schneider20.11.2021
Uwe Lang20.11.2021
Mehr...

Themeninformationen

Dieses Thema hat 2 Teilnehmer:

p.specht (1x)
unbekannt (1x)


Admins  |  AGB  |  Anwendungen  |  Autoren  |  Chat  |  Datenschutz  |  Download  |  Eingangshalle  |  Hilfe  |  Händlerportal  |  Impressum  |  Mart  |  Schnittstellen  |  SDK  |  Services  |  Spiele  |  Suche  |  Support

Ein Projekt aller XProfaner, die es gibt!


Mein XProfan
Private Nachrichten
Eigenes Ablageforum
Themen-Merkliste
Eigene Beiträge
Eigene Themen
Zwischenablage
Abmelden
 Deutsch English Français Español Italia
Übersetzungen

Datenschutz


Wir verwenden Cookies nur als Session-Cookies wegen der technischen Notwendigkeit und bei uns gibt es keine Cookies von Drittanbietern.

Wenn du hier auf unsere Webseite klickst oder navigierst, stimmst du unserer Erfassung von Informationen in unseren Cookies auf XProfan.Net zu.

Weitere Informationen zu unseren Cookies und dazu, wie du die Kontrolle darüber behältst, findest du in unserer nachfolgenden Datenschutzerklärung.


einverstandenDatenschutzerklärung
Ich möchte keinen Cookie