Показать сообщение отдельно
Старый 01.07.2012, 21:05   #22
polopok
ПроЭктировщик
 
Регистрация: 17.07.2009
Сообщений: 182
Написано 51 полезных сообщений
(для 71 пользователей)
Ответ: гексогональная тайловая карта(изометрия)

Добавил загрузку карты .
Прежде чем запустить этот код создайте карту в редакторе катры (он ниже)

;_______________________________________________________________________________

Global gex_grass , gex , gex_activ , gex_water , gex_wall , gex_wood
Global tilex , tiley , CamX , CamY , HexagonNumber , N
Global w , h , pw , h2 , oldx , oldy , kx , ky , xx , yy , sxx , syy , sx# , sy# , mouseSelect , mx# , my# 

Const GrWidth = 800	;ширина экрана
Const GrHeight = 600	;высота  экрана
;_______________________________________________________________________________
	
Graphics GrWidth , GrHeight , 32 , 2 

	fntArial=LoadFont("Arial",14) 		;загрузка шрифта с указанием размера шрифта
	SetFont fntArial 				;активация шрифта 
	
	; вычисление центра экрана :
	CenterMapX = GrWidth/2			;половина ширины экрана 
	CenterMapY = GrHeight/2		;половина высоты  экрана 
	
	w = 40 						;ширина тайла
	h = 20						;высота тайла
	tilex =10						;кол-во тайлов по горизонтали
	tiley = 5						;кол-во тайлов по вертикали
	
	pw = w/4*3					;параметр смещения тайлов по горизонтали
	h2 = h/2						;половина высоты тайла
	
	;позиция камеры :
	CamX =0						
	CamY =0		
		
 	Dim Map( tilex+1 +10,  tiley+1 +10)
;gex = LoadImage ("hex3.png") :MaskImage gex,255,255,255
	CreateImages()	;создаём или загружаем  изображения , анимированые изображения
	LoadMap( "D:\vitalii\blitz\гексы\maps2.txt")
SetBuffer BackBuffer() 	;устанавливаем задний буффер 

;__________ Main programm _____________________________________________________________________

While Not KeyHit(1) 					;ESC для выхода из цикла и завершения программы 
ClsColor 110,110,112				;цвет очистки экрана
Cls								;очистка экрана
	mx# = MouseX() : my# = MouseY()	; координаты мыши 

	DrawMap()					;прорисовываем карту	
	KeyMouse()					;события мыши , клавиатуры
		
		

		
	DrawMenu()					;прорисовка меню в игре 
	Text mx,my,"^"					;отображает положение курсора 
	
;__________ Info  _____________________________________________________________________
	
	Info()
;______________________________________________________________________________
		
Flip 								; Меняем буфер 
Wend 
FreeFont fntArial					; удаляем шрифт 
End 

;_______________________________________________________________________________
	
	Function Info()
		Text 100 ,525 ,"kx : "+kx+"  ky :"+ky+"  oldx : "+oldx +" oldy : "+oldy;+"  ix : "+ix +" jy : "+jy
		Text 100 ,540 ," U : "+sxx+"  V :"+syy
		Text 100 ,555 ," Mouse X : "+xx+"  Mouse Y :"+yy
	;	Text 100 ,575 ,"Координаты мышы в сетке : UX : "+mx+"  VY :"+my	
	End Function
