Тема: Граф Студия! Lefost company
Показать сообщение отдельно
Старый 17.06.2007, 17:32   #5
Leito
Танчики Developer
 
Регистрация: 29.01.2007
Сообщений: 539
Написано 16 полезных сообщений
(для 23 пользователей)
ща посмотрим.
кстати у меня в этой проге еще есть поиск гамальтонова цилка, поиск в ширину и глубину (с показыванием результата) построение матрицы сильных компонентов.

Const SCREEN_WIDTH		= 1024
Const SCREEN_HEIGHT		= 768
Const SCREEN_MODE		=   1

Global gentFireCamera
Global gentLogo				
Global gentFireSprite		
Global gtexFireBlur			
Global gtexFlames			

Global gfltUPos#		
Global gfltVPos#		

Global GameScr

Dim M(100,100)
Dim M2(100,100)
Dim SM(100,100)
Dim Depth(100,100)
Dim Width(100,100)
Dim H(100,100)
Dim P(100,3)
Dim YYY(100,100)
Dim graph(100,100)
Dim graph2(100,100)
Dim graph3(100,100)
Dim graph4(100,100)
Dim dop(100)
Dim ver(100)
Global QPrint

Type list
Field x
End Type

Type ste
Field x
End Type

Type stack
Field x
End Type

Global Pstat=1,x1,y1,NumP,QP,Mstat=0,QE,Qdepth,Qwidth,m4st=1

Global lolx=Rand(100,900),loly=Rand(100,700),dlolx=3,dloly=3
Global lolst=1

Const MaxM=100,PInt=30,PintAl=15,Radius=12

Graphics3D SCREEN_WIDTH, SCREEN_HEIGHT, 0, SCREEN_MODE
SetBuffer BackBuffer()
Global Font=LoadFont("palatino linotype",32)
Global Font20=LoadFont("palatino linotype",20)
Global Font24=LoadFont("palatino linotype",24)

GameScr=0

Cls
Repeat

Select GameScr
Case 0
	Cls
	Select Mstat
	Case 0
		SetFont font24
		UpdatePixels()
		If KeyHit(2) Mstat=1		
		If KeyHit(3) Mstat=2
		If KeyHit(4) 
			Mstat=3
			graf()
		End If
		If KeyHit(5) 
			Mstat=4
			graf2()
		End If
		If KeyHit(6) 
			Mstat=5
			graf2()
			graf3()
		End If		
		If KeyHit(7) 
			Mstat=6
			detour()
		End If
		If KeyHit(8) 
			Mstat=7
			ailer()
		End If		
		If lolst=1 UpdateLol()
		If KeyHit(9) lolst=-lolst
		Color 255,255,255
		If lolst=1 Text 950,10,"lol: on" Else Text 950,10,"lol: off"
	Case 1
		SetFont font
		UpdateMatrix(1)
		If KeyHit(28) Mstat=0
	Case 2
		SetFont font
		UpdateMatrix(2)
		If KeyHit(28) Mstat=0
	Case 3
		SetFont font
		UpdateMatrix(3)
		If KeyHit(28) Mstat=0
	Case 4
		SetFont font
		UpdateMatrix(4)
		If KeyHit(28) Mstat=0		
	Case 5
		SetFont font
		UpdateMatrix(5)
		If KeyHit(28) Mstat=0	
	Case 6
		SetFont font
		UpdateMatrix(6)
		If KeyHit(28) Mstat=0			
	Case 7
		SetFont font
		UpdateMatrix(7)
		If KeyHit(28) Mstat=0	
	End Select
Case 1

End Select
Color 255,255,255
Text MouseX()-StringWidth("+")/2,MouseY()-StringHeight("+")/2,"+"
Flip
Until (KeyHit(1) Or KeyHit(10))
End

Function UpdatePixels()

If MouseHit(1)
	x=MouseX():y=MouseY()
	Select Pstat
	Case 1
		If QP<MAXM
			For i=1 To QP
				If Abs(P(i,1)-x)<PInt And Abs(P(i,2)-y)<PInt Goto NextAction
			Next
			QP=QP+1
			P(QP,1)=x
			P(QP,2)=y
		End If
	Case 2
		If NumP=0
			For i=1 To QP
				If Abs(P(i,1)-x)<PIntAl And Abs(P(i,2)-y)<PIntAl
					x1=P(i,1):y1=P(i,2):NumP=i
				End If
			Next
		Else
			For i=1 To QP
				If Abs(P(i,1)-x)<PIntAl And Abs(P(i,2)-y)<PIntAl
					If x1<>P(i,1) And y1<>P(i,2)
						If M(NumP,i)=0 And M(i,NumP)=0
							QE=QE+1
							q=QE
							YYY(NumP,i)=QE
							YYY(i,NumP)=QE							
						Else
							q=YYY(i,NumP)
						End If
						If M(i,NumP)=0 
							H(NumP,q)=-1
							H(i,q)=1
						Else
							H(NumP,q)=1
							H(i,q)=1							
						End If
						M(NumP,i)=1
						NumP=0
						Goto NextAction
					End If
				End If
			Next
		End If
	End Select
