02-13-2006, 12:28 AM
You can erase object I'm workin on intersection. It's a bit hard !
Code:
Declare Sub AffNode()
Declare Sub AffLink()
Declare Sub Refresh()
Declare Sub AffMouse ( Forme% , x , y)
Declare Sub AffChaine(X%,Y%,T$,Mode%)
Declare Sub Box(X%,Y%,L%,H%)
Declare Sub BoxR(X%,Y%,L%,H%)
Declare Sub Button(X%,Y%,Text$,Mode%)
Declare Function CreeMenu%(Chaine$,Pere%)
Declare Function GetFree%
Declare Sub AffMenuTexte(Num%,T$)
Declare Sub InitMenu()
Declare Sub TextBox(X%,Y%,Text$,Mode%)
Declare Function PicMenu$(x,y,Num%,SubMenu$)
Declare Function GetInMenu%(Num%,Length%)
Declare Function InZone%(X%,Y%,L%,H%)
Declare Sub SearchObject
Declare Sub DeleteObject(Kind%,Number%)
Type Menu : Title As String : Pere As Integer : Libre As Byte : End Type
Const MaxMenu% = 1000 : Dim Shared Menus(1 To MaxMenu%) As Menu : Dim Shared Car%(0 To 255,0 To 256),CarHigh%
CarHigh% = 15
Screen 19,,2
Type Node
X As Integer
Y As Integer
Color As Integer
Exist As Byte
OnObject As Integer
Number As Integer
End Type
Type Cercle
Node1 As Integer
Node2 As Integer
Color As Integer
Exist As Byte
End Type
Type Link
Node1 As Integer
Node2 As Integer
Length As Integer ' 0 : can change
Angle As Integer ' From Another Link |
FLink As Integer ' Father link |
MinAngle As Integer
MaxAngle As Integer
Color As Integer
Exist As Byte
End Type
Dim Shared Son(0 To 1000) As Node
Dim Shared Links(0 To 1000) As Link
Dim Shared Cercles(0 To 1000) As Cercle
Dim Shared NbNode%, NbLink%, NbCercle%
' Function
Type Fonction
Title As String
ShortCut As String
End Type
Dim Shared MaxFunction% : MaxFunction% = 10
Dim Shared Fonctions(1 To MaxFunction%) As Fonction
Dim Shared InFo$
RESTORE Dat1
Cpt%=0
Do
Read T1$,T2$
If T1$="" Then Exit Do
Cpt%=Cpt%+1
Fonctions(Cpt%).Title=T1$
Fonctions(Cpt%).ShortCut=T2$
Loop
Dat1:
Data "Put/Move Node","N"
Data "Make Link","L"
Data "Make circle","C"
Data "Put Node on Object","P"
Data "Make Link with Length's contraint","M"
Data "Erase Node","E"
Data "",""
' End Function
Dim Shared x,y,Forme%, Funct%
NbNode% = 0
NbLink% = 0
Forme% = 0
Dim Shared XMax%, YMax% : SCREENINFO XMax%, YMax%
InitMenu
T$=""
For I%=1 To Cpt%
T$=T$+Fonctions(I%).Title+" ("+Fonctions(I%).ShortCut+"),"
Next I%
Menu$="["+T$+"File[New,Save,Exit]]"
MainMenu% = -1 : Num% = CreeMenu%(Menu$,MainMenu%)
'AffMenuTexte Men%,"" : Sleep
'TextBox 8,8,"Bonjour|comment vas-tu ?|super",2
Type Object
Kind As Integer
Number As Integer
End Type
Dim Shared OnObjet%, OnObject(0 To 50) As Object
SCREENSET 1, 0
SETMOUSE 0, 0, 0
Do
SearchObject 'OnObject.Kind,OnObject.Number
A$= Inkey$
If A$<>"" Then
For I%=1 To MaxFunction%
If Ucase$(A$)=Fonctions(I%).Shortcut Then Funct%=I%
Next I%
EndIf
GETMOUSE x, y,, buttons
If (buttons = 2) Then
SCREENSET 0, 0
SETMOUSE x, y, 1
P$ = PicMenu$(x,y,MainMenu%,"")
For I%=1 To MaxFunction%
If P$=Fonctions(I%).Title+" ("+Fonctions(I%).ShortCut+")" Then Funct%=I%
Next I%
Do : GETMOUSE x, y,, buttons : Loop Until buttons=0
SCREENSET 1, 0
SETMOUSE x, y, 0
EndIf
' On a node ?
Sel% = -1
For I%=0 To NbNode% - 1
If Son(I%).Exist = 1 Then
Xt%=Son(I%).x
Yt%=Son(I%).y
Son(I%).Color = 0
If x>=Xt%-2 and y>=Yt%-2 and x%<=Xt%+2 and y%<=Yt% + 2 Then Sel%=I%
EndIf
Next I%
If Sel%<>-1 Then Son(Sel%).Color = 1 : Forme% = 2 Else Forme% = 1
If First% = 1 Then Son(Select1%).Color = 1
If (buttons and 1) And (Funct% = 5 Or Funct% = 6) Then
Select Case Funct%
Case 6
If OnObjet%>0 Then
For I%=1 To OnObjet%
DeleteObject OnObject(I%).Kind,OnObject(I%).Number
Next I%
End If
End Select
Endif
' Make Link
If (buttons and 1) And Sel%<>-1 And (Funct% = 2 Or Funct% = 3) Then
If First% = 0 Then
Select1% = Sel%
Son(Sel%).Color = 1
First% = 1
Refresh
Do : GETMOUSE x, y,, buttons : Loop Until buttons=0
Else
If Select1% = Sel% Then
First% = 0
Else
Select Case Funct%
Case 2
Links(NbLink%).Node1 = Select1%
Links(NbLink%).Node2 = Sel%
Links(NbLink%).Exist = 1
NbLink%=NbLink%+1
Case 3
Cercles(NbCercle%).Node1 = Select1%
Cercles(NbCercle%).Node2 = Sel%
Cercles(NbCercle%).Exist = 1
NbCercle%=NbCercle%+1
Case 4
Links(NbLink%).Node1 = Select1%
Links(NbLink%).Node2 = Sel%
X1% = Son(Links(NbLink%).Node1).x
Y1% = Son(Links(NbLink%).Node1).y
X2% = Son(Links(NbLink%).Node2).x
Y2% = Son(Links(NbLink%).Node2).y
Length% = SQR((X2%-X1%)^2+(Y2%-Y1%)^2)
Links(NbLink%).Length=Length%
Links(NbLink%).Exist = 1
NbLink%=NbLink%+1
End Select
Refresh
Do : GETMOUSE x, y,, buttons : Loop Until buttons=0
First% = 0
End If
End If
End If
' -> Move Node
If (buttons and 1) And Sel%<>-1 And Funct% = 1 Then
Do
GETMOUSE x, y,, buttons
' Length Contrain
' For I%=0 To NbLinks% - 1
' N1% = Links(I%).Node1
' N2% = Links(I%).Node2
' If Links(I%).Length<>0 And ( N1% = Sel% Or N2%=Sel% ) Then Contrain% = I%:Exit For
' Next I%
Son(Sel%).x = x
Son(Sel%).y = y
Refresh
Loop Until buttons = 0
End if
If ucase$(A$)="N" then Funct% = 1 : First% = 0
If ucase$(A$)="L" then Funct% = 2
' Make node
If (buttons AND 1) and Funct% = 1 And Sel%=-1 Then
Son(NbNode%).X = x
Son(NbNode%).Y = y
Son(NbNode%).Exist = 1
Son(NbNode%).OnObject = -1
NbNode% = NbNode% + 1
Do : GETMOUSE x, y,, buttons : Loop Until buttons=0
End if
' Put node on object
If (buttons AND 1) and Funct% = 4 And Sel%=-1 Then
If OnObjet% > 1 Then
SCREENSET 0, 0 : SETMOUSE x, y, 1
TextBox -1,-1,"Click On One object only",1
SCREENSET 1, 0 : SETMOUSE x, y, 0
ElseIf OnObjet% = 0 Then
SCREENSET 0, 0 : SETMOUSE x, y, 1
TextBox -1,-1,"Click On One object",1
SCREENSET 1, 0 : SETMOUSE x, y, 0
EndIf
EndIf
Refresh
Loop Until A$=Chr$(27)
Sub SearchObject
OnObjet% = 0
Info$ = "Mouse on "
GETMOUSE x, y,, buttons
For I%=0 To NbNode% - 1
Xt%=Son(I%).x
Yt%=Son(I%).y
' Son(I%).Color = 0
If x>=Xt%-2 and y>=Yt%-2 and x%<=Xt%+2 and y%<=Yt% + 2 And Son(I%).Exist = 1 Then
Info$ = Info$ + "Node "+str(I%)+", "
OnObjet%=OnObjet%+1
OnObject(OnObjet%).Kind = 1
OnObject(OnObjet%).Number = I%
EndIf
Next I%
For I%=0 To NbCercle% - 1
If Cercles(I%).Exist Then
Cercles(I%).Color = 0
Xt%=Son(Cercles(I%).Node1).x
Yt%=Son(Cercles(I%).Node1).y
R# = (Son(Cercles(I%).Node1).x-Son(Cercles(I%).Node2).x)^2+(Son(Cercles(I%).Node1).y-Son(Cercles(I%).Node2).y)^2
If R#<0.00001 Then R#=0.00001
R2# = (x-Xt%)^2+(y-Yt%)^2
If R2#<R# Then Swap R2#,R#
If R2#/R#<1.1 Then
Info$ = Info$ + "Circle "+str(I%)+", " ' Tolerance 1.1 is good !
Cercles(I%).Color = 1
OnObjet%=OnObjet%+1
OnObject(OnObjet%).Kind = 3
OnObject(OnObjet%).Number = I%
End If
End If
'Info$ = Info$ + "Mouse "+str(R2#)+", Rayon :"+str(R#)
Next I%
For I%=0 To NbLink% - 1
If Links(I%).Exist = 1 Then
Links(I%).Color = 0
Xa%=Son(Links(I%).Node1).x : Ya%=Son(Links(I%).Node1).y
Xb%=Son(Links(I%).Node2).x : Yb%=Son(Links(I%).Node2).y
Xac%= x-Xa%:Yac%= y-Ya%
Xbc%= x-Xb%:Ybc%= y-Yb%
' Vector product
Prod% = Abs(Xac% * Ybc% - Yac% * Xbc%)
In% = 0
If Sgn(Ybc%) * Sgn(Yac%) <= 0 And Sgn(Xbc%) * Sgn(Xac%) <= 0 Then In%=1
If Prod%<150 And In%=1 Then
Links(I%).Color = 1
Info$ = Info$ + "Link "+str(I%)+", " ' Tolerance 150 is fine !
OnObjet%=OnObjet%+1
OnObject(OnObjet%).Kind = 2
OnObject(OnObjet%).Number = I%
Endif
EndIf
Next I%
End Sub
Sub DeleteObject(Kind%,Number%)
Select Case Kind%
Case 1
Son(Number%).Exist = 0
For I%=0 To NbCercle%-1
If Cercles(I%).Node1 = Number% or Cercles(I%).Node2 = Number% Then
Cercles(I%).Exist = 0
End If
Next I%
For I%=0 To NbLink%-1
If Links(I%).Node1 = Number% or Links(I%).Node2 = Number% Then
Links(I%).Exist = 0
End If
Next I%
Case 2
Links(Number%).Exist = 0
Case 3
Cercles(Number%).Exist = 0
End Select
End Sub
Sub Move(Node%,DecaX%,DecaY%)
For I%=0 To NbNode%-1
Next I%
End Sub
Sub AffLink
For I%=0 To NbLink%-1
If Links(I%).Exist Then Line(Son(Links(I%).Node1).x,Son(Links(I%).Node1).y)-(Son(Links(I%).Node2).x,Son(Links(I%).Node2).y),15-Links(I%).Color
Next I%
End Sub
Sub AffCircle
For I%=0 To NbCercle%-1
If Cercles(I%).Exist Then
R% = SQR((Son(Cercles(I%).Node1).x-Son(Cercles(I%).Node2).x)^2+(Son(Cercles(I%).Node1).y-Son(Cercles(I%).Node2).y)^2)
Circle (Son(Cercles(I%).Node1).x,Son(Cercles(I%).Node1).y),R%,15-Cercles(I%).Color
End If
Next I%
End Sub
Sub AffNode
For I%=0 To NbNode%-1
If Son(I%).Exist Then
If Son(I%).Color = 0 Then C% = 7 else C% = 14
Line(Son(I%).x-1,Son(I%).y-1)-step(3,3),C%,b
EndIf
Next I%
End Sub
Sub AffMouse ( Forme%, x , y )
Select Case Forme%
Case 1
Line (x-7,y)-step(14,0),15
Line (x,y-7)-step(0,14),15
Case 2
Line (x-3,y-3)-step(6,6),15,b
End Select
End Sub
Sub Refresh
CLS
AffNode
AffLink
AffCircle
AffMouse Forme% , x , y
' Locate 24,1 : Print Funct$(Funct%)
Button 0,YMax%-CarHigh%-10,Fonctions(Funct%).Title + " X :"+str(x)+" ; Y :"+str(y)+ " Funct : "+str(Funct%) ,0
Button 0,0,Info$ ,0
WAIT &h3DA, 8
SCREENCOPY
End Sub
Sub InitMenu
For I%=0 to 255
Locate 1,1
If I%<>7 Then Print Chr$(I%):Get (0,0)-(7,CarHigh%),Car%(I%,0)
Next I%
end sub
Sub AffChaine(X%,Y%,T$,Mode%)
Select Case Mode%
Case 1
For I%=0 To Len(T$)-1
Put (X%+I%*8,Y%),Car%(Asc(Mid$(T$,I%+1,1)),0),TRANS
Next I%
Case 2
For I%=0 To Len(T$)-1
Put (X%+I%*8,Y%),Car%(Asc(Mid$(T$,I%+1,1)),0),Alpha
Next I%
End Select
End Sub
Function GetInMenu%(Num%,Length%)
Cpt% = 0
MaxL% = 0
For I%=1 to MaxMenu%
If Menus(I%).Pere = Num% Then
Cpt% = Cpt% + 1
Length% = Len(Menus(I%).Title)
If Length%>MaxL% Then MaxL% = Length%
End If
Next I%
Length% = MaxL%
GetInMenu% = Cpt%
End Function
Function PicMenu$(x%,y%,Num%,SubMenu$)
Dim TmpMenu$(0 To 100)
Dim TmpMenu%(0 To 100)
Length% = 0
Cpt% = GetInMenu%(Num%, Length%)
H% = (CarHigh%+4) * Cpt% + 2
L% = 8 * Length% + 22
If X%+L%>XMax% Then X% = XMax%-L%-1
If Y%+H%>YMax% Then Y% = YMax%-H%-1
Dim Image%(0 To L%*H%+4)
Get (x%,y%)-Step(L%,H%),Image%
Box x%,y%,L%,H%
T% = 0
For I% = 0 To Cpt%-1
Do
If Menus(T%).Pere = Num% Then Exit Do
T%=T%+1
Loop
TmpMenu$(I%)=Menus(T%).Title : TmpMenu%(I%)=T%
If GetInMenu%(T%,Tmp%)<>0 Then C$=String(Length%-Len(Menus(T%).Title)+1," ")+">" else C$=""
AffChaine X% + 4,Y% + I% * (CarHigh% + 4 ) + 3,Menus(T%).Title+C$, 1
T%=T%+1
Next I%
SETMOUSE x%+5, y+5%
OldSel%=-1
Do
GETMOUSE x1, y1,, buttons
If x1>x% And y1>y% and x1<x%+L% And y1<y%+H%-4 Then
'''''''''''''''''''''''''''''''''''''''''''
'''''''''''''' Surligner et ouvrir sous menu
Men% = (y1-Y%-3)\(CarHigh%+2)
If Men%>Cpt%-1 Then Men%=Cpt%-1
'If GetInMenu%(TmpMenu%(Men%),Tmp%)<>0 Then C$=String(Length%-Len(TmpMenu$(Men%))+1," ")+">" else C$=String(Length%-Len(TmpMenu$(Men%))+2," ")
If Men%<>OldSel% Then
If OldSel% <> -1 Then Line(x%+2,y%+2+OldSel%*(CarHigh% + 4))-Step(L%-4,CarHigh%+2),9,B
BoxR% x%+2,y%+2+Men%*(CarHigh% + 4),L%-4,CarHigh%+2
OldSel% = Men%
End If
If buttons = 1 Then
If GetInMenu%(TmpMenu%(Men%),Tmp%)<>0 Then
Do : GETMOUSE xt, yt,, buttons : Loop Until buttons = 0
'If SubMenu$<>"" Then S$ = SubMenu$+">" Else S$ = ""
T$ = PicMenu$(x%+L%+1,y%+2+OldSel%*(CarHigh% + 4),TmpMenu%(Men%),SubMenu$+TmpMenu$(Men%)+">")
If T$<>TmpMenu$(Men%)+">" Then PicMenu$=T$ : Put(x%,y%),Image%,Pset:Erase Image%,TmpMenu%,TmpMenu$ : Exit Function
Else
PicMenu$=SubMenu$+TmpMenu$(Men%)
Put(x%,y%),Image%,Pset:Erase Image%,TmpMenu%,TmpMenu$
Exit Function
End If
End If
'AffChaine X% + 4,Y% + Men% * (CarHigh% + 2 ) + 3,TmpMenu$(Men%)+C$, 2
else
If OldSel%<>-1 Then Line(x%+2,y%+2+OldSel%*(CarHigh% + 4))-Step(L%-4,CarHigh%+2),9,B:OldSel%=-1
Put(x%,y%),Image%,Pset : Erase Image%,TmpMenu%,TmpMenu$ : exit function
end if
Loop
End Function
Sub Box(X%,Y%,L%,H%)
Line(X%,Y%)-Step(L%,H%),9,BF
Line(X%,Y%)-Step(L%,H%),15,B
Line(X%+L%,Y%)-Step(0,H%),0
Line(X%,Y%+H%)-Step(L%,0),0
End Sub
Function InZone%(X%,Y%,L%,H%)
GetMouse x1,y1
If x1>x% and y1>Y% and x1<x%+L% and y1<y%+H% then InZone% = 1 else InZone% = 0
End Function
Sub Button(X%,Y%,Text$,Mode%)
L% = 8 * Len(Text$) + 10
Box X%,Y%,L%,CarHigh% + 10
If Mode% Then BoxR X%,Y%,L%,CarHigh% + 10
AffChaine$ X%+5,Y%+5,Text$,1
End Sub
Sub TextBox(X%,Y%,Text$,Mode%)
' -1 : Center for X% and Y%
' Mode 0 : To the left
' Mode 1 : Center
' Mode 2 : To The rigth
Dim Ligne$(0 To 50) ' -> It will be enough lol
MaxL% = 0
Tmp$ = Text$
Cpt% = 0
Do
A% = Instr(Tmp$,"|")
If A% = 0 Then Ligne$(Cpt%)=Tmp$ : Exit Do
Ligne$(Cpt%) = Mid(Tmp$,1,A%-1)
Tmp$=Mid(Tmp$,A%+1,Len(Tmp$))
Cpt%=Cpt%+1
Loop
For I%=0 To Cpt%
If Len(Ligne$(I%))>MaxL% Then MaxL% = Len(Ligne$(I%))
Next I%
L% = MaxL% * 8 + 10
H% = 35 + (CarHigh%+2) * (Cpt%+1)
Dim Image%(0 To L%*H%+4)
Get (X%,Y%)-Step(L%,H%),Image%
If X% = -1 Then X% = (XMax% - L%)\2
If Y% = -1 Then Y% = (YMax% - H%)\2
Box X%,Y%,L%,H%
For I%=0 To Cpt%
T% = Len(Ligne$(I%))
Select Case Mode%
Case 0
AffChaine x% + 5,Y% + 5 + I% * ( CarHigh% + 2 ),Ligne$(I%),1
Case 1
AffChaine x% + (L%-(8 * Len(Ligne$(I%))))\2,Y% + 5 + I% * ( CarHigh% + 2 ),Ligne$(I%),1
Case 2
AffChaine x% + L%-(5+8 * Len(Ligne$(I%))),Y% + 5 + I% * ( CarHigh% + 2 ),Ligne$(I%),1
End Select
Next I%
Tex$="Ok"
L2% = 8 * Len(Tex$) + 10
Button X%+(L%-L2%)\2,Y%+H%-CarHigh%-15,Tex$,0
Do
GETMOUSE xt, yt,, buttons
If buttons = 1 And InZone%(X%+(L%-L2%)\2,Y%+H%-CarHigh%-15,L2%,CarHigh%+10) Then
Button X%+(L%-L2%)\2,Y%+H%-CarHigh%-15,Tex$,1
Do : GETMOUSE xt, yt,, buttons : Loop Until buttons = 0
Exit Do
EndIf
Loop
Put (X%,Y%),Image%,Pset
End Sub
Sub BoxR(X%,Y%,L%,H%)
Line(X%,Y%)-Step(L%,H%),0,B
Line(X%+L%,Y%)-Step(0,H%),15
Line(X%,Y%+H%)-Step(L%,0),15
End Sub
Function GetFree%
Cpt% = 0
Do
Cpt%=Cpt%+1
Loop Until Menus(Cpt%).Libre = 0
GetFree% = Cpt%
End Function
Sub AffMenuTexte(Num%,T$)
For I% = 1 To MaxMenu%
If Menus(I%).Pere = Num% Then
Print T$;"|-";Menus(I%).Title';"(";I%;"- Pere : ";Menus(I%).Pere;")"
AffMenuTexte(I%,T$+" ")
Endif
Next I%
End Sub
Function CreeMenu%(Chaine$,Pere%)
' Print Chaine$:sleep
'Print T$
Do
Label1:
If Chaine$="[]" Then Exit Function
A% = INSTR(Chaine$,"[")
If A%<>1 Then CreeMenu% = -1:Exit Function
T$ = Mid$(Chaine$,2,Len(Chaine$)-1)
B% = INSTR(T$,"[")
C% = INSTR(T$,"]")
D% = INSTR(T$,",")
If D%<B% Then
Pere2% = GetFree%
Menus(Pere2%).Libre = 1
Menus(Pere2%).Pere = Pere%
Menus(Pere2%).Title = Mid(T$,1,D%-1)
Chaine$="["+Mid(T$,D%+1)
Goto Label1
End If%
If B%<> 0 Then
' We get the end of the menu
Cpt% = 0
'? T$; Len(T$): Sleep
CloseT% = 0
For I%=1 To Len(T$)
C$= Mid(T$,I%,1)
' ? C$;I% ; Cpt% ; Ex% : sleep
If C$="[" Then Cpt%=Cpt%+1
If C$="]" Then Cpt%=Cpt%-1: CloseT% = 1
If Cpt% = 0 And CloseT% = 1 Then Ex% = I% : Exit For
' If Cpt% = 0 Then ? I%:Exit For
Next I%
Pere2% = GetFree%
Menus(Pere2%).Libre = 1
Menus(Pere2%).Pere = Pere%
Menus(Pere2%).Title = Mid(T$,1,B%-1)
' Menus(Pere2%).Title
If Cpt% = 0 And CloseT% = 1 Then
SsChaine$=Mid(T$,B%,Ex%-B%+1)
Chaine$="["+Mid(Chaine$,Ex%+3,Len(Chaine$))
' ? Mid(T$,1,B%-1);" | ";SsChaine$; " | "; Chaine$:sleep
CreeMenu%(SsChaine$,Pere2%)
EndIf
Else
Chaine2$ = Mid$(T$,1,Len(T$)-1)
' ? Chaine2$:sleep
Do
A% = Instr(Chaine2$,",")
If Chaine2$="[" Or Chaine2$="[]" Or Chaine2$="" Then Exit Do
If A%= 0 Then
Pere2% = GetFree%
Menus(Pere2%).Libre = 1
Menus(Pere2%).Pere = Pere%
Menus(Pere2%).Title = Mid(Chaine2$,1,Len(Chaine2$))
Exit Do
Else
Pere2% = GetFree%
Menus(Pere2%).Libre = 1
Menus(Pere2%).Pere = Pere%
Menus(Pere2%).Title = Mid(Chaine2$,1,A%-1)
Chaine2$ = Mid(Chaine2$,A%+1,Len(Chaine2$))
' ? Chaine2$;"|";Pere%
End If
'? Chaine2$ ; sleep
Loop
'Chaine$="[]"
Exit Function
End If
Loop
End Function
iskbart