02-10-2006, 11:25 PM
I'm working on a 2D editor that allows to make hierarchical animation
Here's the beginning
Have a Nice day
Biskbart
Here's the beginning
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(Kind As Byte,Number As Integer)
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
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 ' -1 can change
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 "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 Byte
Number As Integer
End Type
Dim Shared OnObject 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
' 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
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
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
NbNode% = NbNode% + 1
Do : GETMOUSE x, y,, buttons : Loop Until buttons=0
End if
Refresh
Loop Until A$=Chr$(27)
Sub SearchObject(Kind As Byte, Number As Integer)
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 Then Info$ = Info$ + "Node "+str(I%)+", "
Next I%
For I%=0 To NbCercle% - 1
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 !
'Info$ = Info$ + "Mouse "+str(R2#)+", Rayon :"+str(R#)
Next I%
For I%=0 To NbLink% - 1
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 Info$ = Info$ + "Link "+str(I%)+", " ' Tolerance 150 is fine !
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
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
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) ,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
Biskbart
iskbart