Kirjautuminen

Haku

Tehtävät

Koodit: QB: Labyrintti

Kirjoittaja: J.J.

Kirjoitettu: 03.05.2005 – 03.05.2005

Tagit: koodi näytille, vinkki

Tämä ohjelma generoi labyrintin, jossa on ainoastaan yksi ratkaisu. Umpikujat ovat toisinaan todella pitkiä, tai mitättömän lyhyitä, mutta en enään jaksanut alkaa miettiä millä sitä saisi yksinkertaisesti säädettyä.

Keltainen ruutu tarkoittaa aloituspistettä ja punainen loppua, joka on sijoitettu aloituspisteestä niin kauaksi kuin mahdollista (tämä lienee helppo muuttaa jos kokee sen tarpeelliseksi).

Edit: Lisäsin muunnellun version vanhasta ohjelmasta. Uusi versio tekee klassisemman näköisiä ja ainakin omasta mielestäni parempia labyrintteja. Lisäksi ohjelma kopioi labyrintista tiedoston (jos siitä jollekin on hyötyä).

' LABY.BAS	-JJP

DECLARE SUB Generate ()
DECLARE SUB DisplayMaze ()
DECLARE FUNCTION IsFloor% (x%, y%)
DECLARE FUNCTION Peruuta% (x%, y%)
DECLARE FUNCTION Rand% (a%, b%)
DECLARE SUB Rotate (d%)
DECLARE SUB Siirry (x%, y%, d%)
DECLARE FUNCTION VoikoPiirtaa% (x%, y%, d%)
DEFINT A-Z
CONST sizeX = 80
CONST sizeY = 50

CONST Seina = 1
CONST Lattia = 7
CONST Alku = 14
CONST Loppu = 4

CONST TempTile = -1

CLS
SCREEN 13
DIM SHARED Maze(1 TO sizeX, 1 TO sizeY)

RANDOMIZE TIMER
aika! = TIMER
Generate
aika! = TIMER - aika!
DisplayMaze
PRINT "Aikaa labyrintin luontiin kului:"; aika!; "s."

SUB DisplayMaze
tx = FIX(320 / sizeX)
ty = FIX(200 / sizeY)
IF tx < ty THEN ty = tx ELSE tx = ty
FOR x = 1 TO sizeX
        FOR y = 1 TO sizeY
        LINE (x * tx - tx, y * ty - ty)-(x * tx, y * ty), Maze(x, y), BF
        NEXT y
NEXT x
DO UNTIL NOT INKEY$ = "": LOOP
END SUB

SUB Generate
FOR x = 1 TO sizeX
        FOR y = 1 TO sizeY
        Maze(x, y) = Seina
        NEXT y
NEXT x
Matka = 0
Ennatys = 0
startX = Rand(2, sizeX - 1)
startY = Rand(2, sizeY - 1)
x = startX
y = startY
Maze(startX, startY) = TempTile

DO
d = Rand(1, 2)
IF Rand(0, 1) THEN d = d * -1
FOR Kokeile = 1 TO 4
        IF VoikoPiirtaa(x, y, d) THEN
                Siirry x, y, d
                Matka = Matka + 1
                EiOnnistu = 0
                EXIT FOR
               ELSE
                EiOnnistu = 1
                Rotate d
        END IF
NEXT Kokeile

IF EiOnnistu THEN
                IF Matka > Ennatys THEN
                        Ennatys = Matka
                        EnnX = x
                        EnnY = y
                END IF
                IF Peruuta(x, y) = 0 THEN
                        Maze(startX, startY) = Alku
                        Maze(EnnX, EnnY) = Loppu
                        EXIT SUB
                END IF
                Matka = Matka - 1
END IF
LOOP
END SUB

FUNCTION IsFloor (x, y)
IF Maze(x, y) = Lattia OR Maze(x, y) = TempTile THEN IsFloor = 1 ELSE IsFloor = 0
END FUNCTION

FUNCTION Peruuta (x, y)
Maze(x, y) = Lattia
IF Maze(x - 1, y) = TempTile THEN x = x - 1: Peruuta = 1: EXIT FUNCTION
IF Maze(x + 1, y) = TempTile THEN x = x + 1: Peruuta = 1: EXIT FUNCTION
IF Maze(x, y + 1) = TempTile THEN y = y + 1: Peruuta = 1: EXIT FUNCTION
IF Maze(x, y - 1) = TempTile THEN y = y - 1: Peruuta = 1: EXIT FUNCTION
Peruuta = 0
END FUNCTION

FUNCTION Rand (a, b)
IF a > b THEN
        High = a + 1
        Low = b
       ELSE
        High = b + 1
        Low = a