End If
.NextAction

If KeyHit(57)
	If Pstat=1 Pstat=2 Else Pstat=1
End If

If Pstat=2 And NumP<>0
	Color 0,255,0
	x=MouseX():y=MouseY()
		
	Line x1,y1,MouseX(),MouseY()
	For i=1 To 180
		Line x1+Cos(i*2)*Radius,y1+Sin(i*2)*Radius,x1+Cos(i*2-2)*Radius,y1+Sin(i*2-2)*Radius
	Next
	For i=1 To QP
		If Abs(P(i,1)-x)<PIntAl And Abs(P(i,2)-y)<PIntAl
			For j=1 To 180		
				Line P(i,1)+Cos(j*2)*Radius,P(i,2)+Sin(j*2)*Radius,P(i,1)+Cos(j*2-2)*Radius,P(i,2)+Sin(j*2-2)*Radius
			Next
		End If	
	Next
End If

For i=1 To QP
	For j=1 To QP
		If M(i,j)=1 
			Color 255,0,0
			Line P(i,1),P(i,2),P(j,1),P(j,2)
			Color 0,255,0
			xx=P(j,1)-Cos(rotate(P(i,1),P(i,2),P(j,1),P(j,2))-20)*15
			yy=P(j,2)-Sin(rotate(P(i,1),P(i,2),P(j,1),P(j,2))-20)*15
			Line xx,yy,P(j,1),P(j,2)
			xx=P(j,1)-Cos(rotate(P(i,1),P(i,2),P(j,1),P(j,2))+20)*15
			yy=P(j,2)-Sin(rotate(P(i,1),P(i,2),P(j,1),P(j,2))+20)*15
			Line xx,yy,P(j,1),P(j,2)
			mmm#=(P(j,1)-P(i,1))/2
			nnnn#=(P(j,2)-P(i,2))/2			
			Text P(i,1)+mmm,P(i,2)+nnnn,Str(YYY(i,j))
		End If
	Next	
Next

For i=1 To QP
	Color 0,0,255
	Rect P(i,1)-1,P(i,2)-1,3,3,1
	Color 0,255,0
	Text P(i,1),P(i,2),Str(i)
Next

Color 255,255,255
s$="Product of Leito Software Company - Lab 5-9"
Text 512-StringWidth(s$)/2,740,s$

SetFont font20
Text 10,20,"1 - Matrix of a contiguity"
Text 10,36,"2 - Matrix of a insiadent"
Text 10,52,"3 - Matrix of a transitive circuit"
Text 10,68,"4 - Matrix of a strong components"
Text 10,84,"5 - Transformed matrix of strong components"
Text 10,100,"6 - Detour in depth and width"
Text 10,116,"7 - Ailer and gamilton cycles"
End Function

Function UpdateMatrix(num)

Select num
Case 1
	CellSize=40
	x0=512-(QP*CellSize)/2
	y0=384-(QP*CellSize)/2
	Color 0,0,128
	s$="Matrix of a contiguity"
	Text 512-StringWidth(s$)/2,20,s$
	Color 0,255,0
	Line x0,y0,x0,y0+QP*CellSize
	Line x0+QP*CellSize,y0,x0+QP*CellSize,y0+QP*CellSize

	Color 0,0,255
	For i=1 To QP
		For j=1 To QP
			Text x0+(i-1)*CellSize+16,y0+(j-1)*CellSize+4,Str(M(j,i))
		Next
	Next
Case 2
	CellSize=40
	x0=512-(QE*CellSize)/2
	y0=384-(QP*CellSize)/2
	Color 0,0,128
	s$="Matrix of a insiadent"
	Text 512-StringWidth(s$)/2,20,s$
	Color 0,255,0
	Line x0,y0,x0,y0+QP*CellSize
	Line x0+QE*CellSize,y0,x0+QE*CellSize,y0+QP*CellSize

	Color 0,0,255
	For j=1 To QE
		For i=1 To QP
			If H(j,i)<0 g=16-StringWidth("-") Else g=16
			Text x0+(j-1)*CellSize+16,y0+(i-1)*CellSize+4,Str(H(i,j))
		Next
	Next
