Maze 2D and 3D

Game development specific discussions.
Post Reply
jepalza
Posts: 149
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

Maze 2D and 3D

Post by jepalza »

Maze 2d:

Code: Select all

' laberinto 2D
option explicit

Declare Sub busca_huecos() 
Declare Sub dibuja_laberinto_2d()
Declare Sub crea_laberinto()

'RANDOMIZE TIMER
SCREEN 20

Dim Shared alto As Integer
Dim Shared ancho As Integer


Dim Shared c As Integer ' contador de huecos libres
Dim Shared f As Integer ' bucles
Dim Shared g As Integer ' contador
Dim Shared h As Integer ' bucles
Dim Shared i As Integer ' bucles
Dim Shared j As Integer ' bucles
Dim Shared r As Integer ' random
Dim Shared t As Integer ' contador
Dim Shared x As Integer ' posicion en el laberinto
Dim Shared y As Integer ' posicion de casillas en el laberinto

Dim Shared a As String

Dim Shared direccion As Integer

'MEDIDAS LABERINTO, minimo 5x5 maximo no importa, ancho siempre impar, alto no importa
ALTO=45
ANCHO=109

Dim Shared laberinto(alto*ancho) As Integer ' almacen para el laberinto al completo


crea_laberinto
dibuja_laberinto_2d
sleep


Sub crea_laberinto()
'----------------------------------------------------
'---- creamos una plantilla laberinto "hueco" -------
'----------------------------------------------------
G=0
' ------------- crea el borde superior
For F=1 To ANCHO
	 LABERINTO(G)=2
	 G=G+1
Next

' ------------- crea las celdas intermedias alternadas
For H=1 To (ALTO-2)/2
	
  ' fila impar, con paredes y huecos alternos
  LABERINTO(G)=2:G=G+1
  For F=1 To (ANCHO-3)/2
 	LABERINTO(G+0)=0 
	LABERINTO(G+1)=1
	G=G+2
  Next
  g=g+1
  LABERINTO(G)=2:g=g+1
  
  ' fila par, pero esta lisa entera (todo pared)
  LABERINTO(G)=2:G=G+1
  For F=1 To ANCHO-2
	 LABERINTO(G)=1
	 G=G+1
  Next
  LABERINTO(G)=2:g=g+1
Next H
g=g-ancho
  LABERINTO(G-1)=4 ' ponemos la salida, ya que estamos en esta casilla
' ------------ cierra el borde inferior y queda creado

For F=1 To ANCHO
	 LABERINTO(G)=2
	 G=G+1
Next

FOR f = 1 TO ALTO STEP 2
 For h = 1 TO ANCHO-1 STEP 2
	Y = ANCHO * f + h
   busca_huecos

   IF C > 0 THEN GoTo nohayposibilidad
   If h = 1 And f = 1 THEN GOTO encontrado
   If h = 1 THEN LABERINTO(Y - ANCHO)= 0
   If h > 1 THEN LABERINTO(Y - 1    )= 0

   'DIBUJA EL CAMINO EN TRAMOS DE 20 PASOS
   encontrado:
   For T = 1 TO 200
	 r=Rnd(1)*3
 	 IF r = 1 THEN r = -1
 	 If r = 2 THEN r = -1*ANCHO
 	 IF r = 0 THEN r = +1
 	 IF r = 3 THEN r = ANCHO
 	 If LABERINTO(Y + r) <> 1 Then GoTo nohaycamino
 	 Y = Y + 2 * r
	 busca_huecos
	 IF C > 0 THEN GoTo nohaycamino
	 LABERINTO (Y - r)= 0
	 GOTO encontrado
	 nohaycamino:
   Next T
   nohayposibilidad: 
 NEXT h
Next f
laberinto(ancho)=3 ' marcamos la entrada en el laberinto, siempre en la casilla 1
x=1:y=1 ' y asignamos las coordenadas de la misma, como casilla de salida

End Sub

Sub busca_huecos()
' depende del proceso "crea_laberinto()"
' CUENTA ESPACIOS ALREDEDOR DE Y
C = 0

 If LABERINTO(Y - ANCHO) = 0 THEN C = C + 1
 If LABERINTO(Y + ANCHO) = 0 THEN C = C + 1
 If LABERINTO(Y - 1    ) = 0 THEN C = C + 1
 If LABERINTO(Y + 1    ) = 0 THEN C = C + 1

End Sub

Sub dibuja_laberinto_2d()
Cls
i=0
For j=0 To alto*ancho
	If laberinto(j)=0 Then a=" "
	If laberinto(j)=1 Then a=Chr$(219) 
	If laberinto(j)=2 then a=Chr$(219) ' para debug, usar este --> a=Chr$(177) 
	If laberinto(j)=3 then a="E"
	If laberinto(j)=4 then a="S" 
	Print A;
   i=i+1:If i=ancho Then i=0:Print
Next j
End Sub

Maze 3d:

Code: Select all

Declare Sub busca_huecos() 
Declare Sub dibuja_laberinto_2d()
Declare Sub dibuja_laberinto_3d(x As Integer, y As Integer, direccion As Integer)
Declare Sub crea_laberinto()
Declare Sub pared_3d(pared As integer)

RANDOMIZE Timer ' para que sea diferente cada vez
SCREEN 20

Dim Shared alto As Integer
Dim Shared ancho As Integer
Dim Shared pared As Integer

Dim Shared b As Integer
Dim Shared c As Integer ' contador de huecos libres
Dim Shared f As Integer ' bucles
Dim Shared g As Integer ' contador
Dim Shared h As Integer ' bucles
Dim Shared i As Integer ' bucles
Dim Shared j As Integer ' bucles
Dim Shared r As Integer ' random
Dim Shared t As Integer ' contador
Dim Shared x As Integer ' posicion en el laberinto
Dim Shared y As Integer ' posicion de casillas en el laberinto
Dim Shared As Integer yori, xori

Dim Shared a As String

Dim Shared direccion As Integer

'MEDIDAS LABERINTO, minimo 5x5 maximo no importa, ancho siempre impar, alto no importa
ALTO=10
ANCHO=15 
Dim Shared laberinto(alto*ancho) As Integer ' almacen para el laberinto al completo