END IF
Dif = High - Low
Rand = INT(RND * Dif) + Low
END FUNCTION

SUB Rotate (d)
SELECT CASE (d)
        CASE 1
                d = -1
                EXIT SUB
        CASE -1
                d = 2
                EXIT SUB
        CASE 2
                d = -2
                EXIT SUB
        CASE -2
                d = 1
                EXIT SUB
END SELECT
END SUB

SUB Siirry (x, y, d)
SELECT CASE (d)
        CASE -1
                y = y - 1
        CASE 1
                y = y + 1
        CASE -2
                x = x - 1
        CASE 2
                x = x + 1
END SELECT
Maze(x, y) = TempTile
END SUB

FUNCTION VoikoPiirtaa (x, y, d)

SELECT CASE (d)
        CASE 1
                IF y + 1 >= sizeY THEN VoikoPiirtaa = 0: EXIT FUNCTION
                FOR scan = -1 TO 1
                        IF IsFloor(x + scan, y + 2) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                        IF IsFloor(x + scan, y + 1) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                NEXT scan
        CASE -1
                IF y - 1 <= 1 THEN VoikoPiirtaa = 0: EXIT FUNCTION
                FOR scan = -1 TO 1
                        IF IsFloor(x + scan, y - 2) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                        IF IsFloor(x + scan, y - 1) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                NEXT scan
        CASE 2
                IF x + 1 >= sizeX THEN VoikoPiirtaa = 0: EXIT FUNCTION
                FOR scan = -1 TO 1
                        IF IsFloor(x + 2, y + scan) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                        IF IsFloor(x + 1, y + scan) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                NEXT scan
        CASE -2
                IF x - 1 <= 1 THEN VoikoPiirtaa = 0: EXIT FUNCTION
                FOR scan = -1 TO 1
                        IF IsFloor(x - 2, y + scan) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                        IF IsFloor(x - 1, y + scan) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                NEXT scan
END SELECT
VoikoPiirtaa = 1
END FUNCTION
' LABY.BAS v2 -JJP

DECLARE SUB KirjoitaTiedosto ()
DECLARE SUB Generate ()
DECLARE SUB DisplayMaze ()
DECLARE FUNCTION IsFloor% (x%, y%)
DECLARE FUNCTION Peruuta% (x%, y%)
DECLARE FUNCTION Rand% (a%, b%)
DECLARE SUB Rotate (d%)
DECLARE SUB Siirry (x%, y%, d%)
DECLARE FUNCTION VoikoPiirtaa% (x%, y%, d%)
DEFINT A-Z
CONST sizeX = 81
CONST sizeY = 61

CONST Seina = 1
CONST Lattia = 0
CONST Alku = 14
CONST Loppu = 4
CONST TempTile = -1

CONST Tiedosto$ = "LABY.DAT"


CLS
SCREEN 12
DIM SHARED Maze(1 TO sizeX, 1 TO sizeY)

RANDOMIZE TIMER
aika! = TIMER
Generate
aika! = TIMER - aika!
DisplayMaze
PRINT "Aikaa labyrintin luontiin kului:"; aika!; "s."
KirjoitaTiedosto
END

SUB DisplayMaze
tx = FIX(640 / sizeX)
ty = FIX(480 / sizeY)
IF tx < ty THEN ty = tx ELSE tx = ty
FOR x = 1 TO sizeX
        FOR y = 1 TO sizeY
        LINE (x * tx - tx, y * ty - ty)-(x * tx, y * ty), Maze(x, y), BF
        NEXT y
NEXT x
DO UNTIL NOT INKEY$ = "": LOOP
END SUB

SUB Generate
FOR x = 1 TO sizeX
        FOR y = 1 TO sizeY
        Maze(x, y) = Seina
        NEXT y
NEXT x
Matka = 0
Ennatys = 0
startX = Rand(1, FIX((sizeX - 1) / 2)) * 2
startY = Rand(1, FIX((sizeY - 1) / 2)) * 2

x = startX
y = startY
Maze(startX, startY) = TempTile

DO
d = Rand(1, 2)
IF Rand(0, 1) THEN d = d * -1
FOR Kokeile = 1 TO 4
        IF VoikoPiirtaa(x, y, d) THEN
                Siirry x, y, d
                Matka = Matka + 1
                EiOnnistu = 0
                EXIT FOR
               ELSE
                EiOnnistu = 1
                Rotate d
        END IF
NEXT Kokeile

IF EiOnnistu THEN
                IF Matka > Ennatys THEN
                        Ennatys = Matka
                        EnnX = x
                        EnnY = y
                END IF
                IF Peruuta(x, y) = 0 THEN
                        Maze(startX, startY) = Alku
                        Maze(EnnX, EnnY) = Loppu
                        EXIT SUB
                END IF
                Matka = Matka - 1
