Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
2D Hierarchical Editor
#1
I'm working on a 2D editor that allows to make hierarchical animation
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
Have a Nice day
Biskbart
iskbart
Reply
#2
hmmm... what does it do?
Reply
#3
that's what i was thinking. so far i made neat circles and lines with boxes. and i can't seem to delete nodes. otherwise, pretty cool.
quote="whitetiger0990"]whitetiger is.. WHITE POWER!!! [/quote]
Here
Reply
#4
Welcome back, Biskbart!

So FreeBasic has made you to come back from the C land?
You disappeared after the last Toshi demo contest back in 2002 and erased your QB site before I could rip all your code ;D

The editor is fun, but all I can do is stretch the lines and circles, I guess there will be some way of fixing its length when the animation comes. A suggestion, use different colors for the links , nodes and circles, now it's a little messy.

Bienvenue!
Antoni
Reply
#5
You can rip code from here
http://biskbart.free.fr/nouveau/frame.htm
Weel i'm working but slowly because of real life ( i ve got a job , i cannot be a lazy student lol )
I will post my code here each time i can
Cheers
iskbart
Reply
#6
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
Reply
#7
You've got something here, I'd really like to see which direction it goes in. Props to you man. Big Grin
Reply


Forum Jump:


Users browsing this thread: 1 Guest(s)