'lee coordenadas de los vectores 3d (para 1024x768, modo 20)
Restore coord3d
Dim Shared coord3d(44,2) As Integer
For f=1 To 44
	Read coord3d(f,1),coord3d(f,2)
Next

'lee coordenadas de las lineas de las paredes (10 izq + 6 cen + 10 der, paredes con 4 vertices cada una)
Restore lineas
Dim Shared lineas3d(26,4) As Integer
For f=1 To 26
	Read lineas3d(f,1),lineas3d(f,2),lineas3d(f,3),lineas3d(f,4)
Next

' direccion incial (1=norte, 2=este, 3=sur, 4=oeste)
direccion=3 ' miramos al sur

crea_laberinto()
x=2:y=2 ' asignamos las coordenadas de inicio

inicio:
	Cls
	dibuja_laberinto_2d()
	xori=x:yori=y ' copia de la posicion
	dibuja_laberinto_3d(x-1,y-1,direccion)' las coord. del 3d empiezan en "0,0", quito 1 para compensar
	Locate 2,40:Print "POS:";x;",";y
	b=GetKey

	If b>255 Then b=b Shr 8:a=Chr(b) Else a=Chr(b)
	
	If a="H" Then 
		If direccion=1 Then y-=1
		If direccion=2 Then x+=1
		If direccion=3 Then y+=1
		If direccion=4 Then x-=1
	EndIf
	If a="P" Then 
		If direccion=1 Then y+=1
		If direccion=2 Then x-=1
		If direccion=3 Then y-=1
		If direccion=4 Then x+=1
	EndIf
	If a="K" Then direccion-=1
	If a="M" Then direccion+=1
	If direccion=0 Then direccion=4
	If direccion=5 Then direccion=1
	
	If a=Chr(27) Then End
GoTo inicio

end

Sub crea_laberinto()
'----------------------------------------------------
'---- creamos una plantilla laberinto "hueco" -------
'----------------------------------------------------
G=0
' ------------- crea el borde superior
For F=1 To ANCHO
	 LABERINTO(G)=2
	 G=G+1
Next

' ------------- crea las celdas intermedias alternadas
For H=1 To (ALTO-2)/2
	
  ' fila impar, con paredes y huecos alternos
  LABERINTO(G)=2:G=G+1
  For F=1 To (ANCHO-3)/2
 	LABERINTO(G+0)=0 
	LABERINTO(G+1)=1
	G=G+2
  Next
  g=g+1
  LABERINTO(G)=2:g=g+1
  
  ' fila par, pero esta lisa entera (todo pared)
  LABERINTO(G)=2:G=G+1
  For F=1 To ANCHO-2
	 LABERINTO(G)=1
	 G=G+1
  Next
  LABERINTO(G)=2:g=g+1
Next H
g=g-ancho
  LABERINTO(G-1)=4 ' ponemos la salida, ya que estamos en esta casilla
' ------------ cierra el borde inferior y queda creado

For F=1 To ANCHO
	 LABERINTO(G)=2
	 G=G+1
Next

FOR f = 1 TO ALTO STEP 2
 For h = 1 TO ANCHO-1 STEP 2
	Y = ANCHO * f + h
   busca_huecos

   IF C > 0 THEN GoTo nohayposibilidad
   If h = 1 And f = 1 THEN GOTO encontrado
   If h = 1 THEN LABERINTO(Y - ANCHO)= 0
   If h > 1 THEN LABERINTO(Y - 1    )= 0

   'DIBUJA EL CAMINO EN TRAMOS DE 20 PASOS
   encontrado:
   For T = 1 TO 200
	 r=Rnd(1)*3
 	 IF r = 1 THEN r = -1
 	 If r = 2 THEN r = -1*ANCHO
 	 IF r = 0 THEN r = +1
 	 IF r = 3 THEN r = ANCHO
 	 If LABERINTO(Y + r) <> 1 Then GoTo nohaycamino
 	 Y = Y + 2 * r
	 busca_huecos
	 IF C > 0 THEN GoTo nohaycamino
	 LABERINTO (Y - r)= 0
	 GOTO encontrado
	 nohaycamino:
   Next T
   nohayposibilidad: 
 NEXT h
Next f
laberinto(ancho)=3 ' marcamos la entrada en el laberinto, siempre en la casilla 1

End Sub

Sub busca_huecos()
' depende del proceso "crea_laberinto()"
' CUENTA ESPACIOS ALREDEDOR DE Y
C = 0

 If LABERINTO(Y - ANCHO) = 0 THEN C = C + 1
 If LABERINTO(Y + ANCHO) = 0 THEN C = C + 1
 If LABERINTO(Y - 1    ) = 0 THEN C = C + 1
 If LABERINTO(Y + 1    ) = 0 THEN C = C + 1

End Sub

Sub dibuja_laberinto_2d()
i=0
For j=0 To alto*ancho
	If laberinto(j)=0 Then a=" "
	If laberinto(j)=1 Then a=Chr(219) 
	If laberinto(j)=2 then a=Chr(219) ' para depuracion, usar este --> a=Chr(177) 
	'If laberinto(j)=3 then a="E"
	If laberinto(j)=4 then a="X" 
	Print A;
   i=i+1:If i=ancho Then i=0:Print
Next j
If Screen(y,x)=65499 Then x=xori:y=yori
If Screen(y,x)<>32 And Screen(y,x)<>65499 Then Print "FIN....":Sleep:end
Locate y,x:Print "*"
End Sub

Sub dibuja_laberinto_3d(x As Integer, y As integer, direccion As Integer)
	Dim posicion As Integer
	
	posicion=y*ancho+x ' posicion absoluta segun x e y, dentro de la matriz
	
   ' dibujamos el laberinto 3d, en forma de 15 paredes (1-izq, 1-cen, 1-der y 5 profundidades 3d)
   ' primero, dibujamos el centro, y obtenemos la profundidad a la que se ha parado (de 5 a 0)
   ' y con esa proundidad (guardada en "B"), dibujamos el resto, parando en el mismo sitio
   ' esto lo hacemos por igual para cada direccion que miramos
   
   ' -------------------------------------------
    If direccion=1 Then ' miramos al norte
   	h=0
		For g=11 To 16
			If laberinto(posicion-(ancho*h)) Then pared_3d(g):g=17
			h=h+1
		Next
		b=(6-h)*2
		
      h=0
		For g=1 To 9-b Step 2
			If laberinto(posicion-1-(ancho*h)) Then pared_3d(g) Else pared_3d(g+1)
			h=h+1
		Next
		
		h=0
		For g=17 To 25-b Step 2
			If laberinto(posicion+1-(ancho*h)) Then pared_3d(g) Else pared_3d(g+1)
			h=h+1
		Next
   End If