END IF
LOOP
END SUB

FUNCTION IsFloor (x, y)
IF Maze(x, y) = Lattia OR Maze(x, y) = TempTile THEN IsFloor = 1 ELSE IsFloor = 0
END FUNCTION

SUB KirjoitaTiedosto
OPEN Tiedosto$ FOR OUTPUT AS #1
FOR y = 1 TO sizeY
        rivi$ = ""
        FOR x = 1 TO sizeX
        SELECT CASE (Maze(x, y))
                CASE Seina
                        rivi$ = rivi$ + "Û"
                CASE Lattia
                        rivi$ = rivi$ + "."
                CASE Alku
                        rivi$ = rivi$ + "A"
                CASE Loppu
                        rivi$ = rivi$ + "L"
        END SELECT
        NEXT x
        PRINT #1, rivi$
NEXT y
CLOSE #1
END SUB

FUNCTION Peruuta (x, y)
Maze(x, y) = Lattia
IF Maze(x - 1, y) = TempTile THEN Maze(x - 1, y) = Lattia: x = x - 2: Peruuta = 1: EXIT FUNCTION
IF Maze(x + 1, y) = TempTile THEN Maze(x + 1, y) = Lattia: x = x + 2: Peruuta = 1: EXIT FUNCTION
IF Maze(x, y + 1) = TempTile THEN Maze(x, y + 1) = Lattia: y = y + 2: Peruuta = 1: EXIT FUNCTION
IF Maze(x, y - 1) = TempTile THEN Maze(x, y - 1) = Lattia: y = y - 2: Peruuta = 1: EXIT FUNCTION
Peruuta = 0
END FUNCTION

FUNCTION Rand (a, b)
IF a > b THEN
        High = a + 1
        Low = b
       ELSE
        High = b + 1
        Low = a
END IF
Dif = High - Low
Rand = INT(RND * Dif) + Low
END FUNCTION

SUB Rotate (d)
SELECT CASE (d)
        CASE 1
                d = -1
                EXIT SUB
        CASE -1
                d = 2
                EXIT SUB
        CASE 2
                d = -2
                EXIT SUB
        CASE -2
                d = 1
                EXIT SUB
END SELECT
END SUB

SUB Siirry (x, y, d)
SELECT CASE (d)
        CASE -1
                Maze(x, y - 1) = TempTile
                y = y - 2
        CASE 1
                Maze(x, y + 1) = TempTile
                y = y + 2
        CASE -2
                Maze(x - 1, y) = TempTile
                x = x - 2
        CASE 2
                Maze(x + 1, y) = TempTile
                x = x + 2
END SELECT
Maze(x, y) = TempTile
END SUB

FUNCTION VoikoPiirtaa (x, y, d)

SELECT CASE (d)
        CASE 1
                IF y + 2 >= sizeY THEN VoikoPiirtaa = 0: EXIT FUNCTION
                FOR scan = -1 TO 1
                        IF IsFloor(x + scan, y + 3) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                        IF IsFloor(x + scan, y + 2) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                NEXT scan
        CASE -1
                IF y - 2 <= 1 THEN VoikoPiirtaa = 0: EXIT FUNCTION
                FOR scan = -1 TO 1
                        IF IsFloor(x + scan, y - 3) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                        IF IsFloor(x + scan, y - 2) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                NEXT scan
        CASE 2
                IF x + 2 >= sizeX THEN VoikoPiirtaa = 0: EXIT FUNCTION
                FOR scan = -1 TO 1
                        IF IsFloor(x + 3, y + scan) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                        IF IsFloor(x + 2, y + scan) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                NEXT scan
        CASE -2
                IF x - 2 <= 1 THEN VoikoPiirtaa = 0: EXIT FUNCTION
                FOR scan = -1 TO 1
                        IF IsFloor(x - 3, y + scan) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                        IF IsFloor(x - 2, y + scan) THEN VoikoPiirtaa = 0: EXIT FUNCTION
                NEXT scan
END SELECT
VoikoPiirtaa = 1
END FUNCTION

Kommentit

T.M. [05.05.2005 16:29:06]

#

Outo, mutta toimii hienosti :o
Värit vaihdoin toisinpäin, koska tuntui siltä että seinä oli aluetta josta pystyi kulkea.

hunajavohveli [05.05.2005 17:02:08]

#

Heh, minäkin katsoin katsoin ensin väärinpäin seinää ja lattiaa. :) Algoritmi generoi kivoja labyrintteja.

mikeful [07.05.2005 01:34:21]

#