;_______________________________________________________________________________
		
	Function KeyMouse()	
				
				If KeyHit(49) Then N = 1 - N 					; (отобразить | скрыть) id ячейки по нажатию клавиши N
				If MouseDown(2) Then  mouseSelect = False		; сброс выбора ячейки
				If MouseDown(1) Then 						; выбор ячейки
				
					oldx = kx : oldy = ky						; старые координаты мыши
 					sx# =Floor#   (mx# /(w+0.15) * 4/3 - 0.15)	; вычисление номера ячейки по горизонтали 
					sy# =Floor#   ( my# /h - (sx# Mod 2)/2 )		; вычисление номера ячейки по вертикали  
					sxx = Int (sx#)							; округление результата 
					syy = Int (sy#)
				
						xx = sxx * pw						; вычисление координат ячейки по номеру  ячейки 
						yy = syy * h +(sxx Mod 2)*h2	
						
					 mouseSelect = True
				Else 
					kx = xx : ky = yy						; новые координаты мыши
				EndIf 
	End Function  			
;_______________________________________________________________________________
					
	Function DrawMap()
		For j=0 To tiley
			For i=0 To tilex
							x = i * pw							; вычисление координат ячейки по номеру
							y = (j * h +(i Mod 2)*h2)
							
							
							
				If RectsOverlap (0 , 0 , 600  ,  500   , x , y , w , h ) Then	; прорисовывает только то ,что попадает в зону видимости экрана 	
				
							DrawImage gex, x +CamX , y  +CamY 		; прорисовывает гексы
						If Map(i , j) <= 0
							DrawImage gex_grass, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "0"
							
						Else If Map(i , j) = 1
							DrawImage gex_wood, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "1"
							
						Else If Map(i , j) = 2
							DrawImage gex_wall, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "2"
							
						Else If Map(i , j) = 3
							DrawImage gex_water, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "3"
							
						Else If Map(i , j) = 4
							;DrawImage gex_water, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "4"
						EndIf
						
					If N = 1 Then 									; id только в целях отладки ! Так как жутко тормозит 							
						HexagonNumber = i+ j * tilex 					; id ячейки 
						Text  x +CamX  +10, y  +CamY +5 , HexagonNumber 	; текст id ячейки 
					EndIf 		

					If mouseSelect = True Then 		;если ячейка выбрана рисовать ...
						DrawImage gex_activ , kx +locx , ky +locy
					EndIf 			
						
				End If 	
	       		Next
		Next
	End Function 
;_______________________________________________________________________________
		
	Function LoadMap(file$)
	
		filein = ReadFile(file$)
		mapline = 0
		If filein <> 0 Then
		While Not Eof(filein)
		mapStr$ = ReadLine$(filein)
		Wend		
		CloseFile(filein)		
				For j=0 To tilex
							For i=0 To tilex
								mapline  = mapline  +1
								Map(i , j ) = Int( Mid (mapStr$, mapline  , 1))	
												
					       		Next
				Next 
				
			Else 	
						
			RuntimeError "Такого файла нет" 
			CloseFile(filein)
			Delay 1000
			;Exit 
		

			End If 
	End Function 
;_______________________________________________________________________________
	
	Function DrawMenu()
			Color 0 , 109 , 39				
				Rect 0 , 0 , 600 , 500 ,0
				Color 139 , 134 , 78	
				Rect 600 , 0 , 200 , 500 ,1		
				Rect 0 , 500 , 800 , 100 ,1	
			Color 255,255,255
	End Function
;_______________________________________________________________________________
	
	Function CreateImages()
		gex = CreateImage(w+1,h+1)		; создаём изображение гекса
		SetBuffer ImageBuffer(gex)
		Color 238,118,0
		Line 0,h/2		,w/4,0
		Line w/4,0	,pw,0
		Line pw,0	,w,h/2
		Line w,h/2	,pw,h
		Line pw,h	,w/4,h
		Line w/4,h	,0,h/2
		
		gex_activ = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(gex_activ)
			Color 102,5,0
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			
		gex_grass = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(gex_grass)
			Color 50,205,50
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			
		gex_water = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(gex_water)
			Color 0,206,209
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			
		gex_wall = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(gex_wall)
			Color 205,197,191
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			
		gex_wood = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(gex_wood)
			SeedRnd MilliSecs()
			Color 0,197,90
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			For q1 = 0 To Rnd(12,46)
				Color 5,Rnd(40,180),Rnd(40,180)
				Oval Rnd (5,w-5) , Rnd (5,h-5) , Rnd (5,2) , Rnd (5,2) , 1
			Next 
			
		Color 255,255,255
	End Function


Редактор карты :
;_______________________________________________________________________________

Global  image0 , gex , gex_activ ,  image1 ,  image2 ,  image3
Global tilex , tiley , CamX , CamY , sel
Global w , h , pw , h2 , oldx , oldy , kx , ky , xx , yy , sxx , syy , sx# , sy# , mouseSelect , mx# , my# 

Const GrWidth = 800	;ширина экрана
Const GrHeight = 600	;высота  экрана
;_______________________________________________________________________________
	
Graphics GrWidth , GrHeight , 32 , 2 

	fntArial=LoadFont("Arial",14) 		;загрузка шрифта с указанием размера шрифта
	SetFont fntArial 				;активация шрифта 
	
	; вычисление центра экрана :
	CenterMapX = GrWidth/2			;половина ширины экрана 
	CenterMapY = GrHeight/2		;половина высоты  экрана 
	
	w = 40 						;ширина тайла
	h = 20						;высота тайла
	tilex =10						;кол-во тайлов по горизонтали
	tiley = 5						;кол-во тайлов по вертикали
	
	pw = w/4*3					;параметр смещения тайлов по горизонтали
	h2 = h/2						;половина высоты тайла
	
	;позиция камеры :
	CamX =0						
	CamY =0		
		
 	Dim Map( tilex+1 ,  tiley+1 )
;gex = LoadImage ("hex3.png") :MaskImage gex,255,255,255
	CreateImages()	;создаём или загружаем  изображения , анимированые изображения
	;SaveMap( "D:\vitalii\blitz\гексы\maps2.txt")
SetBuffer BackBuffer() 	;устанавливаем задний буффер 

;__________ Main programm _____________________________________________________________________

While Not KeyHit(1) 					;ESC для выхода из цикла и завершения программы 
ClsColor 110,110,112				;цвет очистки экрана
Cls								;очистка экрана
	mx# = MouseX() : my# = MouseY()	; координаты мыши 

	DrawMap()					;прорисовываем карту	
	DrawMenu()					;прорисовка меню в игре 	
	DrawTiles()	
	KeyMouse()					;события мыши , клавиатуры


	Text mx,my,"^"					;отображает положение курсора 
	
;__________ Info  _____________________________________________________________________
	
	Info()
;______________________________________________________________________________
		
Flip 								; Меняем буфер 
Wend 
FreeFont fntArial					; удаляем шрифт 
End 


;_______________________________________________________________________________
	
	Function DrawTiles()
			Color 120,120,122				
				Rect 620 , 30 ,150 , 240 ,1
			Color 0 , 109 , 39
				Rect 620 , 30 ,150 , 240 ,0
				DrawImage  image0,624 , 34
				DrawImage  image1,624 , 34*2
				DrawImage  image2,624 , 34*3
				DrawImage  image3,624 , 34*4
			Color 255,255,255
				Text 664 , 34," - трава"
				Text 664 , 34*2," - дерево"
				Text 664 , 34*3," - стена"
				Text 664 , 34*4," - вода"
			Color 120,120,122				
				Rect 625 ,175 ,120 , 20 ,1
			Color 0 , 109 , 39
				Rect 625 , 175 ,120 , 20 ,0
			Color 255,255,255
				Text 635 , 177," Сохранить карту"
							
	End Function
;_______________________________________________________________________________
	
	Function Info()
		Text 100 ,525 ,"kx : "+kx+"  ky :"+ky+"  oldx : "+oldx +" oldy : "+oldy;+"  ix : "+ix +" jy : "+jy
		Text 100 ,540 ," U : "+sxx+"  V :"+syy
		Text 100 ,555 ," Mouse X : "+xx+"  Mouse Y :"+yy
		Text 100 ,575 ," sel : "+sel;+"  VY :"+my	
	End Function
;_______________________________________________________________________________
		
	Function KeyMouse()	
		If mx < 600 Then 
				If MouseDown(2) Then  mouseSelect = False	: sel = 0	; сброс выбора ячейки
				If MouseDown(1) Then 						; выбор ячейки
				
					oldx = kx : oldy = ky						; старые координаты мыши
 					sx# =Floor#   (mx# /(w+0.15) * 4/3 - 0.15)	; вычисление номера ячейки по горизонтали 
					sy# =Floor#   ( my# /h - (sx# Mod 2)/2 )		; вычисление номера ячейки по вертикали  
					sxx = Int (sx#)							; округление результата 
					syy = Int (sy#)
				
						xx = sxx * pw						; вычисление координат ячейки по номеру  ячейки 
						yy = syy * h +(sxx Mod 2)*h2	
						
					 mouseSelect = True
				Else 
					kx = xx : ky = yy						; новые координаты мыши
				EndIf 
		Else
			
			For qq = 1 To 4
			If RectsOverlap ( 624 , 34*qq , w , h , mx , my , 2 , 2) Then 
				Color 255,69,0
				Rect 624 , 34*qq , w , h ,0
				Color 255,255,255
				
				If  MouseDown(1) Then 
					 mouseSelect = False
					sel = qq
				EndIf 
			End If
			Next 
			
			If RectsOverlap ( 625 , 175 ,120 , 20 , mx , my , 2 , 2) Then
				Color 255,69,0
				Rect 625 , 175 ,120 , 20 ,0
						Color 255,255,255
				If  MouseDown(1) Then 
					SaveMap( "D:\vitalii\blitz\гексы\maps2.txt")
						EndIf 		
			EndIf
			
		End If 
	End Function  			
;_______________________________________________________________________________
					
	Function DrawMap()
		For j=0 To tiley
			For i=0 To tilex
							x = i * pw							; вычисление координат ячейки по номеру
							y = (j * h +(i Mod 2)*h2)
							
							
				If RectsOverlap (0 , 0 , 600  ,  500   , x , y , w , h ) Then	; прорисовывает только то ,что попадает в зону видимости экрана 	
				
							DrawImage gex, x +CamX , y  +CamY 		; прорисовывает гексы
						If Map(i , j) <= 0
							DrawImage image0, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "0"
						Else If Map(i , j) = 1
							DrawImage image1, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "1"
						Else If Map(i , j) = 2
							DrawImage image2, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "2"
						Else If Map(i , j) = 3
							DrawImage image3, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "3"
						Else If Map(i , j) = 4
							;DrawImage gex_water, x +CamX , y  +CamY 
							Text  x +CamX  +10, y  +CamY +5 , "4"
						EndIf			
					Select sel
						Case 0
							
						Case 1
							DrawImage  image0, mx +CamX , my  +CamY
						Case 2
							DrawImage  image1, mx +CamX , my  +CamY
						Case 3
							DrawImage  image2, mx +CamX , my  +CamY
						Case 4
							DrawImage  image3, mx +CamX , my  +CamY
					End Select 
					If mouseSelect = True Then 		;если ячейка выбрана рисовать ...
						If  sxx >-1 And sxx< tilex+1 And syy>-1 And syy< tiley+1 Then 
							Map(sxx , syy) = sel - 1
						EndIf 	
					End If 		
						
				End If 	
	       		Next
		Next
	End Function 
;_______________________________________________________________________________
		
	Function SaveMap(file$)
	
		fileout = WriteFile(file$) 
		
				For j=1 To tiley+1
							For i=1 To tilex+1
								String$ = String$+ Str (Map(i-1 , j-1))	
								Text 635 , 200,"Идёт сохранение . . . "				
					       		Next
						Next 
			WriteLine( fileout, String$) 
			Text 635 , 200,"Сохранено !"
		CloseFile( fileout ) 

	End Function 
;_______________________________________________________________________________
	
	Function DrawMenu()
			Color 0 , 109 , 39				
				Rect 0 , 0 , 600 , 500 ,0
				Color 139 , 134 , 78	
				Rect 600 , 0 , 200 , 500 ,1		
				Rect 0 , 500 , 800 , 100 ,1	
			Color 255,255,255
	End Function
;_______________________________________________________________________________
	
	Function CreateImages()
		gex = CreateImage(w+1,h+1)		; создаём изображение гекса
		SetBuffer ImageBuffer(gex)
		Color 238,118,0
		Line 0,h/2		,w/4,0
		Line w/4,0	,pw,0
		Line pw,0	,w,h/2
		Line w,h/2	,pw,h
		Line pw,h	,w/4,h
		Line w/4,h	,0,h/2
		
		gex_activ = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(gex_activ)
			Color 102,5,0
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			
		image0 = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(image0)
			Color 50,205,50
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			
		image3 = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(image3)
			Color 0,206,209
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			
		image2 = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(image2)
			Color 205,197,191
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			
		image1 = CreateImage(w+1,h+1) 	; создаём изображение активной ячейки 
		SetBuffer ImageBuffer(image1)
			SeedRnd MilliSecs()
			Color 0,197,90
			Rect (w/4 +0.15) , 0 ,  (w/2 +0.15) , h ,1
			For q1 = 0 To Rnd(12,46)
				Color 5,Rnd(40,180),Rnd(40,180)
				Oval Rnd (5,w-5) , Rnd (5,h-5) , Rnd (5,2) , Rnd (5,2) , 1
			Next 
			
		Color 255,255,255
	End Function
(Offline)
 
Ответить с цитированием