' -------------------------------------------
   If direccion=2 Then ' miramos al este
   	h=0
		For g=11 To 16
			If laberinto(posicion+h) Then pared_3d(g):g=17
			h=h+1
		Next
		b=(6-h)*2
		
      h=0
		For g=1 To 9-b Step 2
			If laberinto(posicion-ancho+h) Then pared_3d(g) Else pared_3d(g+1)
			h=h+1
		Next
		
		h=0
		For g=17 To 25-b Step 2
			If laberinto(posicion+ancho+h) Then pared_3d(g) Else pared_3d(g+1)
			h=h+1
		Next
   End If
   
' -------------------------------------------  
   If direccion=3 Then ' miramos al sur
   	h=0
		For g=11 To 16
			If laberinto(posicion+(ancho*h)) Then pared_3d(g):g=17
			h=h+1
		Next
		b=(6-h)*2
		
      h=0
		For g=1 To 9-b Step 2
			If laberinto(posicion+1+(ancho*h)) Then pared_3d(g) Else pared_3d(g+1)
			h=h+1
		Next
		
		h=0
		For g=17 To 25-b Step 2
			If laberinto(posicion-1+(ancho*h)) Then pared_3d(g) Else pared_3d(g+1)
			h=h+1
		Next
   End If

' -------------------------------------------
   If direccion=4 Then ' miramos al oeste
   	h=0
		For g=11 To 16
			If laberinto(posicion-h) Then pared_3d(g):g=17
			h=h+1
		Next
		b=(6-h)*2
		
      h=0
		For g=1 To 9-b Step 2
			If laberinto(posicion+ancho-h) Then pared_3d(g) Else pared_3d(g+1)
			h=h+1
		Next
		
		h=0
		For g=17 To 25-b Step 2
			If laberinto(posicion-ancho-h) Then pared_3d(g) Else pared_3d(g+1)
			h=h+1
		Next
   End If
   
End Sub

Sub pared_3d(pared As integer)
	' dibujamos las paredes por zonas, de la 1 a la 26, segun donde este
	Dim col As Integer
	Dim p1 As Integer
	Dim p2 As Integer
	Dim p3 As Integer
	Dim p4 As Integer
	
	col=14

   p1=lineas3d(pared,1)
   p2=lineas3d(pared,2)
   p3=lineas3d(pared,3)
   p4=lineas3d(pared,4)
   Line (coord3d( p1,1),coord3d( p1,2))-(coord3d(p2,1),coord3d(p2,2)),c
   Line (coord3d( p2,1),coord3d( p2,2))-(coord3d(p3,1),coord3d(p3,2)),c
	Line (coord3d( p3,1),coord3d( p3,2))-(coord3d(p4,1),coord3d(p4,2)),c
	Line (coord3d( p4,1),coord3d( p4,2))-(coord3d(p1,1),coord3d(p1,2)),c  
   
End Sub


' 44*2 coordenadas 3d para dibujar los vectores de las paredes
coord3d:
DATA 0, 0
DATA 0,64
DATA 96,64
DATA 96,128
DATA 192,128
DATA 192,192
DATA 287,192
DATA 287,255
DATA 383,255
DATA 383,316
DATA 474,316
DATA 0,768
DATA 0,692
DATA 96,692
DATA 96,616
DATA 192,616
DATA 192,541
DATA 287,541
DATA 287,465
DATA 383,465
DATA 383,393
DATA 474,393
DATA 1024, 0
DATA 1024,65
DATA 926,65
DATA 926,129
DATA 831,129
DATA 831,192
DATA 735,192
DATA 735,255
DATA 640,255
DATA 640,316
DATA 548,316
DATA 1024,768
DATA 1024,691
DATA 926,691
DATA 926,616
DATA 831,616
DATA 831,540
DATA 735,540
DATA 735,465
DATA 640,465
DATA 640,393
DATA 548,393

' lineas a dibujar en las coordenadas anteriores
lineas:
' paredes izquierda, alternas inclinada y recta
Data  1, 3,14,12
Data  2, 3,14,13
Data  3, 5,16,14
Data  4, 5,16,15
Data  5, 7,18,16
Data  6, 7,18,17
Data  7, 9,20,18
Data  8, 9,20,19
Data  9,11,22,20
Data 10,11,22,21
' paredes centrales, solo planas
Data  1,23,34,12
Data  3,25,36,14
Data  5,27,38,16
Data  7,29,40,18
Data  9,31,42,20
Data 11,33,44,22
' paredes derecha, alternas inclinada y recta
Data 23,25,36,34
Data 24,25,36,35
Data 25,27,38,36
Data 26,27,38,37
Data 27,29,40,38
Data 28,29,40,39
Data 29,31,42,40
Data 30,31,42,41
Data 31,33,44,42
Data 32,33,44,43
badidea
Posts: 2586
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Maze 2D and 3D

Post by badidea »

jepalza wrote:Maze 2d
With -exx compile:
Aborting due to runtime error 6 (out of bounds array access) at line 123 of test.bas::BUSCA_HUECOS()
Press any key to continue . . .


Variables c,f,g,h,i,j,r,t,x,y,a ? It is a good thing that they a commented. Now I only need to learn Spanish.

More 2d mazes: viewtopic.php?f=7&t=24291&p=272181#p272181
jepalza wrote:Maze 3d
This one also accesses memory outside the LABERINTO array. After a quick fix, I was able to complete the maze.
jepalza
Posts: 149
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

Re: Maze 2D and 3D

Post by jepalza »

Are very old codes from my library. Several of them are conversions from QB , about 90's. I've converted them just for fun and remembering "old times"
Compiled with "fbc -s gui" (or console)