Yritin joskus thedä vastaavaa kun kaikenlaisten generointisysteemit kiinostaa, mutta ei siitä oikein tullut mitään. Nyt kuitenkin olen saanut yhden haaveeni vähän valmiimmaksi tekemällä Infinite Arenaan satunnaiskarttageneraattorin.

baabloo [20.05.2005 15:58:33]

#

Minulla loi tyhmän labyrintin, josta pääsi helposti pisteestä a pisteeseen b. Ne oli vierekkäin eikä välissä ollut seinää.

siansaksamies [25.05.2005 17:03:30]

#

Tohon kun viittisit vielä soveltaa tulostusmahdollisuuden, ettei tarviis koko ajan ruudun edessä kököttää. Onhan Print Screen-toiminto tietysti keksitty, mutta taas jos haluaa tulostaa isomman erän, niin huomaat kyllä homman hitauden. Toinen ehdotus olisi ukon luonti labyrinttiin.
Muuten kyllä ihan simppeli.

jalski [29.10.2026 07:52:52]

#

Tässä 8th ohjelmointikielellä toteutettu koodi satunnaisen labyrintin generointia varten. tallentaa PNG-kuvan labyrintistä, jossa on myös piirrettynä lyhin reitti vasemmasta ylänurkasta oikeaan alanurkkaan.

\
\ Simple maze image generator
\
"maze.png" constant FNAME

10 constant distance

20 constant path-rows
20 constant path-cols
path-rows path-cols n:* constant num-path-nodes

path-rows n:1+ constant wall-rows
path-cols n:1+ constant wall-cols
wall-rows wall-cols n:* constant num-wall-nodes

nullvar path-graph
nullvar path-map
nullvar wall-map

nullvar route

nullvar visited
nullvar frontier

: generate-wall-nodes
  ( wall-cols n:/mod 2 a:close distance 2 n:* n:* ) 0 num-wall-nodes n:1- a:generate ;

: generate-path-nodes
  ( path-cols n:/mod 2 a:close 2 n:* 1 n:+ distance n:* ) 0 num-path-nodes n:1- a:generate ;

: build-grid-edges \ rows nodes -- nodes edges
  \ build edge list
  ' noop 0 2 pick a:_len n:1- a:generate
  rot a:split dup ( a:open ( 0.0 0 4 a:close ) a:2map ) 2 1 a:map+ a:squash
  swap ( ( [0.0, 0] a:+ ) 2 1 a:map+ ) a:map a:squash a:+ ;

: build-wall-map
  wall-rows generate-wall-nodes build-grid-edges ( [0,1] a:_@ a:@ ) a:map nip dup
  ( a:open n:+ 2 n:/ >s ) a:map swap m:zip ;

: build-path-map  \ array-of-edges -- m
  dup>r ( [0,1] a:_@ a:@ ) a:map nip
  ( a:open n:+ 2 n:/ >s ) a:map r> m:zip ;

: generate-path-graph+path-map  \ -- gr m
  path-rows generate-path-nodes build-grid-edges 2 a:close ["nodes", "edges"] swap m:zip gr:new
  gr:nodes over gr:edges nip build-path-map ;

: generate-maze
  m:new visited !
  a:new frontier !

  path-graph @ gr:nodes a:_len rand-pcg swap n:mod visited @ over dup m:! drop
  frontier @ swap a:_push
  repeat
    frontier @ a:len !if
      drop break
    else
      a:pop nip tuck gr:neighbors ( visited @ swap m:exists? nip not ) a:filter a:len !if
        drop nip
      else
        rot dup>r frontier @ swap a:_push a:len rand-pcg swap n:mod a:_@ tuck r> 2 a:close
        swap gr:nodes rot a:_@ a:open n:+ 2 n:/ >s wall-map @ swap m:- drop
        swap frontier @ over a:_push visited @ swap dup m:! drop
      then
    then
  again

  path-map @ wall-map @ m:keys nip m:- m:vals nip
  gr:edges! drop ;


: app:main
  build-wall-map wall-map !
  generate-path-graph+path-map path-map ! path-graph !
  generate-maze

  \ Shortest route from top left node to bottom right node
   path-graph @ gr:nodes tuck a:_len n:1- 0 swap ' n:manhattan-distance gr:search nip a:_@
  ' noop 2 1 a:map+ route !

  FNAME f:rm drop
  wall-cols n:1- distance 2 n:* n:* wall-rows n:1- distance 2 n:* n:* img:new
  "black" img:fill
  wall-map @ m:vals nip ( a:open "white" img:line ) a:each! drop
  route @ ( a:open "red" img:line ) a:each! drop
  FNAME img:>file
  FNAME null f:launch ;

Kirjoita kommentti

Muista lukea kirjoitusohjeet.
Tietoa sivustosta