Case 3
	CellSize=40
	x0=512-(QP*CellSize)/2
	y0=384-(QP*CellSize)/2
	Color 0,0,128
	s$="Matrix of a transitive circuit"
	Text 512-StringWidth(s$)/2,20,s$
	Color 0,255,0
	Line x0,y0,x0,y0+QP*CellSize
	Line x0+QP*CellSize,y0,x0+QP*CellSize,y0+QP*CellSize

	Color 0,0,255
	For i=1 To QP
		For j=1 To QP
			Text x0+(j-1)*CellSize+16,y0+(i-1)*CellSize+4,Str(graph(i,j))
		Next
	Next		
Case 4
	CellSize=40
	x0=512-(QP*CellSize)/2
	y0=384-(QP*CellSize)/2
	Color 0,0,128
	s$="Matrix of a strong components"
	Text 512-StringWidth(s$)/2,20,s$
	Color 0,255,0
	Line x0,y0,x0,y0+QP*CellSize
	Line x0+QP*CellSize,y0,x0+QP*CellSize,y0+QP*CellSize

	Color 0,0,255
	For i=1 To QP
		For j=1 To QP
			Text x0+(j-1)*CellSize+16,y0+(i-1)*CellSize+4,Str(graph3(i,j))
		Next
	Next
Case 5
	CellSize=40
	x0=512-(QP*CellSize)/2
	y0=384-(QP*CellSize)/2
	Color 0,0,128
	s$="Transformed matrix of strong components"
	Text 512-StringWidth(s$)/2,20,s$
	Color 0,255,0

	qp2=0
	For i=0 To QP
		If graph4(i,0)<>0	 Or i=0
			If i<>0 qp2=qp2+1
			For j=0 To QP
				If graph4(0, j)<>0 Or j=0
					If i=0 Or j=0 Color 255,0,0 Else Color 0,0,255
					If i<>0 Or j<>0 Text x0+(j-1)*CellSize+16,y0+(i-1)*CellSize+4,Str(graph4(i,j))
				End If
			Next
		End If
	Next
	Color 0,255,0
	Line x0,y0,x0,y0+QP2*CellSize
	Line x0+QP2*CellSize,y0,x0+QP2*CellSize,y0+QP2*CellSize

	Line x0,y0,x0+QP2*CellSize,y0
	Line x0,y0+QP2*CellSize,x0+QP2*CellSize,y0+QP2*CellSize
	
Case 6
	CellSize=25
	x0=370
	y0=100
	
	Color 0,0,128
	s$="Detour in depth and width"
	Text 512-StringWidth(s$)/2,20,s$

	Color 0,255,0
	Text x0,y0-10,"u"
	Text x0+2*CellSize,y0-10,"T"
			
	maxs=0
	For i=1 To Qdepth
		Text x0,y0+i*CellSize,depth(i,0)
		j=1:s$=""
		While depth(i,j)<>0
			If depth(i,j+1)<>0 s$=s$+Str(depth(i,j))+"," Else s$=s$+Str(depth(i,j))
			j=j+1
		Wend
		If s$="" s$="empty"
		Text x0+2*CellSize,y0+i*CellSize,s$
		If Len(s$)>maxs maxs=Len(s$)
	Next
	
	Color 0,0,255
	Line x0-CellSize,y0+CellSize,x0+2*(6*CellSize+maxs),y0+CellSize
	Line x0-CellSize,y0+(Qdepth+2)*CellSize,x0+2*(6*CellSize+maxs),y0+(Qdepth+2)*CellSize
	Line x0+6*CellSize+maxs-25,y0,x0+6*CellSize+maxs-25,y0+(Qdepth+2)*CellSize
	Line x0+6*CellSize+maxs-15,y0,x0+6*CellSize+maxs-15,y0+(Qdepth+2)*CellSize

	x0=x0+6*CellSize+maxs
	Color 0,255,0
	Text x0,y0-10,"u"
	Text x0+2*CellSize,y0-10,"T"
	
	For i=1 To Qwidth
		Text x0,y0+i*CellSize,width(i,0)
		j=1:s$=""
		While width(i,j)<>0
			If width(i,j+1)<>0 s$=s$+Str(width(i,j))+"," Else s$=s$+Str(width(i,j))
			j=j+1
		Wend
		If s$="" s$="empty"
		Text x0+2*CellSize,y0+i*CellSize,s$
	Next	
	

	If m4st=1
		Color 0,255,0
		For i=1 To QP-1
			Line P(depth(i,0),1),P(depth(i,0),2)+100,P(depth(i+1,0),1),P(depth(i+1,0),2)+100
		Next
	
		For i=1 To QP
			Color 0,0,255
			Rect P(depth(i,0),1)-1,P(depth(i,0),2)-1+100,3,3
			Color 0,255,0
			Text P(depth(i,0),1),P(depth(i,0),2)+100,Str(depth(i,0))		
		Next
	Else
		Color 0,255,0
		For i=1 To QP-1
			j=1
			While width(i,j)<>0
				For k=1 To i-1
					n=1
					While width(k,n)<>0
						If width(k,n)=width(i,j) Goto na
						n=n+1
					Wend					
				Next
				 Line P(width(i,0),1),P(width(i,0),2)+100,P(width(i,j),1),P(width(i,j),2)+100
				.na
				j=j+1
			Wend
		Next
	
		For i=1 To QP
			Color 0,0,255
			Rect P(width(i,0),1)-1,P(width(i,0),2)-1+100,3,3
			Color 0,255,0
			Text P(width(i,0),1),P(width(i,0),2)+100,Str(width(i,0))		
		Next	
	End If
	
	If KeyHit(57) m4st=-m4st
	If m4st=1 s$="The Ostaph Tree(in Depth)" Else s$="The Ostaph Tree(in Width)"
	Color 255,255,255
	Text 512-StringWidth(s$)/2,740,s$
