Hello all, I am working on a 'Carcassonne'-like game. The game starts with a specific tile at e.g. 0, 0 location. Each turn, the player can then add a tile adjacent to the tiles placed so far (left, right, above or below). There are no real boundaries, we play at a near-infinite sized 'table'.
I am looking for a good data structure to store this map, ideas so far:
A) Just declare a big array e.g. map(2000, 2000) and start at the center. Easy solution, but not so elegant.
B) A 2-dimensional doubly linked list. That turned out insanely complex.
C) A simple list that stores all the tile ids and coordinates. I am worried about performance here. (going down as the map grows)
D) Use redim preserve. I tried that, but it does not work well for 2d-arrays or when changing the lower boundary. (as documented I found later)
Any suggestions? I don't like any of the above. Maybe a tree structure? Sort by 'x'-coordinate, then by 'y'-coordinate?
Also: Tiles are never removed, only added (unless I change my mind later). Checking for neighbor tiles is done often.
2d data structure without fixed boundaries
Re: 2d data structure without fixed boundaries
In order to make the array 'single dimension', you could use a UDT (struct).
Then make/use a array of UDT.
Below example is just a idea:
Then make/use a array of UDT.
Below example is just a idea:
Code: Select all
Type tile_t
Dim As Long x, y, id ' coordinates & id
Dim As Long nl, na, nr, nb ' id's of neighbors (left, above, right, below)
End TypeRe: 2d data structure without fixed boundaries
Yes, that might do it. One problem I see, is that if want to display only a section of the map, I will have to go through the whole list. Unlike in the case of 2d-arrays.MrSwiss wrote:In order to make the array 'single dimension', you could use a UDT (struct).
...
Maybe I should put the thing a nice class, so that I can change the data structure later without changing the interface.
-
Lost Zergling
- Posts: 538
- Joined: Dec 02, 2011 22:51
- Location: France
Re: 2d data structure without fixed boundaries
You might find it useful to simultaneously manage a relative and absolute coordinate system, don't know, not sure relative coordinate relevant. Relative to easily add an adjacent room and / or to have a tree identifier, absolute to verify the presence and conformity of other adjacent rooms following the addition. You could use tables with a slippery repository and difficult algos. You could perhaps also solve this type of problem with lzle using a double index: relative path (from the first piece) in key, coordinates in value, copycat or copytrack in second list linked to the first and indexed on the coordinates. It's cumbersome, but some simplification of the algorithms thanks to features and no memory management. On the other hand, with the increase in the number of rooms and a dense map, this option becomes irrelevant, would need to dynamically deindex adjacent -full used no room left groups of slots or slots having their 4 sides used ?
Otherwise, you may need an arrays and a hash tables on the coordinates?
Otherwise, you may need an arrays and a hash tables on the coordinates?
Re: 2d data structure without fixed boundaries
Linked lists are available in GLib, you needn't code yourself. Even a single linked list would be fast enough, when you work with multiple entry points.
But what about a four linked list, linking to the neighbour tiles in north, east, south and west direction? Similar to the MrSwiss idea, but linking to the tiles directly:
But what about a four linked list, linking to the neighbour tiles in north, east, south and west direction? Similar to the MrSwiss idea, but linking to the tiles directly:
Code: Select all
TYPE tile_t
AS tile_t PTR _
north _ '*< top neighbour
, east _ '*< right neighbour
, south _ '*< bottom neighbour
, west '*< left neighbour
AS LONG _
X _ '*< position
, Y _ '*< position
'...
END TYPERe: 2d data structure without fixed boundaries
I have never heard of people implementing a four linked list. It wouldn't be too complicated to implement, but logically, it wouldn't make much sense.
The main point of a linked list is the possibility to delete or insert an element, and that works perfectly in a simple list:
A --- B --- C
if I delete the B element, A will link to C and C will link to A, so the list will still work.
But let's imagine the same in 2D:
Let's imagine I start from element H, and move to right (I), then up (F), then left (E), and then down: I am back to the starting point, as I am supposed to be.
What happens if I remove the element E?
Starting from element H, and move to right (I), then up (F), then left (D, since E doesn't exist anymore), and then down, I would end in position G!
Also, imagine if I try to add an element in such a grid: if I added an element Z after E, what would I get?
What is supposed to be upward and downward Z?
That's why 2d linked lists don't make much sense. Instead, a thing that can be done is a linked list of linked lists (or also a dynamic array of dynamic arrays): it would be 2d, and extendable in all directions. It can be achieved with a wise usage of array pointers, or by representing each tile with a character, and having a dynamic array of strings
The main point of a linked list is the possibility to delete or insert an element, and that works perfectly in a simple list:
A --- B --- C
if I delete the B element, A will link to C and C will link to A, so the list will still work.
But let's imagine the same in 2D:
Code: Select all
A - B - C
| | |
D - E - F
| | |
G - H - I
What happens if I remove the element E?
Code: Select all
A - B - C
| | |
D - + - F
| | |
G - H - I
Also, imagine if I try to add an element in such a grid: if I added an element Z after E, what would I get?
Code: Select all
A - B - C
| | |
D - E-Z-F
| | |
G - H - I
That's why 2d linked lists don't make much sense. Instead, a thing that can be done is a linked list of linked lists (or also a dynamic array of dynamic arrays): it would be 2d, and extendable in all directions. It can be achieved with a wise usage of array pointers, or by representing each tile with a character, and having a dynamic array of strings
Re: 2d data structure without fixed boundaries
@angros47: It seems you don't know the Carcassone game. Read the first post carefully. Tiles get added only, not removed. There're no intermediate Z-like positions.
BTW:
BTW:
Multi linked lists are used for several aims, like ie. in this caller/callee graphs -- not to add or remove nodes, but in order to optimize the nodes position in the graph.angros47 wrote:I have never heard of people implementing a four linked list.
Re: 2d data structure without fixed boundaries
A spatial hash?badidea wrote:...
Any suggestions?...
https://www.gamedev.net/tutorials/progr ... ing-r2697/
Re: 2d data structure without fixed boundaries
You can do a custom redim preserve to keep things right:
Code: Select all
#macro redimpreserve(a,d1,d2)
Scope
Dim As Integer x,y
Redim As Typeof(a) copy(d1,d2)
For x =d1
For y=d2
If x>=Lbound(a,1) And x<=Ubound(a,1) Then
If y>=Lbound(a,2) And y<=Ubound(a,2) Then
copy(x,y)=a(x,y)
End If
End If
Next y
Next x
Redim a(d1,d2)
For x= d1
For y=d2
a(x,y)=copy(x,y)
Next y
Next x
End Scope
#endmacro
#macro printout(d)
print
For n As Long=Lbound(d,1) To Ubound(d,1)
For m As Long=Lbound(d,2) To Ubound(d,2)
Print d(n,m);
Next m
Print
Next n
Print
#endmacro
Dim As Double s(1 To 2,3)={{1,2,3,4},_ 'easy to write down
{5,6,7,8}}
Redim Shared As Double d(1 To 2,3)
For n As Long=Lbound(s,1) To Ubound(s,1) 'transfer to a dynamic array.
For m As Long=Lbound(s,2) To Ubound(s,2)
d(n,m)=s(n,m)
Next m
Next n
printout(d)
redimpreserve(d,-2 To 5,-3 To 7)
printout(d)
redimpreserve(d,0 To 5,0 To 7)
printout(d)
redimpreserve(d,0 To 2000,0 To 2000)
d(20,20)=-7
For n As Long=Lbound(d,1) To 25
For m As Long=Lbound(d,2) To 25
Print d(n,m);
Next m
Print
Next n
Print
sleep
Re: 2d data structure without fixed boundaries
Thanks for all suggestions.
A 'quadruply' linked list without keeping track of all nodes is not going to work I think and/or seems like an administrative nightmare.
The suggestion or Mr Swiss similar to a 'quadruply' linked list but keeps all 'nodes' nicely in one array.
I'll have to study spatial hashing. In have heard of it before, but I don't know what it actually means.
I do like dodicat's approach with the custom redim preserve. Adding tiles will get slower if the maps grows, but today's computer a good at processing sequential data blocks and data readout for a zoomed in section of the map is fast.
Games like minecraft use clusters of cubes to speed things up (I think), but that would be overkill for this purpose.
A 'quadruply' linked list without keeping track of all nodes is not going to work I think and/or seems like an administrative nightmare.
The suggestion or Mr Swiss similar to a 'quadruply' linked list but keeps all 'nodes' nicely in one array.
I'll have to study spatial hashing. In have heard of it before, but I don't know what it actually means.
I do like dodicat's approach with the custom redim preserve. Adding tiles will get slower if the maps grows, but today's computer a good at processing sequential data blocks and data readout for a zoomed in section of the map is fast.
Games like minecraft use clusters of cubes to speed things up (I think), but that would be overkill for this purpose.
-
grindstone
- Posts: 862
- Joined: May 05, 2015 5:35
- Location: Germany
Re: 2d data structure without fixed boundaries
After firstly reading the rules of "Carcassonne" (a very interesting game, IMHO) I think I understand now what you have in mind.
It reminds me of a flowchart editor I wrote some years ago, and some of its features are exactly what you're looking for. It's completely in german, sorry for that incovenience, and another inconvenience: The code is too big for a single message, so I had to split it. Simply merge the 2 parts, compile and run the program. To place an element, drag it form the side bar and drop it on the drawing area. Notice how the area is extended automatically, if you place an element near the lower or right boundary. After placing some elements you can save the diagram ("Diagramm speichern" --> "Speichern unter..."). Type a name and press <enter> and then have a look at the xxx.fds file, it contains plain text.
If you want I could recode the program to a Carcassonne playboard (in english, of course).
Flowchart part 1:
It reminds me of a flowchart editor I wrote some years ago, and some of its features are exactly what you're looking for. It's completely in german, sorry for that incovenience, and another inconvenience: The code is too big for a single message, so I had to split it. Simply merge the 2 parts, compile and run the program. To place an element, drag it form the side bar and drop it on the drawing area. Notice how the area is extended automatically, if you place an element near the lower or right boundary. After placing some elements you can save the diagram ("Diagramm speichern" --> "Speichern unter..."). Type a name and press <enter> and then have a look at the xxx.fds file, it contains plain text.
If you want I could recode the program to a Carcassonne playboard (in english, of course).
Flowchart part 1:
Code: Select all
#Include "file.bi"
Const pi As Double = ACos(0)*2
Const rest = 0
Dim Shared As ULong schwarz = RGB(0,0,0), _
weiss = RGB(255,255,255), _
rot = RGB(255,0,0), _
hellgruen = RGB(0,128,0), _
gruen = RGB(0,255,0)
Enum
oval = 1
rechteck
raute
rhombus
unterprogramm
punkt
End Enum
Enum
_ndef = 0
_oben
_unten
_rechts
_links
End Enum
Enum
_legende = 1
_diagramm
_raster
_grafik
_hintergrund
End Enum
Type tPunkt
x As Integer
y As Integer
typ As UByte 'oben/unten/rechts/links
ofs As Integer 'länge des anfangs-/endstücks
index As Integer
End Type
Type tPfeilparameter
von As tPunkt
bis As tPunkt
verlauf As String = ""
text As String = ""
farbe As ULong = RGB(255,255,255)
grafikpuffer As Any Ptr
End Type
Operator + (punkt As tPunkt, offset As Integer) As tPunkt
'zum festlegen der individuellen länge des anfangs- bzw. endstückes des verbindungspfeils
Dim As tPunkt pReturn
pReturn = punkt
pReturn.ofs = offset
Return pReturn
End Operator
Type tDiagramm
muster As UByte
Union
xpos As Integer
musterposx As Integer 'fd(0)
End Union
ypos As Integer
Union
breite As Integer
fangbereich As Integer 'fd(0)
End Union
hoehe As Integer
ofsdefault As Integer = 20
text As String
farbe As ULong = RGBA(255,255,255,255)
textfarbe As ULong = RGBA(255,255,255,255)
indexfarbe As ULong = RGBA(0,255,0,255)
Union
flag As UByte
rasterflag As UByte 'fd(0), zum ANZEIGEN des rasters
End Union
arrayptr As Any Ptr
grafikpuffer As Any Ptr
Static As ULong hintergrundfarbe
Static As Any Ptr diagrammpuffer
Declare Property oben As tPunkt
Declare Property unten As tPunkt
Declare Property rechts As tPunkt
Declare Property links As tPunkt
Declare Property index As String
Declare Sub zeichnen
Declare Sub pfeil (von As tPunkt, bis As tPunkt, text As String = "", farbe As ULong = RGBA(255,255,255,255))
Declare Function pfeil(von As tPunkt, verlauf As String, text As String = "", farbe As ULong = RGBA(255,255,255,255)) As tPunkt
Declare Function hindernis(von As tPunkt, bis As tPunkt) As Integer
End Type
Static As ULong tDiagramm.hintergrundfarbe
Static As Any Ptr tDiagramm.diagrammpuffer
Property tDiagramm.oben As tPunkt 'oberer anschlusspunkt
If muster = punkt Then
tDiagramm.oben = Type<tPunkt>(xpos, ypos, _ndef, ofsdefault, 0)
Else
tDiagramm.oben = Type<tPunkt>(xpos, ypos - hoehe / 2, _oben, ofsdefault, 0)
EndIf
End Property
Property tDiagramm.unten As tPunkt 'unterer anschlusspunkt
If muster = punkt Then
tDiagramm.unten = Type<tPunkt>(xpos, ypos, _ndef, ofsdefault, 0)
Else
tDiagramm.unten = Type<tPunkt>(xpos, ypos + hoehe / 2, _unten, ofsdefault, 0)
EndIf
End Property
Property tDiagramm.links As tPunkt 'linker anschlusspunkt
If muster = punkt Then
tDiagramm.links = Type<tPunkt>(xpos, ypos, _ndef, ofsdefault, 0)
Else
tDiagramm.links = Type<tPunkt>(xpos - breite / 2, ypos, _links, ofsdefault, 0)
EndIf
End Property
Property tDiagramm.rechts As tPunkt 'rechter anschlusspunkt
If muster = punkt Then
tDiagramm.rechts = Type<tPunkt>(xpos, ypos, _ndef, ofsdefault, 0)
Else
tDiagramm.rechts = Type<tPunkt>(xpos + breite / 2, ypos, _rechts, ofsdefault, 0)
EndIf
End Property
Property tDiagramm.index As String
If arrayptr Then
Return Str((Cast(UInteger,@This) - Cast(UInteger,arrayptr)) / SizeOf(This))
Else
Return ""
EndIf
End Property
Sub tDiagramm.zeichnen
Dim As Integer h2 = hoehe / 2
Dim As Integer b2 = breite / 2
Dim As Integer a, e
ReDim As String t(0)
'element zeichnen
Select Case muster
Case oval
Line grafikpuffer, (xpos - b2 + h2, ypos - h2) - (xpos - b2 + breite - h2, ypos - h2), farbe
Line grafikpuffer, (xpos - b2 + h2, ypos + h2) - (xpos - b2 + breite - h2, ypos + h2), farbe
Circle grafikpuffer, (links.x + h2, links.y), h2, farbe, pi/2, pi/2*3
Circle grafikpuffer, (rechts.x - h2, rechts.y), h2, farbe, pi/2*3, pi/2
Case rechteck
Line grafikpuffer, (xpos - b2, ypos - h2) - (xpos + b2, ypos + h2), farbe, B
Case raute
Line grafikpuffer, (links.x, links.y) - (oben.x, oben.y), farbe
Line grafikpuffer, (oben.x, oben.y) - (rechts.x, rechts.y), farbe
Line grafikpuffer, (rechts.x, rechts.y) - (unten.x, unten.y), farbe
Line grafikpuffer, (unten.x, unten.y) - (links.x, links.y), farbe
Case rhombus
Line grafikpuffer, (xpos - b2 + h2, ypos - h2) - (xpos + b2, ypos - h2), farbe
Line grafikpuffer, (xpos - b2, ypos + h2) - (xpos + b2 - h2, ypos + h2), farbe
Line grafikpuffer, (xpos - b2 + h2, ypos - h2) - (xpos - b2, ypos + h2), farbe
Line grafikpuffer, (xpos + b2, ypos - h2) - (xpos + b2 - h2, ypos + h2), farbe
Case unterprogramm
Line grafikpuffer, (xpos - b2, ypos - h2) - (xpos + b2, ypos + h2), farbe, B
Line grafikpuffer, (xpos - b2 + 10, ypos - h2) - (xpos - b2 + 10, ypos + h2), farbe
Line grafikpuffer, (xpos + b2 - 10, ypos - h2) - (xpos + b2 - 10, ypos + h2), farbe
End Select
'text hineinschreiben
a = 1
Do 'teilstrings in array schreiben
ReDim Preserve t(UBound(t) + 1)
e = InStr(e + 1,text,"\n")
t(UBound(t)) = Mid(text,a,e - a)
a = e + 2
Loop While e
For a = 1 To UBound(t) 'text zentriert ausgeben
Draw String grafikpuffer, (oben.x - (Len(t(a)) * 8 / 2), links.y - (UBound(t) * 4 - 1) + 8 * (a - 1)), t(a), textfarbe
Next
'optionalen index ausgeben
Draw String grafikpuffer, (oben.x - Len(index) * 8 / 2, oben.y + 2), index, indexfarbe
flag = 1 'sperrflag setzen
End Sub
Sub tDiagramm.pfeil(von As tPunkt, bis As tPunkt, text As String = "", farbe As ULong = RGBA(255,255,255,255))
'parameter:
'von - anfangspunkt der verbindung
'bis - endpunkt der verbindung
'text - optionaler text am anfang der verbindungslinie
'farbe - farbe der verbindungslinie (default: weiss)
Dim As tPunkt von2, bis2
Dim As Integer spitzenlaenge = 8 'länge der pfeilspitze
Dim As String verlauf
'anfangsstück
von2 = von
Select Case von.typ
Case _ndef
'"punkt" als anfang hat kein anfangsstück
verlauf = ""
Case _oben',_ndef
von2.y -= von.ofs
verlauf = "o" + Str(von.ofs)
Case _unten
von2.y += von.ofs
verlauf = "u" + Str(von.ofs)
Case _rechts 'falls erforderlich, linie um den text herumführen
von2.x += IIf((von.ofs < Len(text) * 8 + 4) And (von.y > bis.y), Len(text) * 8 + 4, von.ofs)
verlauf = "r" + Str(Abs(von.x - von2.x))
Case _links 'falls erforderlich, linie um den text herumführen
von2.x -= IIf((von.ofs < Len(text) * 8 + 4) And (von.y > bis.y), Len(text) * 8 + 4, von.ofs)
verlauf = "l" + Str(Abs(von.x - von2.x))
End Select
'länge des endabschnitts setzen
bis2 = bis
Select Case bis.typ
Case _ndef
'"punkt" als ziel hat keinen endabschnitt
Case _oben', _ndef
bis2.y -= bis.ofs
Case _unten
bis2.y += bis.ofs
Case _rechts
bis2.x += bis.ofs
Case _links
bis2.x -= bis.ofs
End Select
If von.typ = _ndef Then
von.typ = _unten
If von2.x > bis2.x Then
von.typ = _links
ElseIf von2.x < bis2.x Then
von.typ = _rechts
ElseIf von2.y > bis2.y Then
von.typ = _oben
EndIf
EndIf
Select Case von.typ
Case _oben
If bis2.y < von2.y Then 'ende höher als anfang
verlauf += "o" + Str(Abs(von2.y - bis2.y)) 'zuerst y
verlauf += IIf(von2.x < bis2.x, "r" ,"l") + Str(Abs(von2.x - bis2.x)) 'dann x
Else
verlauf += IIf(von2.x < bis2.x, "r", "l") + Str(Abs(von2.x - bis2.x)) 'zuerst x
verlauf += "u" + Str(Abs(von2.y - bis2.y)) 'dann y
EndIf
Case _unten
If bis2.y < von2.y Then 'ende höher als anfang
verlauf += IIf(von2.x < bis2.x, "r", "l") + Str(Abs(von2.x - bis2.x))
verlauf += "o" + Str(Abs(von2.y - bis2.y))
Else
verlauf += "u" + Str(Abs(von2.y - bis2.y))
verlauf += IIf(von2.x < bis2.x, "r", "l") + Str(Abs(von2.x - bis2.x))
EndIf
Case _links
If bis2.x < von2.x Then 'ende weiter links als anfang
verlauf += "l" + Str(Abs(von2.x - bis2.x))
verlauf += IIf(von2.y < bis2.y, "u", "o") + Str(Abs(von2.y - bis2.y))
Else
verlauf += IIf(von2.y < bis2.y, "u", "o") + Str(Abs(von2.y - bis2.y))
verlauf += "r" + Str(Abs(von2.x - bis2.x))
EndIf
Case _rechts
If bis2.x < von2.x Then 'ende weiter links als anfang
verlauf += IIf(von2.y < bis2.y, "u", "o") + Str(Abs(von2.y - bis2.y))
verlauf += "l" + Str(Abs(von2.x - bis2.x))
Else
verlauf += "r" + Str(Abs(von2.x - bis2.x))
verlauf += IIf(von2.y < bis2.y, "u", "o") + Str(Abs(von2.y - bis2.y))
EndIf
End Select
'endabschnitt
Select Case bis.typ
Case _oben
verlauf += "u" + Str(Abs(bis.y - bis2.y))
Case _unten
verlauf += "o" + Str(Abs(bis.y - bis2.y))
Case _rechts
verlauf += "l" + Str(Abs(bis.x - bis2.x))
Case _links
verlauf += "r" + Str(Abs(bis.x - bis2.x))
End Select
If bis.typ <> _ndef Then 'pfeilspitze, wenn muster <> "punkt"
verlauf += "p"
EndIf
pfeil(von, verlauf, text, farbe) 'zeichnen
End Sub
Function tDiagramm.pfeil(von As tPunkt, verlauf As String, text As String = "", farbe As ULong = RGBA(255,255,255,255)) As tPunkt
Dim As Integer a = 1, h
Dim As String richtung
Dim As tPunkt p1, p2 = von
Dim As Integer spitzenlaenge = 8 'länge der pfeilspitze
'optionalen text ausgeben
Select Case von.typ
Case _oben
Draw String grafikpuffer, (von.x + 2, von.y - 9), text, farbe
Case _unten
Draw String grafikpuffer, (von.x + 2, von.y + 2), text, farbe
Case _rechts
Draw String grafikpuffer, (von.x + 2, von.y - 9), text, farbe 'linksbündig über der linie
Case _links
Draw String grafikpuffer, (von.x -(Len(text) * 8 + 1), von.y - 9), text, farbe 'rechtsbündig über der linie
Case Else
Draw String grafikpuffer, (von.x + 2, von.y + 2), text, farbe
End Select
Do 'verlauf abarbeiten
p1 = p2 'endpunkt als neuen anfangspunkt setzen
Select Case Mid(verlauf,a,1)
Case "o"
a += 1 'zeiger auf längenangabe
richtung = "o" 'letzte richtung merken
p2.y -= Val(Mid(verlauf,a)) 'endpunkt setzen
h = hindernis(p1,p2) 'auf hindernis prüfen
If h Then 'linie nur bis zum hindernis zeichnen
p2.y = p1.y - h
If InStr(verlauf,"p") Then 'anweisung für pfeilspitze suchen
a = InStrRev(verlauf,"p") 'pfeilspitze zeichnen
Else
a = Len(verlauf) 'linie beenden
EndIf
EndIf
Line grafikpuffer, (p1.x, p1.y) - (p2.x, p2.y), farbe 'linie zeichnen
Case "u"
a += 1
richtung = "u"
p2.y += Val(Mid(verlauf,a))
h = hindernis(p1,p2) 'auf hindernis prüfen
If h Then 'linie nur bis zum hindernis zeichnen
p2.y = p1.y + h
If InStr(verlauf,"p") Then 'anweisung für pfeilspitze suchen
a = InStrRev(verlauf,"p") 'pfeilspitze zeichnen
Else
a = Len(verlauf) 'linie beenden
EndIf
EndIf
Line grafikpuffer, (p1.x, p1.y) - (p2.x, p2.y), farbe
Case "r"
a += 1
richtung = "r"
p2.x += Val(Mid(verlauf,a))
h = hindernis(p1,p2) 'auf hindernis prüfen
If h Then 'linie nur bis zum hindernis zeichnen
p2.x = p1.x + h
If InStr(verlauf,"p") Then 'anweisung für pfeilspitze suchen
a = InStrRev(verlauf,"p") 'pfeilspitze zeichnen
Else
a = Len(verlauf) 'linie beenden
EndIf
EndIf
Line grafikpuffer, (p1.x, p1.y) - (p2.x, p2.y), farbe
Case "l"
a += 1
richtung = "l"
p2.x -= Val(Mid(verlauf,a))
h = hindernis(p1,p2) 'auf hindernis prüfen
If h Then 'linie nur bis zum hindernis zeichnen
p2.x = p1.x - h
If InStr(verlauf,"p") Then 'anweisung für pfeilspitze suchen
a = InStrRev(verlauf,"p") 'pfeilspitze zeichnen
Else
a = Len(verlauf) 'linie beenden
EndIf
EndIf
Line grafikpuffer, (p1.x, p1.y) - (p2.x, p2.y), farbe
Case "p" 'pfeilspitze
spitzenlaenge = Val(Mid(verlauf,a + 1))
If spitzenlaenge = 0 Then
spitzenlaenge = 8 'defaultwert
Else
a += 1
EndIf
Select Case richtung 'richtung der letzten linie
Case "o"
Line grafikpuffer, (p2.x, p2.y + spitzenlaenge) - (p2.x, p2.y), hintergrundfarbe 'linie innerhalb des pfeils löschen
Line grafikpuffer, (p2.x, p2.y) - (p2.x - spitzenlaenge/2, p2.y + spitzenlaenge), farbe
Line grafikpuffer, (p2.x, p2.y) - (p2.x + spitzenlaenge/2, p2.y + spitzenlaenge), farbe
Line grafikpuffer, (p2.x + spitzenlaenge/2, p2.y + spitzenlaenge) - (p2.x - spitzenlaenge/2, p2.y + spitzenlaenge), farbe
Case "u"
Line grafikpuffer, (p2.x, p2.y - spitzenlaenge) - (p2.x, p2.y), hintergrundfarbe
Line grafikpuffer, (p2.x, p2.y) - (p2.x + spitzenlaenge/2, p2.y - spitzenlaenge), farbe
Line grafikpuffer, (p2.x, p2.y) - (p2.x - spitzenlaenge/2, p2.y - spitzenlaenge), farbe
Line grafikpuffer, (p2.x - spitzenlaenge/2, p2.y - spitzenlaenge) - (p2.x + spitzenlaenge/2, p2.y - spitzenlaenge), farbe
Case "r"
Line grafikpuffer, (p2.x - spitzenlaenge, p2.y) - (p2.x, p2.y), hintergrundfarbe
Line grafikpuffer, (p2.x, p2.y) - (p2.x - spitzenlaenge, p2.y - spitzenlaenge/2), farbe
Line grafikpuffer, (p2.x, p2.y) - (p2.x - spitzenlaenge, p2.y + spitzenlaenge/2), farbe
Line grafikpuffer, (p2.x - spitzenlaenge, p2.y - spitzenlaenge/2) - (p2.x - spitzenlaenge, p2.y + spitzenlaenge/2), farbe
Case "l"
Line grafikpuffer, (p2.x + spitzenlaenge, p2.y) - (p2.x, p2.y), hintergrundfarbe
Line grafikpuffer, (p2.x, p2.y) - (p2.x + spitzenlaenge, p2.y - spitzenlaenge/2), farbe
Line grafikpuffer, (p2.x, p2.y) - (p2.x + spitzenlaenge, p2.y + spitzenlaenge/2), farbe
Line grafikpuffer, (p2.x + spitzenlaenge, p2.y - spitzenlaenge/2) - (p2.x + spitzenlaenge, p2.y + spitzenlaenge/2), farbe
End Select
a += 1
End Select
Do While InStr("0123456789 ", Mid(verlauf,a,1)) 'zeiger hinter längenangabe setzen
a += 1
Loop
Loop While a <= Len(verlauf)
Select Case richtung
Case "o"
p2.typ = _oben
Case "u"
p2.typ = _unten
Case "r"
p2.typ = _rechts
Case "l"
p2.typ = _links
End Select
Return p2
End Function
Function tDiagramm.hindernis(von As tPunkt, bis As tPunkt) As Integer
Dim As Integer i, d
Dim As Any Ptr puffer
If diagrammpuffer Then
puffer = diagrammpuffer 'pointer auf externen puffer
Else
puffer = grafikpuffer 'pointer von element
EndIf
If von.x = bis.x Then 'senkrechte linie
d = Abs(von.y - bis.y)
If von.y < bis.y Then 'nach oben
For i = 1 To d
If Point(von.x, von.y + i, puffer) <> hintergrundfarbe Then
Return IIf(i > 2, i, 0)
EndIf
Next
Else 'nach unten
For i = 1 To d
If Point(von.x, von.y - i, puffer) <> hintergrundfarbe Then
Return IIf(i > 2, i, 0)
EndIf
Next
EndIf
ElseIf von.y = bis.y Then 'waagerechte linie
d = Abs(von.x - bis.x)
If von.x < bis.x Then 'nach rechts
For i = 1 To d
If Point(von.x + i, von.y, puffer) <> hintergrundfarbe Then
Return IIf(i > 2, i, 0)
EndIf
Next
Else 'nach links
For i = 1 To d
If Point(von.x - i, von.y, puffer) <> hintergrundfarbe Then
Return IIf(i > 2, i, 0)
EndIf
Next
EndIf
EndIf
Return 0
End Function
'#################################################################################
'#################################################################################
'#################################################################################
'#################################################################################
'#################################################################################
Type tFlag
edit : 1 As Integer
maus : 1 As Integer
End Type
Dim As tFlag flag
Type tMenu 'zur übergabe der parameter von mausMenu an menuInput
As Integer dummy
Static As Integer yPos, xPos
Static As ULong foreground, background
Static As String text
Static As Any Ptr buffer
End Type
Static As Integer tMenu.yPos, tMenu.xPos
Static As ULong tMenu.foreground, tMenu.background
Static As String tMenu.text
Static As Any Ptr tMenu.buffer
Declare Function parse OverLoad(satz As String = "", trenner As String = "") As String
Declare Function parse(flag As Integer) As String
Declare Sub parliste(par As String, parameter() As String)
Declare Sub neuZeichnen()
Declare Sub pfeil(par As tPfeilparameter)
Declare Function istAnschlussPunkt(index As Integer = 0) As tPunkt
Declare Sub textInput(ByRef txt As String, ByRef sp As Integer)
Declare Function zeichenEntfernen(text As String, zeichen As String) As String
Declare Sub pfeileAnpassen(index As Integer)
Declare Sub diagrammVerschieben
Declare Sub puffergroesseAnpassen
Declare Sub neuesRaster()
Declare Sub diagrammLaden()
Declare Sub diagrammSpeichern()
Declare Sub programmEnde()
Declare Sub umlaute(ByRef text As String)
Declare Function ini(datei As String, variable As String) As String
Declare Function menuInput OverLoad (value As Integer, xPos As Integer = 0, yPos As Integer = 0) As Integer
Declare Function menuInput(value As String, xPos As Integer = 0, yPos As Integer = 0) As String
Declare Function mausMenu(text As String, _
separator As String = "", _
xPos As Integer = 0, _
yPos As Integer = 0, _
foreground As ULong, _
background As ULong, _
mode As UByte = 0, _
buffer As Any Ptr = 0) As Integer
Dim As String g, ausgabedatei, txt, datei, inivarname
Dim As Integer x, y, a, e, ms, sp, cp, inival, ff, fangbereich, _
breite, hoehe, bpp, sc_breite, sc_hoehe, _
mx, my, rad, tasten, radvor, radvor2, _
musterbreite = 140, musterabstand = 50
Dim As tPunkt anfangspunkt, endpunkt
Dim Shared As Any Ptr puffer(_raster)
Dim Shared As String letztedatei
Dim Shared As Integer pufferbreite, pufferhoehe, xanf, yanf, _
ofsanfang, ofsende, ovalbreite, ovalhoehe, rechteckbreite, _
rechteckhoehe, rautenbreite, rautenhoehe, rhombusbreite, _
rhombushoehe, subbreite, subhoehe
Dim Shared As tPunkt raster, rastervorgabe
Dim As tDiagramm muster(punkt) 'oval, rechteck, raute, rhombus, unterprogramm, punkt
ReDim As String parameter(0)
ReDim As String text(0)
ReDim Shared As tDiagramm fd(0)
ReDim Shared As tPfeilparameter pfeile(0)
ScreenRes 1000, 800, 32
ScreenInfo sc_breite, sc_hoehe
pufferbreite = sc_breite * 2 'anfangswerte
pufferhoehe = sc_hoehe * 2
#Macro mausLoslassen
Do
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
Sleep 1
Loop While tasten
#EndMacro
#Macro inispeichern
Print #ff, "letzteDatei=";letztedatei
Print #ff, "ofsanfang=";Str(ofsanfang)
Print #ff, "ofsende=";Str(ofsende)
Print #ff, "ovalbreite=";Str(ovalbreite)
Print #ff, "ovalhoehe=";Str(ovalhoehe)
Print #ff, "rechteckbreite=";Str(rechteckbreite)
Print #ff, "rechteckhoehe=";Str(rechteckhoehe)
Print #ff, "rautenbreite=";Str(rautenbreite)
Print #ff, "rautenhoehe=";Str(rautenhoehe)
Print #ff, "rhombusbreite=";Str(rhombusbreite)
Print #ff, "rhombushoehe=";Str(rhombushoehe)
Print #ff, "subbreite=";Str(subbreite)
Print #ff, "subhoehe=";Str(subhoehe)
Print #ff, "rasterx=";Str(raster.x)
Print #ff, "rastery=";Str(raster.y)
Print #ff, "rastervorgabex=";Str(rastervorgabe.x)
Print #ff, "rastervorgabey=";Str(rastervorgabe.y)
#EndMacro
#Macro iniholen
Seek ff,1
Do
Line Input #ff, g
inivarname = Left(g, InStr(g, "=") - 1)
inival = Val(Mid(g, InStr(g, "=") + 1))
Select Case inivarname
Case "letzteDatei"
letztedatei = Mid(g, InStr(g, "=") + 1)
Case "ofsanfang"
ofsanfang = inival
Case "ofsende"
ofsende = inival
Case "ovalbreite"
ovalbreite = inival
Case "ovalhoehe"
ovalhoehe = inival
Case "rechteckbreite"
rechteckbreite = inival
Case "rechteckhoehe"
rechteckhoehe = inival
Case "rautenbreite"
rautenbreite = inival
Case "rautenhoehe"
rautenhoehe = inival
Case "rhombusbreite"
rhombusbreite = inival
Case "rhombushoehe"
rhombushoehe = inival
Case "subbreite"
subbreite = inival
Case "subhoehe"
subhoehe = inival
Case "rasterx"
raster.x = inival
Case "rastery"
raster.y = inival
Case "rastervorgabex"
rastervorgabe.x = inival
Case "rastervorgabey"
rastervorgabe.y = inival
End Select
Loop Until EOF(ff)
#EndMacro
#Macro defaultwerteSetzen
ofsanfang = 20
ofsende = 20
ovalbreite = 200
ovalhoehe = 20
rechteckbreite = 200
rechteckhoehe = 40
rautenbreite = 200
rautenhoehe = 50
rhombusbreite = 200
rhombushoehe = 40
subbreite = 200
subhoehe = 40
rastervorgabe.x = 150
rastervorgabe.y = 100
raster = rastervorgabe
#EndMacro
puffer(_legende) = ImageCreate(sc_breite, sc_hoehe, RGB(255,0,255), 32) 'hintergrund transparent
puffer(_diagramm) = ImageCreate(pufferbreite, pufferhoehe, schwarz, 32)
puffer(_raster) = ImageCreate(pufferbreite, pufferhoehe, schwarz, 32)
tDiagramm.diagrammpuffer = puffer(_diagramm)
defaultwerteSetzen
'werte aus inidatei laden
datei = Command(0) 'programmname mit pfad
datei = Left(datei, InStrRev(datei, ".exe") - 1) + ".ini"
If FileExists(datei) Then
ff = FreeFile
Open datei For Input As #ff
iniholen
Close ff
EndIf
'musterpuffer anlegen
With muster(oval)
.muster = oval
.breite = musterbreite
.hoehe = 20
.text = "Start / Ende"
.ypos = .hoehe / 2 + 10
End With
With muster(rechteck)
.muster = rechteck
.breite = musterbreite
.hoehe = 20
.text = "Anweisung"
.ypos = muster(rechteck - 1).ypos + muster(rechteck - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With
With muster(raute)
.muster = raute
.breite = musterbreite
.hoehe = 40
.text = "Entscheidung"
.ypos = muster(raute - 1).ypos + muster(raute - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With
With muster(rhombus)
.muster = rhombus
.breite = musterbreite
.hoehe = 20
.text = "Ein- / Ausgabe"
.ypos = muster(rhombus - 1).ypos + muster(rhombus - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With
With muster(unterprogramm)
.muster = unterprogramm
.breite = musterbreite
.hoehe = 20
.text = "Unterprogramm"
.ypos = muster(unterprogramm - 1).ypos + muster(unterprogramm - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With
With muster(punkt)
.muster = punkt
.breite = musterbreite
.hoehe = 20
.text = "Punkt"
.ypos = muster(punkt - 1).ypos + muster(punkt - 1).hoehe / 2 + .hoehe / 2 + musterabstand
End With
'werte für erforderliche höhe und breite des musterpuffers berechnen
x = 0
y = 0
For i As Integer = 1 To UBound(muster) 'grössten x- und y - wert suchen
With muster(i)
If .unten.y > y Then
y = .unten.y
EndIf
If .breite > x Then
x = .breite
EndIf
End With
Next
fd(0).musterposx = sc_breite - x - 20 'x - position der legende im grafikfenster
Line puffer(_legende), (fd(0).musterposx, 0) - (sc_breite - 1, sc_hoehe - 1), hellgruen, bf 'hintergrund für legende
For i As Integer = 1 To UBound(muster)
With muster(i)
.xpos = sc_breite - x / 2 - 10
.grafikpuffer = puffer(_legende)
End With
Next
tDiagramm.hintergrundfarbe = Point(0,0,puffer(_diagramm))
raster = rastervorgabe
flag.edit = 1 'für anzeige der indices
fangbereich = 5
fd(0).fangbereich = fangbereich
neuesRaster
GetMouse mx, my, rad, tasten
radvor2 = rad
Do 'hauptschleife
neuZeichnen()
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
'xanf / yanf --> obere linke ecke des im screenfenster angezeigten ausschnitts des diagrammpuffers
If tasten = -1 Then 'maus ist ausserhalb des fensters
If InKey = Chr(255,107) Then 'schliessen - button wurde angeklickt
programmEnde()
EndIf
flag.maus = 1
Sleep 1
Continue Do
Else
If flag.maus Then 'maus ist neu im fenster
radvor = rad
radvor2 = rad
flag.maus = 0
EndIf
EndIf
'musterbereich / legende / neues element anlegen
For x = 1 To UBound(muster)
With muster(x)
If ((mx - xanf) >= .xpos - .breite / 2) AndAlso _
((mx - xanf) <= .xpos + .breite / 2) AndAlso _
((my - yanf) >= .ypos - .hoehe / 2) AndAlso _
((my - yanf) <= .ypos + .hoehe / 2) Then 'mauszeiger über muster
.farbe = rot
.textfarbe = rot
If tasten = 1 Then 'linke maustaste gedrückt --> neues element anlegen
ReDim Preserve fd(UBound(fd) + 1) 'neuen platz im array anlegen
With fd(UBound(fd))
fd(UBound(fd)) = muster(x) 'muster in array kopieren
Select Case .muster 'auf elementgröße setzen
Case oval
.breite = ovalbreite
.hoehe = ovalhoehe
Case rechteck
.breite = rechteckbreite
.hoehe = rechteckhoehe
Case raute
.breite = rautenbreite
.hoehe = rautenhoehe
Case rhombus
.breite = rhombusbreite
.hoehe = rhombushoehe
Case unterprogramm
.breite = subbreite
.hoehe = subhoehe
Case punkt
.breite = 20 'fangbereich zum verschieben
.hoehe = 20
End Select
For i As Integer = 0 To UBound(fd) 'neuer arraypointer (für indexanzeige)
fd(i).arrayptr = IIf(flag.edit, @fd(0), 0)
Next
.farbe = weiss
.textfarbe = weiss
.grafikpuffer = puffer(_diagramm)
Do 'neues element an seinen platz ziehen
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
If Abs(mx - .xpos) > raster.x / 2 Then
.xpos = Int(mx / raster.x) * raster.x
EndIf
If Abs(my - .ypos) > raster.y / 2 Then
.ypos = Int(my / raster.y) * raster.y
EndIf
neuZeichnen()
Sleep 1
Loop Until tasten = 0 'auf loslassen der maustaste warten
.text = "" 'musterbezeichnung löschen
puffergroesseAnpassen
End With
EndIf
Else
.farbe = weiss
.textfarbe = weiss
'legendenmenü
ms = muster(unterprogramm).links.x - 8 'spalte für mausmenü
ScreenSync
If mausMenu(" Breite = " + Str(ovalbreite),"= ", ms + 10*8, muster(oval).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
ovalbreite = menuInput(ovalbreite)
ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(ovalhoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
ovalhoehe = menuInput(ovalhoehe)
ElseIf mausMenu(" Breite = " + Str(rechteckbreite),"= ", ms + 10*8, muster(rechteck).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
rechteckbreite = menuInput(rechteckbreite)
ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(rechteckhoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
rechteckhoehe = menuInput(rechteckhoehe)
ElseIf mausMenu(" Breite = " + Str(rautenbreite),"= ", ms + 10*8, muster(raute).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
rautenbreite = menuInput(rautenbreite)
ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(rautenhoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
rautenhoehe = menuInput(rautenhoehe)
ElseIf mausMenu(" Breite = " + Str(rhombusbreite),"= ", ms + 10*8, muster(rhombus).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
rhombusbreite = menuInput(rhombusbreite)
ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(rhombushoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
rhombushoehe = menuInput(rhombushoehe)
ElseIf mausMenu(" Breite = " + Str(subbreite),"= ", ms + 10*8, muster(unterprogramm).unten.y + 1*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
subbreite = menuInput(subbreite)
ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(subhoehe),"= ", ms + 10*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
subhoehe = menuInput(subhoehe)
ElseIf mausMenu(" Pfeil Anfang = " + Str(ofsanfang),"= ", ms + 13*8, -7*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
ofsanfang = menuInput(ofsanfang)
ElseIf mausMenu(" Pfeil Ende = " + Str(ofsende),"= ", ms + 13*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
ofsende = menuInput(ofsende)
ElseIf mausMenu(" Raster x = " + Str(rastervorgabe.x),"= ", ms + 9*8, -3*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
rastervorgabe.x = menuInput(rastervorgabe.x)
raster = rastervorgabe
neuesRaster
neuZeichnen()
ElseIf mausMenu(" Raster y = " + Str(rastervorgabe.y),"= ", ms + 9*8, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
rastervorgabe.y = menuInput(rastervorgabe.y)
raster = rastervorgabe
neuesRaster
neuZeichnen()
ElseIf mausMenu(" Raster " + IIf(fd(0).rasterflag,"AN ", "AUS "),, ms, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
fd(0).rasterflag = IIf(fd(0).rasterflag, 0, 1)
raster.x = IIf(raster.x = 1, rastervorgabe.x, 1)
raster.y = IIf(raster.y = 1, rastervorgabe.y, 1)
ElseIf mausMenu(" Indexanzeige " + IIf(flag.edit,"AUS ", "AN "),, ms, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
If flag.edit Then
flag.edit = 0
For i As Integer = 0 To UBound(fd)
fd(i).arrayptr = 0
Next
Else
flag.edit = 1
For i As Integer = 0 To UBound(fd)
fd(i).arrayptr = @fd(0)
Next
EndIf
ElseIf mausMenu(" Werte zur" & Chr(129) & "cksetzen ",, ms, -4*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
defaultwertesetzen
Line puffer(_legende), (fd(0).musterposx, 0) - (sc_breite - 1, sc_hoehe - 1), hellgruen, bf 'hintergrund für legende
neuesRaster
neuZeichnen
ElseIf mausMenu(" Diagramm laden ",, ms, -4*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
diagrammLaden()
ElseIf mausMenu(" Diagramm speichern ",, 0, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
diagrammSpeichern()
ElseIf mausMenu(" Grafik erstellen ",, 0, -2*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
ScreenInfo sc_breite, sc_hoehe
Line (0,0)-(fd(0).musterposx, sc_hoehe), schwarz, bf
Draw String (fd(0).musterposx / 2 -(21 * 8 / 2), sc_hoehe / 2), "Grafik erstellen.."
ausgabedatei = Left(letztedatei, InStrRev(letztedatei, ".") - 1) + ".bmp"
ImageInfo puffer(_diagramm), breite, hoehe, bpp
puffer(_grafik) = ImageCreate(breite, hoehe,, bpp * 8) 'grafikpuffer erzeugen
puffer(_hintergrund) = ImageCreate(breite, hoehe, weiss, bpp * 8) 'grafikpuffer mit weissem hintergrund erzeugen
Get puffer(_diagramm), (0,0)-(breite - 1, hoehe - 1), puffer(_grafik) 'diagramm in puffer1 laden
Put puffer(_grafik), (0,0), puffer(_hintergrund), Xor 'farben invertieren
BSave(ausgabedatei, puffer(_grafik), breite * hoehe * bpp) 'diagramm speichern
ImageDestroy puffer(_grafik)
puffer(_grafik) = 0
ImageDestroy puffer(_hintergrund)
puffer(_hintergrund) = 0
Draw String (fd(0).musterposx / 2 -(21 * 8 / 2), sc_hoehe / 2 + 16), "fertig"
Sleep 1000
neuZeichnen
ElseIf mausMenu(" Beenden ",, 0, -4*8, weiss, hellgruen,,puffer(_legende)) = 9 Then
programmEnde()
EndIf
EndIf
.zeichnen
End With
Next
'existierende elemente bearbeiten
For x = 1 To UBound(fd)
With fd(x)
anfangspunkt = istAnschlussPunkt(x) 'anfangspunkt
If anfangspunkt.index = x Then 'mauscursor befindet sich über einem anschlusspunkt
'*** PFEILE ***
.farbe = weiss
pfeile(0).von = anfangspunkt
neuZeichnen()
'pfeilarray durchsuchen
For y = 1 To UBound(pfeile)
If (pfeile(y).von.x = anfangspunkt.x) And (pfeile(y).von.y = anfangspunkt.y) Then 'vom punkt geht schon ein pfeil aus
Exit For 'y ist der index des verbundenen pfeils
EndIf
Next
If tasten = 1 Then 'linke maustaste gedrückt --> pfeilanfang
mausloslassen
If y > UBound(pfeile) Then 'pfeil anlegen
Do 'schleife für pfeil anlegen
neuZeichnen()
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
endpunkt = istAnschlussPunkt() 'endpunkt
If endpunkt.index Then 'mauszeiger ist auf anschlusspunkt
pfeile(0).bis = endpunkt
pfeile(0).bis.ofs = IIf(fd(endpunkt.index).muster = punkt, 0, ofsende)
Else
pfeile(0).bis.index = 0
pfeile(0).bis.typ = _ndef
pfeile(0).bis.ofs = 0
pfeile(0).bis.x = mx
pfeile(0).bis.y = my
EndIf
pfeile(0).text = ""
pfeile(0).farbe = weiss
pfeile(0).von.ofs = IIf(fd(anfangspunkt.index).muster = punkt, 0, ofsanfang)
pfeile(0).grafikpuffer = puffer(_diagramm)
If tasten = 1 Then
If endpunkt.index Then 'mauszeiger ist auf anschlusspunkt --> pfeil abspeichern
ReDim Preserve pfeile(y)
pfeile(y) = pfeile(0)
mausLoslassen
Exit Do 'pfeil anlegen beenden
Else
diagrammVerschieben
EndIf
ElseIf tasten = 2 Then 'abbrechen
mausLoslassen
Exit Do
EndIf
If rad > radvor2 Then 'scrollen mit mausrad
yanf += (radvor2 - rad) * 50
radvor2 = rad
neuZeichnen
ElseIf rad < radvor2 Then
yanf -= (rad - radvor2) * 50
radvor2 = rad
neuZeichnen
EndIf
Sleep 1
Loop
pfeile(0).grafikpuffer = 0
EndIf
ElseIf (tasten = 2) And (y <= UBound(pfeile)) Then 'rechte maustaste --> pfeil editieren
Do 'schleife für mausmenü
radvor = rad
radvor2 = rad
ms = anfangspunkt.x - xanf
ScreenSync
If mausMenu(" Text ",, ms + 16, anfangspunkt.y + 8 - yanf, weiss, schwarz) = 9 Then
sp = Len(pfeile(y).text) + 1
Do 'texteingabe
neuZeichnen()
textInput(pfeile(y).text, sp)
'blinkender cursor
If Frac(Timer) > .5 Then
With pfeile(y).von
Select Case .typ
Case _oben
Draw String (.x + 1 + (sp - 1) * 8 - xanf, .y - 9 - yanf), "_", weiss
Case _unten
Draw String (.x + 1 + (sp - 1) * 8 - xanf, .y + 2 - yanf), "_", weiss
Case _rechts
Draw String (.x + 1 + (sp - 1) * 8 - xanf, .y - 9 - yanf), "_", weiss
Case _links
Draw String (.x - 1 + (sp - Len(pfeile(y).text)- 2)*8 - xanf, .y -9 - yanf), "_", weiss
Case Else
End Select
End With
EndIf
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
If (tasten = 1) Or (InStr(pfeile(y).text, Chr(13))) Then 'texteingabe beenden
pfeile(y).text = zeichenEntfernen(pfeile(y).text, Chr(13))
pfeile(y).farbe = weiss
Exit Do, Do
EndIf
Sleep 100
Loop
EndIf
Select Case mausMenu(" Anfang = " + Str(pfeile(y).von.ofs),"= ", ms + 8*9, -2*8,weiss, schwarz)
Case 8
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
If rad < radvor Then
pfeile(y).von.ofs += 10
neuZeichnen()
ElseIf rad > radvor Then
pfeile(y).von.ofs = IIf(pfeile(y).von.ofs >= 10,pfeile(y).von.ofs - 10, 0)
neuZeichnen()
EndIf
Case 9
pfeile(y).von.ofs = menuInput(pfeile(y).von.ofs)
neuZeichnen()
End Select
Select Case mausMenu(" Ende = " + Str(pfeile(y).bis.ofs),"= ", ms + 7*8, -2*8, weiss, schwarz)
Case 8
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
If rad < radvor Then
pfeile(y).bis.ofs += 10
neuZeichnen()
ElseIf rad > radvor Then
pfeile(y).bis.ofs = IIf(pfeile(y).bis.ofs >= 10,pfeile(y).bis.ofs - 10, 0)
neuZeichnen()
EndIf
Case 9
pfeile(y).bis.ofs = menuInput(pfeile(y).bis.ofs)
neuZeichnen()
End Select
If mausMenu(" L" & Chr(148) & "schen (" + Str(anfangspunkt.index) + "->" + Str(pfeile(y).bis.index) + ") ",, ms + 2*8, -2*8, weiss, schwarz) = 9 Then
For j As Integer = y To UBound(pfeile) - 1
pfeile(j) = pfeile(j + 1)
Next
ReDim Preserve pfeile(UBound(pfeile) - 1)
Exit Do
ElseIf (mausMenu(" OK ",, 0, -2*8,weiss, schwarz) = 9) Or (InKey = Chr(27)) Then
pfeile(y).farbe = weiss
Exit Do
EndIf
Sleep 1
Loop
EndIf
ElseIf (mx >= .xpos - .breite / 2) AndAlso _
(mx <= .xpos + .breite / 2) AndAlso _
(my >= .ypos - .hoehe / 2) AndAlso _
(my <= .ypos + .hoehe / 2) Then 'mauszeiger über element
'*** ELEMENTE ***
.farbe = rot
If tasten = 1 Then 'linke maustaste --> element verschieben
Do 'ziehen des elements mit gedrückter linker maustaste
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
If Abs(mx - .xpos) > raster.x / 2 Then
.xpos = Int(mx / raster.x) * raster.x
EndIf
If Abs(my - .ypos) > raster.y / 2 Then
.ypos = Int(my / raster.y) * raster.y
EndIf
pfeileAnpassen(x)
neuZeichnen()
Sleep 1
Loop While tasten And 1
puffergroesseAnpassen
ElseIf tasten = 2 Then 'rechte maustaste --> element editieren
mausLoslassen
'editmodus für element
Do 'schleife für mausmenü
ms = .rechts.x - xanf
ScreenSync
If mausMenu(" Text ", "", ms + 2*8, .oben.y - yanf, weiss, schwarz) = 9 Then
'texteingabe
neuZeichnen()
.grafikpuffer = 0 'auf screen schreiben
.xpos -= xanf
.ypos -= yanf
txt = .text
While InStr(txt,"\n")
txt = Left(txt, InStr(txt,"\n") - 1) + Chr(13) + Mid(txt, InStr(txt,"\n") + 2)
Wend
.zeichnen
sp = Len(txt) + 1
Do 'eingabeschleife für text
textInput(txt, sp)
.text = txt
While InStr(.text, Chr(13)) 'alle Chr(13) durch "\n" ersetzen
.text = Left(.text, InStr(.text, Chr(13)) - 1) + "\n" + Mid(.text, InStr(.text, Chr(13)) + 1)
Wend
ReDim text(0)
Do 'teilstrings in array schreiben
ReDim Preserve text(UBound(text) + 1)
e = InStr(e + 1,txt,Chr(13))
text(UBound(text)) = Mid(txt,a,e - a)
a = e + 1
Loop While e
'automatische höhenanpassung
If UBound(text) * 8 + 4 > .hoehe Then
.hoehe = UBound(text) * 8 + 4
pfeileAnpassen(x)
neuZeichnen()
EndIf
ScreenLock
Line(.links.x, .oben.y) - (.rechts.x, .unten.y), schwarz,BF 'bereich löschen
.zeichnen
'blinkender cursor
If Frac(Timer) > .5 Then
cp = 0
For y = 1 To UBound(text)
cp += Len(text(y)) + 1
If cp >= sp Then 'cursorzeile gefunden
cp -= Len(text(y)) + 1
cp = sp - cp - 1
Exit For
EndIf
Next
Draw String(.xpos - Len(text(y)) * 4 + cp * 8 - 1, .ypos - UBound(text) * 4 + (y - 1) * 8 + 1), "_", .textfarbe
EndIf
ScreenUnlock
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
If tasten = 1 Then 'linke maustaste gedrückt --> texteingabe beenden
.grafikpuffer = puffer(_diagramm)
.xpos += xanf
.ypos += yanf
mausLoslassen
Exit Do, Do 'editmodus beenden
EndIf
Sleep 1
Loop
ElseIf mausMenu(" Breite = " + Str(.breite) + " ", "= ", ms + 9*8, -2*8, weiss, schwarz) = 9 Then
'neue breite eingeben
.breite = menuInput(.breite)
pfeileAnpassen(x)
neuZeichnen()
ElseIf mausMenu(" H" & Chr(148) & "he = " + Str(.hoehe) + " ", "= ", ms + 7*8, -2*8, weiss, schwarz) = 9 Then
'neue höhe eingeben
.hoehe = menuInput(.hoehe)
pfeileAnpassen(x)
neuZeichnen()
ElseIf mausMenu(" L" & Chr(148) & "schen ", "", ms + 2*8, -2*8, weiss, schwarz) = 9 Then
'element löschen
Do 'alle verbundenen pfeile löschen
For y = 1 To UBound(pfeile)
If (pfeile(y).von.index = x) Or (pfeile(y).bis.index = x) Then 'pfeil ist mit dem zu löschenden element verbunden
For j As Integer = y To UBound(pfeile) - 1
pfeile(j) = pfeile(j + 1)
Next
ReDim Preserve pfeile(UBound(pfeile) - 1)
Continue Do 'wiederholen
EndIf
Next
Exit Do 'alle pfeile gelöscht
Loop
For y As Integer = x + 1 To UBound(fd) 'nachfolgende elemente nach oben schieben
fd(y - 1) = fd(y)
For j As Integer = 1 To UBound(pfeile) 'pfeilindices neu zuordnen
If pfeile(j).von.index = y Then
pfeile(j).von.index -= 1
EndIf
If pfeile(j).bis.index = y Then
pfeile(j).bis.index -= 1
EndIf
Next
Next
ReDim Preserve fd(UBound(fd) - 1) 'freien platz löschen
For i As Integer = 0 To UBound(fd) 'arraypointer aktualisieren (für indexanzeige)
fd(i).arrayptr = IIf(flag.edit, @fd(0), 0)
Next
mausLoslassen
puffergroesseAnpassen
Continue Do, Do
ElseIf (mausMenu(" OK ", "", 0, -2*8, weiss, schwarz) = 9) Or (InKey = Chr(27)) Then
Continue Do,Do 'editmodus beenden
EndIf
Sleep 1
Loop
EndIf
Else
.farbe = weiss
EndIf
.zeichnen
End With
Next
If tasten = 1 Then 'linke maustaste --> diagramm verschieben
diagrammVerschieben
EndIf
'vertikal scrollen mit mausrad
If rad > radvor2 Then
yanf += (radvor2 - rad) * 50
radvor2 = rad
neuZeichnen
ElseIf rad < radvor2 Then
yanf -= (rad - radvor2) * 50
radvor2 = rad
neuZeichnen
EndIf
Sleep 1
Loop
-
grindstone
- Posts: 862
- Joined: May 05, 2015 5:35
- Location: Germany
Re: 2d data structure without fixed boundaries
Flowchart part 2:
Code: Select all
Function parse(flag As Integer) As String
If flag = 0 Then
Return parse(, Chr(0)) 'rest des strings zurückgeben
EndIf
End Function
Function parse(satz As String = "", trenner As String = "") As String
Static As String s, t, r
Static As Integer a, e
If trenner = Chr(0) Then 'rest des textes zurückgeben
r = Mid(s, e + 1)
e = Len(s)
Return r
ElseIf Len(trenner) Then
t = trenner
EndIf
If Len(satz) Then 'neuer satz
s = satz
e = 0 'zeiger auf anfang
EndIf
a = e + 1
Do While InStr(t, Mid(s, a, 1)) 'nächsten wortanfang suchen
If a >= Len(s) Then
Return ""
EndIf
a += 1
Loop
e = a
Do
If Mid(s, e, 1) = """" Then 'anführungsstriche
Do 'ende des textes in anführungsstrichen suchen
e += 1
If e > Len(s) Then 'text zuende
Exit Do, Do
EndIf
Loop Until Mid(s, e, 1) = """"
EndIf
e += 1
If e > Len(s) Then 'text zuende
Exit Do
EndIf
Loop Until InStr(t, Mid(s, e, 1)) 'trenner gefunden
e -= 1 'zeiger vor trenner setzen
r = Mid(s, a, e - a + 1) 'textstück isolieren
Return Trim(r,"""")
End Function
Sub parliste(par As String, parameter() As String)
Dim As Integer e, quoteflag
Dim As String g
g = par
ReDim parameter(0)
Do
g = Trim(g)
For e = 0 To Len(g) - 1
If g[e] = Asc("""") Then 'anführungsstriche
quoteflag Xor= 1
EndIf
If g[e] = Asc(",") And quoteflag = 0 Then 'komma gefunden
Exit For
EndIf
Next
ReDim Preserve parameter(UBound(parameter) + 1) 'arrayplatz anlegen
parameter(UBound(parameter)) = Trim(Left(g,e)) 'parameter in array schreiben
g = Mid(g, e + 2) 'behandelten parameter entfernen
Loop While Len(g)
End Sub
Sub neuZeichnen()
Dim As Integer mx, my, rad, tasten, x, breite, hoehe, sc_breite, sc_hoehe
Dim As tPunkt pkt
GetMouse mx, my, rad, tasten
ScreenInfo sc_breite, sc_hoehe
ImageInfo puffer(_diagramm), breite, hoehe
If xanf > breite - sc_breite Then
xanf = breite - sc_breite 'erlaubter maximalwert
ElseIf xanf < 0 Then
xanf = 0 'erlaubter minimalwert
EndIf
If yanf > hoehe - sc_hoehe Then
yanf = hoehe - sc_hoehe 'erlaubter maximalwert
ElseIf yanf < 0 Then
yanf = 0 'erlaubter minimalwert
EndIf
Line puffer(_diagramm), (0,0) - (breite - 1, hoehe - 1), schwarz, bf 'diagrammpuffer löschen
For y As Integer = 1 To UBound(fd) 'elemente zeichnen
fd(y).zeichnen
Next
For y As Integer = IIf(pfeile(0).grafikpuffer, 0, 1) To UBound(pfeile) 'pfeile zeichnen
pfeil(pfeile(y))
Next
ScreenLock
Put (0,0), puffer(_diagramm), (xanf, yanf) - (xanf + sc_breite, yanf + sc_hoehe), PSet 'diagramm auf grafikscreen
If fd(0).rasterflag = 0 Then
Put (0,0), puffer(_raster), (xanf, yanf) - (xanf + sc_breite, yanf + sc_hoehe), Or
EndIf
pkt = istAnschlussPunkt()
If pkt.index Then
Circle (pkt.x - xanf, pkt.y - yanf), 5, rot,,,,F
EndIf
'senkrechter balken
Dim As Integer gesamtlaenge = sc_hoehe - 40
Dim As Integer balkenlaenge = gesamtlaenge * sc_hoehe / hoehe
Dim As Integer balkenpos = yanf / hoehe * gesamtlaenge + 10
Line puffer(_legende), (10, 10) - (20, gesamtlaenge + 10), schwarz, bf 'löschen
Line puffer(_legende), (10, 10) - (20, gesamtlaenge + 10), weiss, b 'rahmen
Line puffer(_legende), (10, balkenpos) - (20, balkenpos + balkenlaenge), weiss, bf 'balken
'waagerechter balken
gesamtlaenge = fd(0).musterposx - 50
balkenlaenge = gesamtlaenge * sc_breite / breite
balkenpos = xanf / breite * gesamtlaenge + 30
Line puffer(_legende), (30, sc_hoehe - 10) - (fd(0).musterposx - 20, sc_hoehe - 20), schwarz, bf 'löschen
Line puffer(_legende), (30, sc_hoehe - 10) - (fd(0).musterposx - 20, sc_hoehe - 20), weiss, b 'rahmen
Line puffer(_legende), (balkenpos, sc_hoehe - 10) - (balkenpos + balkenlaenge, sc_hoehe - 20), weiss, bf 'balken
Put (0,0), puffer(_legende), Trans
ScreenUnlock
End Sub
#Macro PrintMenuItem()
bufferForegroundColor = foreground
bufferBackgroundColor = background
PrintMenuItemMain()
#EndMacro
#Macro PrintMenuItemInv()
bufferForegroundColor = background
bufferBackgroundColor = foreground
PrintMenuItemMain()
#EndMacro
#Macro PrintMenuItemMain()
Line buffer, (xPos,yPos - 1)-(xPos + Len(text) * 8, yPos + 8),bufferBackgroundColor, bf
Draw String buffer, (xPos, yPos), text, bufferForegroundColor
If (mode And 2) Then 'draw frame around text
Line buffer, (xPos - 1, yPos - 2)-(xPos + 1 + Len(text) * 8, yPos + 9),bufferForegroundColor, b
EndIf
#EndMacro
Function mausMenu(text As String, _
separator As String = "", _
xPos As Integer = 0, _
yPos As Integer = 0, _
foreground As ULong, _
background As ULong, _
mode As UByte = 0, _
buffer As Any Ptr = 0) As Integer
'mode 0 -> highlight at touch with cursor (default)
'mode 1 -> highlight at click
'mode 2 -> draw a frame around the text
Dim As Integer mx, my, wheel, buttons, separatorpos, returnValue = 0
Dim As ULongInt bufferForegroundColor, bufferBackgroundColor
umlaute(text)
If yPos = 0 Then
yPos = tMenu.yPos
ElseIf yPos < 0 Then
yPos = tMenu.yPos - yPos
yPos = IIf(yPos < 0, 0, yPos)
EndIf
If xPos = 0 Then
xPos = tMenu.xPos
ElseIf xPos < 0 Then
xPos = tMenu.xPos - xPos
xPos = IIf(xPos < 0, 0, xPos)
EndIf
'adjust text position
If separator = "" Then
separatorpos = Len(text) * 8
Else
separatorpos = (InStr(text,separator) - 1) * 8
xPos = xPos - separatorpos + 8 'position text at separator
EndIf
tMenu.yPos = yPos
tMenu.xPos = xPos
tMenu.foreground = foreground
tMenu.background = background
tMenu.text = Left(text, InStr(text,separator) - 1 + Len(separator))
tMenu.buffer = buffer
GetMouse (mx,my,wheel,buttons)
Select Case (mode And 1)
Case 0 'highlight at touch
If (mx >= xpos) AndAlso (mx <= xpos + Len(text) * 8) AndAlso _
(my >= yPos) AndAlso (my <= ypos + 8) Then 'mouse cursor touches the text
returnValue Or= 8
PrintMenuItemInv() 'highlight menu item
If buttons Then 'mouse button pressed
returnValue Or= buttons
Do 'wait for release of the mouse button
GetMouse (mx,my,wheel,buttons)
Sleep 1
Loop While buttons
EndIf
Return returnValue
EndIf
Case 1 'highlight at click
If buttons Then 'mouse button pressed
returnValue Or= buttons
If (mx >= xpos) AndAlso (mx <= xpos + Len(text) * 8) AndAlso _
(my >= yPos) AndAlso (my <= ypos + 8) Then 'mouse cursor touches the text
returnValue Or= 8
PrintMenuItemInv() 'highlight menu item
Do 'wait for release of the mouse button
GetMouse (mx,my,wheel,buttons)
Sleep 1
Loop While buttons
Return returnValue
EndIf
EndIf
End Select
PrintMenuItem()
End Function
Sub pfeil(par As tPfeilparameter)
Dim As tPunkt pvon, pbis
Dim As Any Ptr gpmerken
pvon = par.von
If par.von.index Then
Select Case par.von.typ
Case _oben, _ndef
pvon = fd(par.von.index).oben
Case _unten
pvon = fd(par.von.index).unten
Case _rechts
pvon = fd(par.von.index).rechts
Case _links
pvon = fd(par.von.index).links
End Select
pvon.ofs = par.von.ofs
EndIf
pbis = par.bis
If par.bis.index Then
Select Case par.bis.typ
Case _oben, _ndef
pbis = fd(par.bis.index).oben
Case _unten
pbis = fd(par.bis.index).unten
Case _rechts
pbis = fd(par.bis.index).rechts
Case _links
pbis = fd(par.bis.index).links
End Select
pbis.ofs = par.bis.ofs
EndIf
gpmerken = fd(1).grafikpuffer
fd(1).grafikpuffer = par.grafikpuffer
If Len(par.verlauf) Then
fd(1).pfeil(pvon, par.verlauf, par.text, par.farbe)
Else
fd(1).pfeil(pvon, pbis, par.text, par.farbe)
EndIf
fd(1).grafikpuffer = gpmerken
End Sub
Function istAnschlussPunkt(index As Integer = 0) As tPunkt
Dim As tPunkt pr
Dim As Integer mx, my, rad, tasten, anfang, ende, x
If index Then 'nur ein element prüfen
anfang = index
ende = index
Else 'alle elemente prüfen
anfang = 1
ende = UBound(fd)
EndIf
GetMouse mx, my, rad, tasten : mx += xanf : my += yanf
For x = anfang To ende
With fd(x)
If (Abs(mx - .oben.x) < fd(0).fangbereich) AndAlso (Abs(my - .oben.y) < fd(0).fangbereich) Then
pr = .oben
pr.index = x
Return pr
ElseIf (Abs(mx - .unten.x) < fd(0).fangbereich) AndAlso (Abs(my - .unten.y) < fd(0).fangbereich) Then
pr = .unten
pr.index = x
Return pr
ElseIf (Abs(mx - .rechts.x) < fd(0).fangbereich) AndAlso (Abs(my - .rechts.y) < fd(0).fangbereich) Then
pr = .rechts
pr.index = x
Return pr
ElseIf (Abs(mx - .links.x) < fd(0).fangbereich) AndAlso (Abs(my - .links.y) < fd(0).fangbereich) Then
pr = .links
pr.index = x
Return pr
EndIf
End With
Next
pr.index = 0
Return pr
End Function
Sub textInput(ByRef txt As String, ByRef sp As Integer)
Dim As Integer gi
Dim As String g
g = Inkey
If Len(g) = 1 Then 'regular character
If g[0] > 31 Then 'alphabetic character
txt = Left(txt, sp - 1) + g + Mid(txt, sp)
sp += 1
Else 'control character
Select Case g[0]
Case 8 'backspace
If sp > 1 Then
txt = Left(txt, sp - 2) + Mid(txt, sp)
sp -= 1
End If
Case 13 'return
txt = Left(txt, sp - 1) + g + Mid(txt, sp)
sp += 1
End Select
End If
ElseIf Len(g) = 2 Then 'control character
gi = g[1]
Select Case gi 'control character
Case 75 'left arrow -> cursor left
If sp > 1 Then
sp -= 1
End If
Case 77 'right arrow -> cursor right
If sp <= Len(txt) Then
sp += 1
EndIf
Case 14 'backspace -> delete character before cursor
If sp > 1 Then
txt = Left(txt, sp - 1) + Mid(txt, sp)
sp -= 1
End If
Case 83 'del -> delete chracter behind cursor
If sp <= Len(txt) Then
txt = Left(txt, sp - 1) + Mid(txt, sp + 1)
End If
Case 71 'pos1 -> move cursor to the begin of the string
sp = 1
Case 79 'end -> move cursor to the end of the string
sp = Len(txt) + 1
End Select
End If
End Sub
Function menuInput(value As Integer, xPos As Integer = 0, yPos As Integer = 0) As Integer
Return Val(menuInput(Str(value), xPos, yPos))
End Function
Function menuInput(value As String, xPos As Integer = 0, yPos As Integer = 0) As String
Dim As String g, text
Dim As Integer sp, wsp
text = tMenu.text
If xPos = 0 Then
xPos = tMenu.xPos
EndIf
If yPos = 0 Then
yPos = tMenu.yPos
EndIf
If tMenu.buffer Then 'delete buffer background
Line tMenu.buffer, (xPos, yPos - 1) - (xPos + (Len(text) + Len(value)) * 8, yPos + 8), tMenu.background, BF
EndIf
ScreenSync
'prompt
Line (xPos, yPos - 1) - (xPos + (Len(text) + Len(value)) * 8, yPos + 8), tMenu.background, BF 'delete screen background
Draw String (xPos, yPos), text, tMenu.foreground
wsp = xPos + Len(text) * 8
sp = Len(value) + 1
'value
Do
textInput(value, sp)
ScreenSync
Line (xPos + Len(text) * 8, yPos - 1) - (xPos + (Len(text) + Len(value) + 3) * 8, yPos + 8), tMenu.background, BF 'delete screen background
Draw String (wsp, yPos), value, tMenu.foreground
'flashing cursor
If Frac(Timer) > .5 Then
Draw String (wsp + (sp - 1) * 8, yPos), "_", tMenu.foreground
EndIf
Sleep 1
Loop Until InStr(value, Chr(13))
value = zeichenEntfernen(value, Chr(13))
Return value
End Function
Function zeichenEntfernen(text As String, zeichen As String) As String
Dim As Integer x = InStr(text, zeichen)
While x
text = Left(text, x - 1) + Mid(text, x + Len(zeichen))
x = InStr(text, zeichen)
Wend
Return text
End Function
Sub pfeileAnpassen(index As Integer)
With fd(index)
For i As Integer = 1 To UBound(pfeile)
If pfeile(i).von.index = index Then
Select Case pfeile(i).von.typ
Case _oben, _ndef
pfeile(i).von.x = .oben.x
pfeile(i).von.y = .oben.y
Case _unten
pfeile(i).von.x = .unten.x
pfeile(i).von.y = .unten.y
Case _rechts
pfeile(i).von.x = .rechts.x
pfeile(i).von.y = .rechts.y
Case _links
pfeile(i).von.x = .links.x
pfeile(i).von.y = .links.y
End Select
pfeile(i).von.index = index
EndIf
If pfeile(i).bis.index = index Then
Select Case pfeile(i).bis.typ
Case _oben, _ndef
pfeile(i).bis.x = .oben.x
pfeile(i).bis.y = .oben.y
Case _unten
pfeile(i).bis.x = .unten.x
pfeile(i).bis.y = .unten.y
Case _rechts
pfeile(i).bis.x = .rechts.x
pfeile(i).bis.y = .rechts.y
Case _links
pfeile(i).bis.x = .links.x
pfeile(i).bis.y = .links.y
End Select
pfeile(i).bis.index = index
EndIf
Next
End With
End Sub
Sub diagrammVerschieben
Dim As Integer xmerken, ymerken, mx, my, rad, tasten, xam, yam
GetMouse xmerken, ymerken, rad, tasten
xam = xanf
yam = yanf
Do
GetMouse mx, my, rad, tasten
xanf = xam + xmerken - mx
yanf = yam + ymerken - my
neuZeichnen()
Loop While tasten
xanf = xam + xmerken - mx
yanf = yam + ymerken - my
End Sub
Sub puffergroesseAnpassen
Dim As Integer xmax, ymax, x, y, breite, hoehe, sc_breite, sc_hoehe
ScreenInfo sc_breite, sc_hoehe
ImageInfo puffer(_diagramm), breite, hoehe
For x = 1 To UBound(fd) 'maximale koordinaten ermitteln
With fd(x)
If .rechts.x > xmax Then
xmax = .rechts.x
EndIf
If .unten.y > ymax Then
ymax = .unten.y
EndIf
End With
Next
If ((pufferbreite - xmax) < sc_breite) Or _
((pufferbreite - xmax) > (2 * sc_breite)) Or _
((pufferhoehe - ymax) < sc_hoehe) Or _
((pufferhoehe - ymax) > (2 * sc_hoehe)) Then
pufferbreite = sc_breite * (Int(xmax / sc_breite) + 2)
pufferhoehe = sc_hoehe * (Int(ymax / sc_hoehe) + 2)
'puffer neu anlegen
ImageDestroy puffer(_diagramm)
puffer(_diagramm) = ImageCreate(pufferbreite, pufferhoehe, schwarz, 32)
ImageDestroy puffer(_raster)
puffer(_raster) = ImageCreate(pufferbreite, pufferhoehe, schwarz, 32)
'pointer aktualisieren
tDiagramm.diagrammpuffer = puffer(_diagramm)
For x = 0 To UBound(fd)
fd(x).grafikpuffer = puffer(_diagramm)
Next
For x = 1 To UBound(pfeile)
pfeile(x).grafikpuffer = puffer(_diagramm)
Next
neuesRaster
neuZeichnen()
EndIf
End Sub
Sub umlaute(ByRef text As String)
'ä 228 132
'ö 246 148
'ü 252 129
'Ä 196 142
'Ö 214 153
'Ü 220 154
'ß 223 225
For x As Integer = 0 To Len(text) - 1
Select Case text[x]
Case 228 'ä
text[x] = 132
Case 246 'ö
text[x] = 148
Case 252 'ü
text[x] = 129
Case 196 'Ä
text[x] = 142
Case 214 'Ö
text[x] = 153
Case 220 'Ü
text[x] = 154
Case 223 'ß
text[x] = 225
End Select
Next
End Sub
Function ini(datei As String, variable As String) As String
Dim As Integer ff
Dim As String g
ff = FreeFile
Open datei For Input As #ff
Do
Line Input #ff, g
If Left(g, InStr(g,"=") - 1) = variable Then
Close ff
Return Mid(g, InStr(g,"=") + 1)
EndIf
Loop
Return ""
End Function
Sub neuesRaster
Dim As Integer x, y
' neues raster erzeugen
Line puffer(_raster), (0,0) - (pufferbreite - 1, pufferhoehe - 1), schwarz, bf
If raster.x > 1 Then
For x = 0 To pufferbreite - 1 Step raster.x
For y = 0 To pufferhoehe - 1 Step raster.y
PSet puffer(_raster), (x,y), weiss
Next
Next
EndIf
End Sub
Sub diagrammLaden()
Dim As Integer ff, inival, i, sc_breite, sc_hoehe
Dim As String g, inivarname, datei
ReDim As String parameter(0)
ScreenInfo sc_breite, sc_hoehe
Line (0,0)-(fd(0).musterposx, sc_hoehe), schwarz, bf
Do
tMenu.xPos = 200
tMenu.yPos = 100
g = Dir(ExePath + "/*.fds")
ScreenSync
Draw String(tMenu.xPos, tMenu.yPos - 16), "DIAGRAMM LADEN", weiss
Draw String(tMenu.xPos, tMenu.yPos - 14), "______________", weiss
Do 'auswahlmenü dateien
If mausMenu(g,, 0, -2*8, IIf(g = Mid(letztedatei, InStrRev(letztedatei, "/") + 1), RGB(0,255,255), weiss), schwarz) = 9 Then
datei = ExePath + "/" + g
Exit Do, Do
EndIf
g = Dir()
Loop While Len(g)
If mausMenu("Abbrechen",, 0, -4*8, weiss, schwarz) = 9 Then
Exit Sub
EndIf
Sleep 1
Loop
ff = FreeFile
Open datei For Input As #ff
iniholen
letztedatei = datei
ReDim Preserve fd(0)
ReDim Preserve pfeile(0)
xanf = 0
yanf = 0
Seek ff,1
Do 'skript einlesen
Line Input #ff, g
g = Trim(g)
If Val(g) Then 'string beginnt mit zahl --> element
i = Val(parse(g, " ,"))
If i > UBound(fd) Then
ReDim Preserve fd(i)
EndIf
With fd(i)
Select Case parse() 'muster
Case "oval"
.muster = oval
Case "rechteck"
.muster = rechteck
Case "raute"
.muster = raute
Case "rhombus"
.muster = rhombus
Case "unterprogramm"
.muster = unterprogramm
Case "punkt"
.muster = punkt
End Select
parliste(parse(rest), parameter())
.xpos = Val(parameter(1))
.ypos = Val(parameter(2))
.breite = Val(parameter(3))
.hoehe = Val(parameter(4))
.text = Trim(parameter(5),"""")
.farbe = Val(parameter(6))
.textfarbe = Val(parameter(7))
.indexfarbe = Val(parameter(8))
End With
ElseIf parse(g, " ,") = "pfeil" Then
ReDim Preserve pfeile(UBound(pfeile) + 1)
parliste(parse(rest), parameter())
With pfeile(UBound(pfeile))
.von.x = Val(parameter(1))
.von.y = Val(parameter(2))
.von.typ = Val(parameter(3))
.von.ofs = Val(parameter(4))
.von.index = Val(parameter(5))
.bis.x = Val(parameter(6))
.bis.y = Val(parameter(7))
.bis.typ = Val(parameter(8))
.bis.ofs = Val(parameter(9))
.bis.index = Val(parameter(10))
.verlauf = parameter(11)
.text = Trim(parameter(12),"""")
.farbe = Val(parameter(13))
.grafikpuffer = puffer(_diagramm)
End With
EndIf
Loop Until EOF(ff)
Close ff
For i = 1 To UBound(fd)
With fd(i)
.arrayptr = @fd(0)
.grafikpuffer = puffer(_diagramm)
End With
Next
puffergroesseAnpassen
Line puffer(_legende), (fd(0).musterposx, 0) - (sc_breite - 1, sc_hoehe - 1), hellgruen, bf 'hintergrund für legende
neuesRaster
neuZeichnen
WindowTitle datei
End Sub
Sub diagrammSpeichern()
Dim As String g, datei
Dim As Integer ff, i, sc_breite, sc_hoehe, xmerken, ymerken
Dim As tMenu menuMerken
Do
ScreenInfo sc_breite, sc_hoehe
Line (0,0)-(fd(0).musterposx, sc_hoehe), schwarz, bf
Do
g = Dir(ExePath + "/*.fds")
tMenu.xPos = 200
tMenu.yPos = 100
ScreenSync
Draw String(tMenu.xPos, tMenu.yPos - 16), "DIAGRAMM SPEICHERN", weiss
Draw String(tMenu.xPos, tMenu.yPos - 14), "__________________", weiss
Do
If mausMenu(g,, 0, -2*8, IIf(g = Mid(letztedatei, InStrRev(letztedatei, "/") + 1), RGB(0,255,255), weiss), schwarz) = 9 Then
datei = ExePath + "/" + g
Exit Do, Do
EndIf
g = Dir()
Loop While Len(g)
If mausMenu("Speichern unter...",, 0, -4*8, weiss, schwarz) = 9 Then
datei = Mid(letztedatei, InStrRev(letztedatei, "/") + 1)
datei = Left(datei, InStr(datei, ".") - 1)
Line(tMenu.xPos, tMenu.yPos - 1) - (tMenu.xPos + 20*8, tMenu.yPos + 8) , schwarz, bf
datei = menuInput(datei)
datei = ExePath + "/" + datei
If InStr(datei, ".") = 0 Then
datei += ".fds"
EndIf
Exit Do, Do
ElseIf mausMenu("Abbrechen",, 0, -4*8, weiss, schwarz) = 9 Then
Exit Sub
EndIf
xmerken = tMenu.xPos
ymerken = tMenu.yPos
Sleep 1
Loop
g = "Datei " & Chr(129) & "berschreiben ?"
umlaute(g)
If FileExists(datei) Then
Draw String(xmerken, ymerken + 5*8), g, weiss
Do
If mausMenu(" Ja ",, xmerken + 200, ymerken + 5*8, weiss, schwarz, 2) = 9 Then
Exit Do, Do
ElseIf mausMenu(" Nein ",, -50, 0, weiss, schwarz, 2) = 9 Then
Continue Do, Do
EndIf
Sleep 1
Loop
Else
Exit Do
EndIf
Loop
letztedatei = datei
ff = FreeFile
Open datei For Output As #ff
inispeichern
Print #ff, ""
For i = 1 To UBound(fd)
With fd(i)
.arrayptr = @fd(0)
Print #ff, .index;" ";
Select Case .muster
Case oval
Print #1, "oval ";
Case rechteck
Print #1, "rechteck ";
Case raute
Print #1, "raute ";
Case rhombus
Print #1, "rhombus ";
Case unterprogramm
Print #1, "unterprogramm ";
Case punkt
Print #1, "punkt ";
End Select
Print #ff, .xpos;",";.ypos;",";.breite;",";.hoehe;",";
Print #ff, """";.text;"""";",";
Print #ff, .farbe;",";.textfarbe;",";.indexfarbe
End With
Next
Print #ff, ""
For i = 1 To UBound(pfeile)
With pfeile(i)
Print #ff, "pfeil ";.von.x;",";.von.y;",";.von.typ;",";.von.ofs;",";.von.index;",";
Print #ff, .bis.x;",";.bis.y;",";.bis.typ;",";.bis.ofs;",";.bis.index;",";
Print #ff, .verlauf;",";
Print #ff, """";.text;"""";",";
Print #ff, .farbe
End With
Next
Close #ff
WindowTitle datei
End Sub
Sub programmEnde()
Dim As Integer x, ff
Dim As String datei
For x = 1 To UBound(puffer)
ImageDestroy puffer(x)
Next
datei = Command(0)
datei = Left(datei, InStrRev(datei, ".exe") - 1) + ".ini"
ff = FreeFile
Open datei For Output As #ff
inispeichern
Close ff
End
End Sub
Re: 2d data structure without fixed boundaries
I actually used spatial hashing before, when simulating many collisions. I forgot the name of the technique. For this purpose however, it don't like it too much.paul doe wrote:A spatial hash?
The German part is not a big problem, neither is pasting two sections of code is one file :-)grindstone wrote:It's completely in German, sorry for that inconvenience, and another inconvenience: The code is too big for a single message, so I had to split it.
Bigger problems appear when I try to compile:
Code: Select all
test.bas(941) error 92: Array out-of-bounds, found ')' in 'puffer(_grafik) = ImageCreate(breite, hoehe,, bpp * 8) 'grafikpuffer erzeugen'
test.bas(942) error 92: Array out-of-bounds, found ')' in 'puffer(_hintergrund) = ImageCreate(breite, hoehe, weiss, bpp * 8) 'grafikpuffer mit weissem hintergrund erzeugen'
test.bas(943) error 92: Array out-of-bounds, found ')' in 'Get puffer(_diagramm), (0,0)-(breite - 1, hoehe - 1), puffer(_grafik) 'diagramm in puffer1 laden'
...
Compilation failed.
Code: Select all
Enum
_legende = 1
_diagramm
_raster
_grafik
_hintergrund
End Enum
Dim Shared As Any Ptr puffer(_raster)
puffer(_grafik) = ImageCreate(breite, hoehe,, bpp * 8) 'grafikpuffer erzeugen
The other big problem is trying to understand 2000 lines of code and then figure out what I can use.
Thanks for posting, but I probably go with the dodicat approach (which I still have to test).
-
grindstone
- Posts: 862
- Joined: May 05, 2015 5:35
- Location: Germany
Re: 2d data structure without fixed boundaries
Understandable. *grin*badidea wrote:The other big problem is trying to understand 2000 lines of code and then figure out what I can use.
After rethinking the problem I would suggest another approach. FB already has a built-in 2D map with all necessary tools which work mighty fine: The image and graphics statements. An image is an organized array of 32bit values, and it does not necessarily have to contain colour values, you may also write (32bit-) pointers to it (in a 64 bit system you need two images, one for the 32 high order bits and another for the low order bits).
I couldn't resist to write a little example program (use the arrow keys to shift the tiles on the board):
Code: Select all
#Include Once "fbgfx.bi"
Type tTile
number As Integer
End Type
Dim As Integer x, y, count, mapmax_x, mapmax_y, start_x, start_y
Dim As tTile Ptr tp
Declare Sub display(viewx As ULong, viewy As ULong, map As FB.image Ptr)
ScreenRes 900, 900, 32
'create initial map
Dim As FB.image Ptr map = ImageCreate(50, 50, 0) 'default size 50 x 50
Dim As FB.image Ptr maptemp
'create some tiles
Dim As Integer tile_x, tile_y
For count = 1 To 10
tp = New tTile
tp->number = count
tile_x = Int(Rnd * 10)
tile_y = Int(Rnd * 10)
Do Until Point(tile_x, tile_y, map) = 0 'find an empty point
tile_x = Int(Rnd * 10)
tile_y = Int(Rnd * 10)
Loop
PSet map, (tile_x, tile_y), Cast(ULong, tp) 'write the tile pointer to the map
Next
Do
ImageInfo map, mapmax_x, mapmax_y
Select Case InKey
Case Chr(255,77) 'arrow right
If start_x >= mapmax_x - 10 Then 'add one column at the right side
maptemp = ImageCreate(mapmax_x + 1, mapmax_y, 0)
Put maptemp, (0, 0), map, (0, 0) - (mapmax_x - 1, mapmax_y - 1), PSet
ImageDestroy map
map = maptemp
maptemp = 0
EndIf
start_x += 1
Case Chr(255,75) 'arrow left
If start_x > 0 Then
start_x -= 1
Else 'add one column at the left side
maptemp = ImageCreate(mapmax_x + 1, mapmax_y, 0)
Put maptemp, (1, 0), map, (0, 0) - (mapmax_x - 1, mapmax_y - 1), PSet
ImageDestroy map
map = maptemp
maptemp = 0
EndIf
Case Chr(255,80) 'arrow down
If start_y >= mapmax_y - 10 Then 'add one row at the bottom
maptemp = ImageCreate(mapmax_x, mapmax_y + 1, 0)
Put maptemp, (0, 0), map, (0, 0) - (mapmax_x - 1, mapmax_y - 1), PSet
ImageDestroy map
map = maptemp
maptemp = 0
EndIf
start_y += 1
Case Chr(255,72) 'arrow up
If start_y > 0 Then
start_y -= 1
Else 'add one row at the top
maptemp = ImageCreate(mapmax_x, mapmax_y + 1, 0)
Put maptemp, (0, 1), map, (0, 0) - (mapmax_x - 1, mapmax_y - 1), PSet
ImageDestroy map
map = maptemp
maptemp = 0
EndIf
Case " "
Exit Do
End Select
ImageInfo map, mapmax_x, mapmax_y
display(start_x, start_y, map)
Loop
'delete all tiles
ImageInfo map, mapmax_x, mapmax_y
For x = 0 To mapmax_x - 1
For y = 0 To mapmax_y - 1
tp = Cast(tTile Ptr, Point(x, y, map))
If tp Then
Delete tp
EndIf
Next
Next
Sub display(viewx As ULong, viewy As ULong, map As FB.image Ptr)
Dim As Integer x, y, scx, scy
'create view section, the piece of the map that's displayed on the screen (10 x 10 tiles)
Dim As FB.image Ptr viewsection = ImageCreate(10, 10, 0)
Dim As tTile Ptr tps
Dim As String text
'copy the section to be displayed to the buffer
Get map, (viewx, viewy) - (viewx + 9, viewy + 9), viewsection
ScreenLock
Cls
For y = 0 To 9
For x = 0 To 9
Line (x * 90 + 5, y * 90 + 5) - ((x + 1) * 90 - 5, (y + 1) * 90 - 5), RGB(255, 255, 255), b
tps = Cast(tTile Ptr, Point(x, y, viewsection))
Draw String(x * 90 + 10, y * 90 + 10), "x=" & viewx + x & " y=" & viewy + y, RGB(255, 255, 255)
If tps Then
text = Str(tps->number)
Else
'text = "empty"
text = ""
EndIf
Draw String(x * 90 + 30, y * 90 + 30), text, RGB(255, 255, 255)
Next
Next
ScreenUnLock
ImageDestroy viewsection
End Sub
EDIT: Maybe it's an easier solution (especially for 64bit systems) to create a one-dimensional array of the tiles and write the indices to the map.
Last edited by grindstone on Sep 23, 2021 10:53, edited 1 time in total.
Re: 2d data structure without fixed boundaries
What isn't understandable however, in this 'day and age' is, that it only works with FBC 32-bit. :(grindstone wrote:I couldn't resist to write a little example program (use the arrow keys to shift the tiles on the board):
Hint: all the Cast's seem to be affected. Also might be a good idea to replace Integer with Long.
(for current 1.08.1 version of FBC, and later)