Sorry for "spanish", but not speak english. Using google for all purpouses.
I wouldn't dare or be able to write in English, for not "screwing up" and making a fool of myself
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Maze 2D and 3D

Post by BasicCoder2 »

jepalza wrote:Sorry for "spanish", but not speak english. Using google for all purpouses.
I wouldn't dare or be able to write in English, for not "screwing up" and making a fool of myself
It would be nice if google could translate source code :)
Sería bueno si Google pudiera traducir el código fuente :)

Code: Select all

Declare Sub look_for_gaps()
Declare Sub draw_maze_2d()
Declare Sub draw_maze_3d(x As Integer, y As Integer, direction As Integer)
Declare Sub create_maze()
Declare Sub wall_3d(wall As integer)

RANDOMIZE Timer ' to make it different every time
SCREEN 20

Dim Shared high As Integer
Dim Shared wide As Integer
Dim Shared wall As Integer

Dim Shared b As Integer
Dim Shared c As Integer ' free gap counter
Dim Shared f As Integer ' loops
Dim Shared g As Integer ' accountant
Dim Shared h As Integer ' loops
Dim Shared i As Integer ' loops
Dim Shared j As Integer ' loops
Dim Shared r As Integer ' random
Dim Shared t As Integer ' accountant
Dim Shared x As Integer ' position in maze
Dim Shared y As Integer ' position of squares in the maze
Dim Shared As Integer yori, xori  'y or i   x or i ?

Dim Shared a As String

Dim Shared direction As Integer

'MEASURES LABYRINTH, minimum 5x5 maximum not important, wide always odd height, height not important
high=10
wide=15
Dim Shared labyrinth(high*wide) As Integer ' store for the entire labyrinth

'read coordinates of vectors 3d (for 1024x768, mode 20)
Restore coord3d
Dim Shared coord3d(44,2) As Integer
For f=1 To 44
   Read coord3d(f,1),coord3d(f,2)
Next

'
'reads coordinates of the lines of the walles (10 left + 6 cen + 10 right, walles with 4 vertices each)
Restore lines
Dim Shared lines3d(26,4) As Integer
For f=1 To 26
   Read lines3d(f,1),lines3d(f,2),lines3d(f,3),lines3d(f,4)
Next

' direction initial (1 = north, 2 = east, 3 = south, 4 = west)
direction=3 ' we look south

create_maze()
x=2:y=2 ' we assign the starting coordinates

start:
   Cls
   draw_maze_2d()
   xori=x:yori=y ' copy positions
   draw_maze_3d(x-1,y-1,direction)' the coord. 3d's start at "0,0", I remove 1 to compensate
   Locate 2,40:Print "POS:";x;",";y
   b=GetKey

   If b>255 Then b=b Shr 8:a=Chr(b) Else a=Chr(b)
   
   If a="H" Then
      If direction=1 Then y-=1
      If direction=2 Then x+=1
      If direction=3 Then y+=1
      If direction=4 Then x-=1
   EndIf
   If a="P" Then
      If direction=1 Then y+=1
      If direction=2 Then x-=1
      If direction=3 Then y-=1
      If direction=4 Then x+=1
   EndIf
   If a="K" Then direction-=1
   If a="M" Then direction+=1
   If direction=0 Then direction=4
   If direction=5 Then direction=1
   
   If a=Chr(27) Then End
GoTo start

end

Sub create_maze()
'----------------------------------------------------
'---- we create a hollow labyrinth template -------
'----------------------------------------------------
G=0
' ------------- create the top border
For F=1 To wide
    labyrinth(G)=2
    G=G+1
Next

' ------------- create alternate intermediate cells
For H=1 To (high-2)/2
   
  ' odd row, with alternate walls and gaps
  labyrinth(G)=2:G=G+1
  For F=1 To (wide-3)/2
    labyrinth(G+0)=0
   labyrinth(G+1)=1
   G=G+2
  Next
  g=g+1
  labyrinth(G)=2:g=g+1
 
  ' even row, but this whole smooth (todo wall)
  labyrinth(G)=2:G=G+1
  For F=1 To wide-2
    labyrinth(G)=1
    G=G+1
  Next
  labyrinth(G)=2:g=g+1
Next H
g=g-wide
  labyrinth(G-1)=4 ' we put the output, since we are in this box
  
' ------------ close the bottom edge and it is created

For F=1 To wide
    labyrinth(G)=2
    G=G+1
Next

FOR f = 1 TO high STEP 2
 For h = 1 TO wide-1 STEP 2
   Y = wide * f + h
   look_for_gaps

   IF C > 0 THEN GoTo there_is_no_possibility
   If h = 1 And f = 1 THEN GOTO found
   If h = 1 THEN labyrinth(Y - wide)= 0
   If h > 1 THEN labyrinth(Y - 1    )= 0

   'DRAW THE WAY IN 20-STEP SECTIONS
   found:
   For T = 1 TO 200
    r=Rnd(1)*3
     IF r = 1 THEN r = -1
     If r = 2 THEN r = -1*wide
     IF r = 0 THEN r = +1
     IF r = 3 THEN r = wide
     If labyrinth(Y + r) <> 1 Then GoTo there_is_no_path
     Y = Y + 2 * r
    look_for_gaps
    IF C > 0 THEN GoTo there_is_no_path
    labyrinth (Y - r)= 0
    GOTO found
    there_is_no_path:
   Next T
   there_is_no_possibility:
 NEXT h
Next f
labyrinth(wide)=3 ' we mark the entrance in the labyrinth, always in box 1

End Sub

Sub look_for_gaps()
' depends on the process "create_maze()"
' ACCOUNT SPACES AROUND Y
C = 0

 If labyrinth(Y - wide) = 0 THEN C = C + 1
 If labyrinth(Y + wide) = 0 THEN C = C + 1
 If labyrinth(Y - 1    ) = 0 THEN C = C + 1
 If labyrinth(Y + 1    ) = 0 THEN C = C + 1

End Sub