Case 7
	CellSize=25
	i=0

	Color 0,0,128
	s$="Ailer And gamilton cycles"
	Text 512-StringWidth(s$)/2,20,s$

	s$=""
	If First ste<>Null
		For u.ste = Each ste
			s$=Str(u\x)+","+s$
		Next
		s$="{"+Left(s$,Len(s$)-1)+"}"
		Color 0,255,0	
		Text 512-StringWidth(s$)/2,200,s$
		s$="Ailer cycles:"
		Text 512-StringWidth(s$)/2,170,s$		
	Else
		s$="Ailer cycles aren't found in graph"
		Color 0,255,0
		Text 512-StringWidth(s$)/2,200,s$
	End If
	
	findgamilton()
	If Qprint=0
		s$="Gamilton cycles aren't found in graph"
		Color 0,255,0
		Text 512-StringWidth(s$)/2,290,s$	
	End If
End Select
End Function

Function UpdateLol()
lolx=lolx+dlolx
loly=loly+dloly

Color 255,255,0
For i=1 To 90
	Line lolx+Cos(i*4)*15,loly+Sin(i*4)*15,lolx+Cos(i*4+4)*15,loly+Sin(i*4+4)*15
Next

Line lolx-8,loly-5,lolx-3,loly-5
Line lolx+3,loly-5,lolx+8,loly-5

Line lolx-4,loly+8,lolx+4,loly+8
Line lolx-6,loly+5,lolx-4,loly+8
Line lolx+4,loly+8,lolx+6,loly+5

Line lolx,loly-1,lolx,loly+3

SetFont font20
s$="LoL"
Text lolx-StringWidth(s$)/2,loly-35,s$

If lolx>=1008 dlolx=-dlolx
If lolx<=16 dlolx=-dlolx
If loly>=752 dloly=-dloly
If loly<=16 dloly=-dloly
End Function