Sub draw_maze_2d()
i=0
For j=0 To high*wide
   If labyrinth(j)=0 Then a=" "
   If labyrinth(j)=1 Then a=Chr(219)
   If labyrinth(j)=2 then a=Chr(219) ' for debugging use this --> a=Chr(177)
   'If labyrinth(j)=3 then a="E"
   If labyrinth(j)=4 then a="X"
   Print A;
   i=i+1:If i=wide Then i=0:Print
Next j
If Screen(y,x)=65499 Then x=xori:y=yori
If Screen(y,x)<>32 And Screen(y,x)<>65499 Then Print "FIN....":Sleep:end
Locate y,x:Print "*"
End Sub

Sub draw_maze_3d(x As Integer, y As integer, direction As Integer)
   Dim position As Integer
   
   position=y*wide+x ' absolute position according to x and y, inside the matrix
   

   'we draw the labyrinth 3d, in the form of 15 walls (1-left, 1-cen, 1-der and 5 depths 3d)
   'first, we draw the center, and obtain the depth at which it has stopped (from 5 to 0)
   'and with that depth (stored in "B"), we draw the rest, stopping in the same place
   'we do this equally for each direction we look
   
   ' -------------------------------------------
    If direction=1 Then ' we look north
      h=0
      For g=11 To 16
         If labyrinth(position-(wide*h)) Then wall_3d(g):g=17
         h=h+1
      Next
      b=(6-h)*2
      
      h=0
      For g=1 To 9-b Step 2
         If labyrinth(position-1-(wide*h)) Then wall_3d(g) Else wall_3d(g+1)
         h=h+1
      Next
      
      h=0
      For g=17 To 25-b Step 2
         If labyrinth(position+1-(wide*h)) Then wall_3d(g) Else wall_3d(g+1)
         h=h+1
      Next
   End If

' -------------------------------------------
   If direction=2 Then ' we look east
      h=0
      For g=11 To 16
         If labyrinth(position+h) Then wall_3d(g):g=17
         h=h+1
      Next
      b=(6-h)*2
      
      h=0
      For g=1 To 9-b Step 2
         If labyrinth(position-wide+h) Then wall_3d(g) Else wall_3d(g+1)
         h=h+1
      Next
      
      h=0
      For g=17 To 25-b Step 2
         If labyrinth(position+wide+h) Then wall_3d(g) Else wall_3d(g+1)
         h=h+1
      Next
   End If
   
' ------------------------------------------- 
   If direction=3 Then ' we look south
      h=0
      For g=11 To 16
         If labyrinth(position+(wide*h)) Then wall_3d(g):g=17
         h=h+1
      Next
      b=(6-h)*2
      
      h=0
      For g=1 To 9-b Step 2
         If labyrinth(position+1+(wide*h)) Then wall_3d(g) Else wall_3d(g+1)
         h=h+1
      Next
      
      h=0
      For g=17 To 25-b Step 2
         If labyrinth(position-1+(wide*h)) Then wall_3d(g) Else wall_3d(g+1)
         h=h+1
      Next
   End If

' -------------------------------------------
   If direction=4 Then ' we look west
      h=0
      For g=11 To 16
         If labyrinth(position-h) Then wall_3d(g):g=17
         h=h+1
      Next
      b=(6-h)*2
      
      h=0
      For g=1 To 9-b Step 2
         If labyrinth(position+wide-h) Then wall_3d(g) Else wall_3d(g+1)
         h=h+1
      Next
      
      h=0
      For g=17 To 25-b Step 2
         If labyrinth(position-wide-h) Then wall_3d(g) Else wall_3d(g+1)
         h=h+1
      Next
   End If
   
End Sub

Sub wall_3d(wall As integer)
   ' we draw the walls by zones, from 1 to 26, according to where it is
   Dim col As Integer
   Dim p1 As Integer
   Dim p2 As Integer
   Dim p3 As Integer
   Dim p4 As Integer
   
   col=14

   p1=lines3d(wall,1)
   p2=lines3d(wall,2)
   p3=lines3d(wall,3)
   p4=lines3d(wall,4)
   Line (coord3d( p1,1),coord3d( p1,2))-(coord3d(p2,1),coord3d(p2,2)),c
   Line (coord3d( p2,1),coord3d( p2,2))-(coord3d(p3,1),coord3d(p3,2)),c
   Line (coord3d( p3,1),coord3d( p3,2))-(coord3d(p4,1),coord3d(p4,2)),c
   Line (coord3d( p4,1),coord3d( p4,2))-(coord3d(p1,1),coord3d(p1,2)),c 
   
End Sub


' 44*2 3d coordinates to draw the vectors of the walls
coord3d:
DATA 0, 0
DATA 0,64
DATA 96,64
DATA 96,128
DATA 192,128
DATA 192,192
DATA 287,192
DATA 287,255
DATA 383,255
DATA 383,316
DATA 474,316
DATA 0,768
DATA 0,692
DATA 96,692
DATA 96,616
DATA 192,616
DATA 192,541
DATA 287,541
DATA 287,465
DATA 383,465
DATA 383,393
DATA 474,393
DATA 1024, 0
DATA 1024,65
DATA 926,65
DATA 926,129
DATA 831,129
DATA 831,192
DATA 735,192
DATA 735,255
DATA 640,255
DATA 640,316
DATA 548,316
DATA 1024,768
DATA 1024,691
DATA 926,691
DATA 926,616
DATA 831,616
DATA 831,540
DATA 735,540
DATA 735,465
DATA 640,465
DATA 640,393
DATA 548,393

' lines draw on the above coordinates
lines:
' left walls, alternate leaning and straight
Data  1, 3,14,12
Data  2, 3,14,13
Data  3, 5,16,14
Data  4, 5,16,15
Data  5, 7,18,16
Data  6, 7,18,17
Data  7, 9,20,18
Data  8, 9,20,19
Data  9,11,22,20
Data 10,11,22,21
' central walls, only flat
Data  1,23,34,12
Data  3,25,36,14
Data  5,27,38,16
Data  7,29,40,18
Data  9,31,42,20
Data 11,33,44,22
' right walls, alternate inclined and straight
Data 23,25,36,34
Data 24,25,36,35
Data 25,27,38,36
Data 26,27,38,37
Data 27,29,40,38
Data 28,29,40,39
Data 29,31,42,40
Data 30,31,42,41
Data 31,33,44,42
Data 32,33,44,43
jepalza
Posts: 149
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

Re: Maze 2D and 3D

Post by jepalza »

Good! even labels! ;-)

Code: Select all

  IF C > 0 THEN GoTo there_is_no_possibility
  IF C > 0 THEN GoTo nohayposibilidad
UEZ
Posts: 972
Joined: May 05, 2017 19:59
Location: Germany

Re: Maze 2D and 3D

Post by UEZ »

@jepalza: thanks for sharing the code.

For the 3D version the textures are missing... ;-)
jepalza
Posts: 149
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

Re: Maze 2D and 3D

Post by jepalza »

This code was created with QB45, around 1990. At that time (30 years already!!) QB didn't have enough power to move textures in real time. So, the easiest way was "wire mode".
I has several codes for real 3D with textures, but need to clean code first.

Image

This code isn't mine, I've converted it and improved it for the FB. When I have it ready, I'll upload it.
jepalza
Posts: 149
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

Re: Maze 2D and 3D

Post by jepalza »

And now, only two years later....

An unfinished, but functional project from 2018. I don't remember well how I started it or why I abandoned it, but it may be useful for someone.
It is a 3D textured maze, very fast.
It has a map editor and texture generator. I do not indicate instructions, because I believe that the only thing that would achieve, would be to confuse even more its simple use.
The texture generator takes a file created independently and converts it to the neutral format needed by the graphic engine.
The map generator is a simple graphic editor in text mode, which allows you to choose a texture and create walls.
It is better to use it to understand its use.
The 3D routines are not mine, I took them from some C example I found on the net, but I can't say where.

Translated with www.DeepL.com/Translator (free version)

Spanish:
Y ahora, solo dos años mas tarde....

Un proyecto de 2018 inacabado, pero funcional. No recuerdo bien cómo lo empecé ni por que lo abandone, pero puede ser util para alguno.
Es un laberinto en 3D texturizado, muy rapido.
Tiene editor de mapas y generador de texturas. No indico instrucciones, por que creo que lo unico que lograria, seria confundiar aun mas su simple uso.
El generador de texturas, coge un fichero creado independiente y lo convierte al formato neutro necesario por el motor grafico.
El generador de mapas, es un simple editor grafico en modo texto, que permite elegir una textura y crear muros.
Es mejor usarlo para entender su uso.
las rutinas 3D no son mias, las cogí de algún ejemplo en C que encontré por la red, pero no podria decir de donde.

https://drive.google.com/file/d/1AfJxB9 ... share_link
D.J.Peters
Posts: 8586
Joined: May 28, 2005 3:28
Contact:

Re: Maze 2D and 3D

Post by D.J.Peters »

I made some changes for 32/64-bit targets :-)
(type RGBAColor as ulong)

Joshy

Code: Select all

' lectura de texturas:
' son cuadros de 64x64 pixel, y cada pixel ocupa 4 bytes (alpha,r,g,b), por lo tanto 64x64x4=16384bytes 
' se almacenan seguidas en el binario, de 16k en 16k. en el binario se almacena como UInteger.
' un color se guarda en el binario como "BGRA" (azul, rojo, verde, alfa)
' de ese modo, al leerlo con el "GET" se lee en su orden, o sea, que queda como "ARGB"
' ejemplo, en el binario, un pixel, se ve como "BB GG RR AA", pero al leerlo se ve como "AA RR GG BB"

#Include "crt/math.bi"
#Include "fbgfx.bi"

' para el multikey
Using fb

type RGBAColor as ulong

Dim Shared texturas(200,4096) As RGBAColor ' 200 texturas de 4096bytes por 4 bytes del Uinteger=10*16384
Dim As Integer e,f=1,g

Open "texturas.bin" For binary As 1
While Not Eof(1)
	Get #1,f,texturas(e,0),4096 ' leo una textura de golpe (4096*4 bytes de golpe)
	f+=4096*4 ' siguiente textura
	e+=1
Wend
Close 1

Randomize timer




#Define screenWidth 1024
#Define screenHeight 768
#Define texWidth 64
#Define texHeight 64
#Define mapWidth 50
#Define mapHeight 35

Dim Shared worldmap (mapHeight ,mapWidth) As Integer
Dim Shared buffer (screenWidth, screenHeight) As RGBAColor

Dim As Double posX = 1.5, posY = 1.5  'x and y start position: esquina sup.izq. siempre
Dim As Double dirX = -1.0, dirY = 0.0 'initial direction vector
Dim As Double planeX = 0.0, planeY = 0.66 'the 2d raycaster version of camera plane
Dim As Double ctime = 0 'time of current frame
Dim As Double oldTime = 0 'time of previous frame
Dim As Integer done = 0
Dim As long x, y, scrw
Dim framebuffer As RGBAColor Ptr

Dim As Integer xmouse,ymouse, mboton, xmouseold,ymouseold, ratonmas,ratonmenos
  
'Loads the map data.
Sub LoadMapData(mapa As String)
	Dim As Integer e,f,g
	e=0
	f=0
	g=1
	dim sc As String=" "
	Open mapa For binary As 1
	While Not Eof(1)
		Get #1,g,sc
		g+=1
		worldmap (f,e)=Asc(sc)
		'if f<25 then Locate f+1,e+1:Print Chr(Asc(sc)+48)
		e+=1:If e=mapWidth Then f+=1:e=0
	Wend
	Close 1
End Sub

'Returns texture color for given texture
Function GetTextureColor(texnum As Integer, x As Integer, y As Integer, isfloor As Integer = 0) As RGBAColor
	Dim As RGBAColor pixel
	Dim As Integer twh
	
	If isfloor = 0 Then
		twh = texHeight
	Else
		twh = texWidth
	EndIf
	'RDC make sure values are in range here	
	If x < 0 Then x = 0
	If x > 63 Then x = 63
	If y < 0 Then y = 0
	If y > 63 Then y = 63
	
	' ****************************************************
	' Aqui recogemos el color del pixel segun la textura
	  pixel = texturas(texNum-1,twh * Y + X)
	' ****************************************************
	
	Return pixel
End Function