Function Rotate#(a1#,a2#,b1#,b2#)
c#=ATan((a1#-b1#)/(a2#-b2#))
If (b1#-a1#)>0 And (b2#-a2#)<0
	c#=180-Abs(c#)
End If
If (b1#-a1#)<0 And (b2#-a2#)<0
	c#=180+c#
End If
If (b1#-a1#)<0 And (b2#-a2#)>0
	c#=360-Abs(c#)
End If
c#=-c#+90
If c#<-180 Return c#+360 Else Return c#
End Function

Function Graf()

For i=1 To QP
	For j=1 To QP
		graph(i,j)=M(i,j)
	Next
Next
For k=1 To QP
	For i=1 To QP
		For j=1 To QP
			If graph(i,j)=0 Then graph(i,j)=graph(i,k)*graph(k,j)
		Next
	Next
Next

For i=1 To QP
	graph(i,i)=1
Next

End Function

Function Graf2()

For i=1 To QP
	For j=1 To QP
		graph(i,j)=M(i,j)
	Next
Next


For k=1 To QP
	For i=1 To QP
		For j=1 To QP
			If graph(i,j)=0 Then graph(i,j)=graph(i,k)*graph(k,j)
		Next
	Next
Next

For i=1 To QP
	For j=1 To QP
		graph2(i,j)=graph(j,i)
	Next
Next

For i=1 To QP
	For j=1 To QP
		graph3(i,j)=graph2(i,j)*graph(i,j)
	Next
Next

For i=1 To QP
	graph(i,i)=1
Next

End Function

Function graf3()
gi=0:ki=1
For i=1 To QP
	For j=1 To QP
		For k=1 To gi
			If graph4(k,0)=j Goto nextaction
		Next		
		If graph3(i,j)=1
			gi=gi+1
			graph4(gi,0)=j
		End If
		.nextaction
	Next
	
	For j=1 To gi
		If graph4(j,0)<>0 graph4(0,j)=graph4(j,0)
	Next
	For j=ki To gi
		For k=ki To gi
			graph4(j,k)=1
		Next
	Next
	ki=gi+1
Next

End Function

Function Detour()
Local note[100]

For i=1 To QP
	sm(i,0)=0
Next

For i=1 To QP
	For j=1 To QP
		If m(i,j)=1
			sm(i,0)=sm(i,0)+1
			sm(i,sm(i,0))=j
		End If
	Next
Next


For i=1 To 99
	For j=1 To 99
		Depth(j,i)=0
	Next
Next
QDepth=0

t.list=New list
t\x=1
note[1]=1
Repeat
	u.list = Last list
	x=u\x
	QDepth=QDepth+1
	Depth(QDepth,0)=x
	Delete u
	For w=1 To sm(x,0)
		If note[sm(x,w)]=0
			t.list=New list
			t\x=sm(x,w)
			note[sm(x,w)]=1
		End If
	Next
	i=0
	For n.list=Each list
		i=i+1
		Depth(QDepth,i)=n\x
	Next
Until Last list=Null


For i=1 To 99
	note[i]=0
Next

For i=1 To 99
	For j=1 To 99
		width(j,i)=0
	Next
Next
Qwidth=0

t.list=New list
t\x=1
note[1]=1
Repeat
	u.list = First list
	x=u\x
	Qwidth=Qwidth+1
	width(Qwidth,0)=x
	Delete u
	For w=1 To sm(x,0)
		If note[sm(x,w)]=0
			t.list=New list
			t\x=sm(x,w)
			note[sm(x,w)]=1
		End If
	Next
	i=0
	For n.list=Each list
		i=i+1
		width(Qwidth,i)=n\x
	Next
Until First list=Null

End Function

Function ailer()
Delete Each stack
Delete Each ste

For i=1 To QP
	For j=1 To QP
		m2(i,j)=m(i,j)
	Next
Next

v=1
s.stack=New stack
s\x=v
While First stack<>Null
	s.stack=Last stack
	v=s\x
	v1=Handle(s)
	For i=1 To QP
		If m2(v,i)<>0 Goto na
	Next
	i=0
	.na
	If i<>0
		s.stack=New stack
		s\x=i
		m2(v,i)=0:m2(i,v)=0
	Else
		u.stack=Object.stack(v1)
		Delete u
		s2.ste=New ste
		s2\x=v
	End If
Wend

s1.ste=First ste
If 1<>s1\x Delete Each ste

End Function

Function FindGamilton()
Qprint=0
For j=1 To QP
	dop(j)=1
	ver(j)=0
Next
ver(1)=1
dop(1)=0
gamilton(2)
End Function

Function gamilton(k)
For i=1 To QP
	If m(ver(k-1),i)=1
		If k=QP+1 And i=ver(1)
			printgam()
		Else
			If dop(i)=1
				ver(k)=i
				dop(i)=0
				gamilton(k+1)
			End If
		End If
		dop(i)=0
	End If
Next
End Function

Function printgam()
s$=""
For i=1 To QP
	s$=ver(QP-i+1)+","+s$
Next
s$="{"+Left(s$,Len(s$)-1)+","+Str(ver(1))+"}"
Color 0,255,0	
Text 512-StringWidth(s$)/2,290+Qprint,s$
s$="Gamilton cycles:"
Text 512-StringWidth(s$)/2,260+Qprint,s$
Qprint=Qprint+30
End Function
(Offline)
 
 Ответить с цитированием