'Draws buffer to screen.
Sub DrawBuffer
    Dim As ulong x, y, scrw
    Dim framebuffer As RGBAColor Ptr

    framebuffer = ScreenPtr
    If framebuffer Then
        ScreenInfo scrw
        ScreenLock
        For x = LBound(buffer, 1) To UBound(buffer, 1)
            For y = LBound(buffer, 2) To UBound(buffer, 2)
            	Poke RGBAColor, framebuffer + (y * scrw + x), buffer(x, y)
            Next
        Next
        ScreenUnlock
    End If
End Sub


'Set up graphic screen.
ScreenRes screenWidth, screenHeight, 32
framebuffer = ScreenPtr
ScreenInfo scrw

' leo el mapa (de 50 de ancho por 35 de alto)
LoadMapData "mapa.bin"

Dim velgiro As Single=1
Dim velavance As Single=1
SetMouse(screenWidth/2,screenHeight/2,0) ' centro el raton, y lo escondo

Do
   ScreenLock
   Cls
	For x As Integer = 0 To screenWidth - 1

      'calculate ray position and direction
      Dim As Double cameraX = 2 * x / CDbl(screenWidth) - 1 'x-coordinate in camera space
      Dim As Double rayPosX = posX
      Dim As Double rayPosY = posY
      Dim As Double rayDirX = dirX + planeX * cameraX
      Dim As Double rayDirY = dirY + planeY * cameraX

      'which box of the map we're in
      Dim As Integer mapX = Int(rayPosX)
      Dim As Integer mapY = Int(rayPosY)

      '//length of ray from current position to next x or y-side
      Dim As Double sideDistX
      Dim As Double sideDistY

      'length of ray from one x or y-side to next x or y-side
      Dim As Double deltaDistX = Sqrt(1 + (rayDirY * rayDirY) / (rayDirX * rayDirX))
      Dim As Double deltaDistY = Sqrt(1 + (rayDirX * rayDirX) / (rayDirY * rayDirY))
      Dim As double perpWallDist

      '//what direction to step in x or y-direction (either +1 or -1)
      Dim As Integer stepX
      Dim As Integer stepY

      Dim As Integer hit = 0 '//was there a wall hit?
      Dim As Integer side '//was a NS or a EW wall hit?

      'calculate step and initial sideDist
      If rayDirX < 0 Then
      	stepX = -1
      	sideDistX = (rayPosX - mapX) * deltaDistX
      Else
        stepX = 1
        sideDistX = (mapX + 1.0 - rayPosX) * deltaDistX
      End If
      
      If rayDirY < 0 Then
        stepY = -1
        sideDistY = (rayPosY - mapY) * deltaDistY
      Else
        stepY = 1
        sideDistY = (mapY + 1.0 - rayPosY) * deltaDistY
      End If
      'perform DDA
      Do While (hit = 0)
        'jump to next map square, OR in x-direction, OR in y-direction
        If sideDistX < sideDistY Then
          sideDistX += deltaDistX
          mapX += stepX
          side = 0
        Else
          sideDistY += deltaDistY
          mapY += stepY
          side = 1
        End If
        'Check if ray has hit a wall
        If worldMap(mapX, mapY) > 0 Then hit = 1
      Loop

      'Calculate distance of perpendicular ray (oblique distance will give fisheye effect!)
      If side = 0 Then 
      	perpWallDist = fabs((mapX - rayPosX + (1 - stepX) / 2) / rayDirX)
      Else           
      	perpWallDist = fabs((mapY - rayPosY + (1 - stepY) / 2) / rayDirY)
      End If

      'Calculate height of line to draw on screen
      Dim As Integer lineHeight = Abs(Int(screenHeight / perpWallDist))

      'calculate lowest and highest pixel to fill in current stripe
      Dim As Integer drawStart = -lineHeight / 2 + screenHeight / 2
      If drawStart < 0 Then drawStart = 0
      Dim As Integer drawEnd = lineHeight / 2 + screenHeight / 2
      If drawEnd >= screenHeight Then drawEnd = screenHeight - 1

      'coge el numero de grafico a emplear en el texturizado, segun el mapa
      Dim As Integer texNum = worldMap(mapX, mapY)+2 ' le sumo dos, para dejar el 0 y el 1 para suelo y techo

      'calculate value of wallX
      Dim As double wallX 
      'where exactly the wall was hit
      If side = 1 Then 
      	wallX = rayPosX + ((mapY - rayPosY + (1 - stepY) / 2) / rayDirY) * rayDirX
      Else           
      	wallX = rayPosY + ((mapX - rayPosX + (1 - stepX) / 2) / rayDirX) * rayDirY
      End If
      wallX -= Floor((wallX))

      'x coordinate on the texture
      Dim As Integer texX = Int(wallX * CDbl(texWidth))
      If (side = 0) And (rayDirX > 0) Then texX = texWidth - texX - 1
      If (side = 1) And (rayDirY < 0) Then texX = texWidth - texX - 1

      For y As Integer = drawStart To drawEnd - 1
        Dim As Integer d = y * 256 - screenHeight * 128 + lineHeight * 128  '256 and 128 factors to avoid floats
        Dim As Integer texY = ((d * texHeight) / lineHeight) / 256
        'make color darker for y-sides: R, G and B byte each divided through two with a "shift" and an "and"
        If side = 1 Then
        		Poke RGBAColor, framebuffer + (y * scrw + x), (GetTextureColor(texNum, texX,  texY) Shr 1) And 8355711
        Else
        		Poke RGBAColor, framebuffer + (y * scrw + x),  GetTextureColor(texNum, texX,  texY)
        EndIf
      Next

      'FLOOR CASTING
      Dim As double floorXWall, floorYWall '//x, y position of the floor texel at the bottom of the wall

      '4 different wall directions possible
      If (side = 0) and (rayDirX > 0) Then
        floorXWall = mapX
        floorYWall = mapY + wallX
      ElseIf (side = 0) and (rayDirX < 0) Then
        floorXWall = mapX + 1.0
        floorYWall = mapY + wallX
      ElseIf (side = 1) And (rayDirY > 0) Then
        floorXWall = mapX + wallX
        floorYWall = mapY
      else
        floorXWall = mapX + wallX
        floorYWall = mapY + 1.0
      End If
      
      Dim As double distWall, distPlayer, currentDist

      distWall = perpWallDist
      distPlayer = 0.0
      if (drawEnd < 0) Then drawEnd = screenHeight '//becomes < 0 when the integer overflows
      '//draw the floor from drawEnd to the bottom of the screen
      For y As Integer = drawEnd + 1 To screenHeight  - 1
        currentDist = screenHeight / (2.0 * y - screenHeight) '//you could make a small lookup table for this instead

        Dim As double weight = (currentDist - distPlayer) / (distWall - distPlayer)
         
        Dim As double currentFloorX = weight * floorXWall + (1.0 - weight) * posX
        Dim As double currentFloorY = weight * floorYWall + (1.0 - weight) * posY
        
        Dim As Integer floorTexX, floorTexY
        floorTexX = int(currentFloorX * texWidth) Mod texWidth
        floorTexY = int(currentFloorY * texHeight) Mod texHeight 
        
        ' Suelo, textura 0
         Poke RGBAColor, framebuffer + (y * scrw + x), (GetTextureColor(1, floorTexX,  floorTexY, 1)  Shr 1) And 8355711
        ' techo, textura 1
        Poke RGBAColor, framebuffer + ((screenHeight - y) * scrw + x), GetTextureColor(2, floorTexX,  floorTexY, 1)
        
      Next
	Next

	'DrawBuffer
	'//clear the buffer instead of cls()
	'Erase buffer
	ScreenUnLock
	
   'timing for input and FPS counter
    oldTime = ctime
    ctime = Timer
    Dim As Double frameTime = ctime - oldTime '/ 1000.0 'frametime is the time this frame has taken, in seconds

    'speed modifiers
    Dim As Double moveSpeed = frameTime * velavance'5.0 'the constant value is in squares/second
    Dim As Double rotSpeed = frameTime * velgiro'3.0 'the constant value is in radians/second

    'mirar arriba-abajo
    if Multikey(SC_Q) Then
      If worldMap(int(posX + dirX * moveSpeed), int(posY)) = 0 Then posX += dirX * moveSpeed
      If worldMap(int(posX), int(posY + dirY * moveSpeed)) = 0 Then posY += dirY * moveSpeed
    End If

    if Multikey(SC_A) Then
      If worldMap(int(posX - dirX * moveSpeed), int(posY)) = 0 Then posX -= dirX * moveSpeed
      If worldMap(int(posX), int(posY - dirY * moveSpeed)) = 0 Then posY -= dirY * moveSpeed
    End If
    
    'move forward if no wall in front of you
    if MultiKey(SC_LSHIFT) Then velavance=2.5 Else velavance=1.2
    If MultiKey(SC_UP) Or Multikey(SC_W)  Then
      If worldMap(int(posX + dirX * moveSpeed), int(posY)) = 0 Then posX += dirX * moveSpeed
      If worldMap(int(posX), int(posY + dirY * moveSpeed)) = 0 Then posY += dirY * moveSpeed
    End If

    if Multikey(SC_DOWN) or Multikey(SC_S) Then
      If worldMap(int(posX - dirX * moveSpeed), int(posY)) = 0 Then posX -= dirX * moveSpeed
      If worldMap(int(posX), int(posY - dirY * moveSpeed)) = 0 Then posY -= dirY * moveSpeed
    End If
    
    'rotate to the right
    if Multikey(SC_RIGHT) Or ratonmas Then
      'both camera direction and camera plane must be rotated
      Dim As Double oldDirX = dirX
      dirX = dirX * cos(-rotSpeed) - dirY * sin(-rotSpeed)
      dirY = oldDirX * sin(-rotSpeed) + dirY * cos(-rotSpeed)
      Dim As Double oldPlaneX = planeX
      planeX = planeX * cos(-rotSpeed) - planeY * sin(-rotSpeed)
      planeY = oldPlaneX * sin(-rotSpeed) + planeY * cos(-rotSpeed)
    End If

    if Multikey(SC_LEFT) Or ratonmenos Then
      'both camera direction and camera plane must be rotated
      Dim As Double oldDirX = dirX
      dirX = dirX * cos(rotSpeed) - dirY * sin(rotSpeed)
      dirY = oldDirX * sin(rotSpeed) + dirY * cos(rotSpeed)
      Dim As Double oldPlaneX = planeX
      planeX = planeX * cos(rotSpeed) - planeY * sin(rotSpeed)
      planeY = oldPlaneX * sin(rotSpeed) + planeY * cos(rotSpeed)
    EndIf

	If MultiKey(SC_ESCAPE) Then
		done = 1
	EndIf
	
	If InKey=Chr(255)+"k" Then End ' al pulsar la "X"   
	   
	Sleep 1
		
	GetMouse(xmouse,ymouse,mboton)
	
	If ratonmas Or ratonmenos Then 
		ratonmas=0
		ratonmenos=0
		If xmouse=xmouseold Then 
			SetMouse(screenWidth/2,screenHeight/2,0) ' centro el raton, y lo escondo
			GetMouse(xmouse,ymouse,mboton)
			xmouseold=xmouse
			velgiro=1
		EndIf
	EndIf
	

	If xmouse<xmouseold Then
		velgiro=(xmouseold-xmouse)/7
		xmouseold=xmouse
		ratonmenos=1
	EndIf

	If xmouse>xmouseold Then
		velgiro=(xmouse-xmouseold)/7
		xmouseold=xmouse
		ratonmas=1
	EndIf

	
Loop Until done

jepalza
Posts: 149
Joined: Feb 24, 2010 10:08
Location: Spain (Bilbao)

Re: Maze 2D and 3D

Post by jepalza »

uppss!! :oops:
just this:
viewtopic.php?p=295996#p295996 :wink:

I abandoned this engine some time ago, because I ran out of ideas of how to continue. maybe someone will be encouraged, and a game can be made with it.
flavio
Posts: 1
Joined: Jan 12, 2010 13:51

Re: Maze 2D and 3D

Post by flavio »

Oh, don't be sorry, jepalza!
Why would you have to write in a foreign language?
For those who only know English, it will be a benefit to learn another language. :wink:
Post Reply