 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
h7b5
Anmeldungsdatum: 13.07.2009
Beiträge: 10
|
 Verfasst am: 10.03.2015, 00:26 Titel: suche Möglichkeit zur Grafikabfrage ähnlich wie POINT |
 |
|
Hallo liebe Basic Programmierer
Ich möchte mir ein kleines Programm schreiben, welches, mehr oder weniger zufällig, Dots(gefüllte Circle) auf einen Screen zeichnet .
Gleichzeitig sollen die Dots einen definierbaren Mindestabstand zueinander einhalten.
Hab sowas ähnliches früher schon mal mit mehreren Point Abfragen rund um die aktuellen Koordinaten gemacht, was aber höchst unkomfortabel wurde wenn die Abständen größer wurden... 
Könnt ihr mir einen Vorschlag machen wie man das lösen kann ?
Ideal wäre, wenn ich ein Kreis-förmiges Array mit definierbarem Radius abfragen könnte, ähnlich wie es mit der Point Abfrage möglich ist.
freundliche Grüße Martin |
|
| Nach oben |
|
 |
Jojo
alter Rang
Anmeldungsdatum: 12.02.2005
Beiträge: 9736
Wohnort: Neben der Festplatte
|
| Verfasst am: 10.03.2015, 01:11 Titel: |
|
|
Wie wäre es, wenn du einfach jeden bisher gesetzten Punkt in ein Array speicherst und dann bei der Auswahl eines neuen möglichen Punktes den Abstand zu allen bisherigen Punkten berechnest und prüfst, ob dieser zu klein ist? Den Abstand zwischen zwei gegebenen Punkten kann man einfach berechnen.
_________________
» Die Mathematik wurde geschaffen, um Probleme zu lösen, die es nicht gäbe, wenn die Mathematik nicht erschaffen worden wäre.
 |
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1839
Wohnort: [JN58JR]
|
| Verfasst am: 10.03.2015, 10:27 Titel: |
|
|
Als Idee würde ich folgende vorgehensweise vorschlagen:
* Screen mit x * y definieren
* screen erzeugen
* Mindestabstand definieren
* map = imagecreate(x / mindestabstand, y / mindestabstand)
* if point(map, zufall x, zufall y)
* wenn frei dann set pixel in map und circle auf screen
MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
h7b5
Anmeldungsdatum: 13.07.2009
Beiträge: 10
|
| Verfasst am: 10.03.2015, 16:38 Titel: |
|
|
Hallo und vielen dank schonmal für eure Tips
Ich hab es gestern erstmal so "gelöst":
| Code: | Screenres 1024,1024,4
DIM as ushort x,y,radius
Randomize Timer
neu:
if Inkey <> "" then goto ende
radius=RND*2+3
x=RND*1024
y=RND*1024
if Point(x,y)<>0 then goto neu
if Point(x,y+9)<>0 then goto neu
if Point(x+4,y+8)<>0 then goto neu
if Point(x+8,y+4)<>0 then goto neu
if Point(x+9,y)<>0 then goto neu
if Point(x+8,y-4)<>0 then goto neu
if Point(x+4,y-8)<>0 then goto neu
if Point(x,y-9)<>0 then goto neu
if Point(x-4,y-8)<>0 then goto neu
if Point(x-8,y-4)<>0 then goto neu
if Point(x-9,y)<>0 then goto neu
if Point(x-8,y+4)<>0 then goto neu
if Point(x-4,y+8)<>0 then goto neu
if Point(x,y+5)<>0 then goto neu
if Point(x+3,y+3)<>0 then goto neu
if Point(x+5,y)<>0 then goto neu
if Point(x+3,y-3)<>0 then goto neu
if Point(x,y-5)<>0 then goto neu
if Point(x-3,y-3)<>0 then goto neu
if Point(x-5,y)<>0 then goto neu
if Point(x-3,y+3)<>0 then goto neu
Circle(x,y), radius, 15, , , 1, F
goto neu
ende:
sleep |
Hab den Bereich um die zufällig generierten Koordinaten eben nur punktuell, in regelmässigen Abständen, abgefragt. Damit kann ich den Radius des abgefragten Bereichs allerdings noch nicht flexibel, als Variable, verwenden.
Meine Programmier-Kentnisse sind allerdings auch sehr begrenzt, so daß ich eure Tips nicht auf Anhieb umsetzen kann. Aber ich werd mal schauen was ich daraus, wie, verwenden kann.
Bei der Abfrage würde es mir ausreichen zu testen, ob irgend ein Pixel im fraglichen Bereich nicht schwarz ist.
Allgemeine Info zum Zweck meines Projekts:
Das Ergebniss soll letztlich mal als Image Textur dienen und wird, in einem Zwischenschritt, noch in einem Bildbearbeitungsprogramm bearbeitet.
Gruß Martin |
|
| Nach oben |
|
|
St_W
Anmeldungsdatum: 22.07.2007
Beiträge: 956
Wohnort: Austria
|
| Verfasst am: 10.03.2015, 17:38 Titel: |
|
|
Hässlich.
Schon wenn man rein die Struktur betrachtet und den Algorithmus einmal außen vor lässt. Goto und Labels sollten in der Regel niemals im Programm vorkommen!
| Code: | DO
if Inkey <> "" then EXIT DO
[...]
if Point(x,y)<>0 then CONTINUE DO
if Point(x,y+9)<>0 then goto CONTINUE DO
[...]
Circle(x,y), radius, 15, , , 1, F
LOOP
[...] |
_________________
Aktuelle FreeBasic Builds, Projekte, Code-Snippets unter http://users.freebasic-portal.de/stw/
http://www.mv-lacken.at Musikverein Lacken (MV Lacken) |
|
| Nach oben |
|
|
h7b5
Anmeldungsdatum: 13.07.2009
Beiträge: 10
|
| Verfasst am: 10.03.2015, 18:05 Titel: |
|
|
Das ist nicht hässlich, das ist mein persönlicher Amiga Basic Style. 
Ich habs nie "richtig" gelernt, und nach meiner Amiga Zeit auch nicht mehr viel dazu gelernt. Natürlich hab ich auch schon mal gehört, daß "goto" böse ist. Ich hab nur nie begriffen warum.  |
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1839
Wohnort: [JN58JR]
|
| Verfasst am: 10.03.2015, 18:21 Titel: |
|
|
@h7b5
nun .. es gibt unheimlich viele Lösungen für dieses Problem. Die Frage ist eher, welche Lösung du bevorzugst.
Die wohl Code-Sparenste Variante wäre die bereits vorhandenen Funktionen von Freebasic auszunutzen, um die Prüfung auszuführen.
In DIESEM Bild habe ich einmal 2 Beispiele aufgeführt.
Du siehst darin (von links nach Rechts) jeweils ein Bild mit Kreisen.
Im Ersten (Linkem) Bild siehst du 2 bereits gezeichnete Kreise (Gelb). Zusätzlich habe ich die Position (grün) für den nächsten Kreis markiert.
Im Nächsten Bild habe ich den "Freiraumradius" für den nächsten Kreis (Rot) eingezeichnet. Dieser Bereich soll freigehalten werden.
Mithilfe von Freebasic erzeugen wir nun eine Maske (Das untere Bild in welchem NUR ein Roter Kreis enthalten ist). Diese Maske wird anschliessend mit dem aktuellem Bild (Nur die beiden Gelben kreise) AND verknüpft.
Das Ergebniss ist dann ganz rechts zu sehen.
Im Oberem Beispiel entsteht dabei ein komplett Schwarzes Bild.
Im Unterem Beispiel entstehehen "flecken" welche die "kollision" darstellen.
Schlussendlich brauchen wir jetzt nur noch das erzeugte "Mischbild" auf eine Farbe hin prüfen. Sobald an irgend einer Position dieses Bildes kein Schwarz vorhanden ist (mit Point zu prüfen), dann bedeutet dies, das der Freiraum um unseren später zu zeichnenen Kreis durch einen anderen kreis beeinträchtigt wurde.
Code-Seitig ist dies auch nicht sonderlich wild zu reaisieren.
| Code: | 'Variablen für die Sichtbare Ausgabe
Dim G_ScreenW as Integer = 640 'Fensterbreite festlegen
Dim G_ScreenH as Integer = 480 'Fensterhöhe festlegen
ScreenRes G_ScreenW, G_ScreenH, 32 'Ein Fenster mit 32-Bit Farbtiefe erzeugen.
'Variablen für die Bild-Berechnung
Dim TImageOutput as Any Ptr = ImageCreate(G_ScreenW, G_ScreenH, 0, 32) 'Ein Bildspeicher für das Ausgabebild erzeugen
Dim TImageMask as Any Ptr = ImageCreate(G_ScreenW, G_ScreenH, 0, 32) 'Ein Bildspeicher für das Maskenbild erzeugen
Dim TImageAND as Any Ptr = ImageCreate(G_ScreenW, G_ScreenH, 0, 32) 'Ein Bildspeicher für das AND-Verknüpfingsergebniss
Dim TCircleRadius as Integer = 30 'Radius für unseren Kreis. Kann mit Dem Maus-Rad geändert werden
Dim TCanAddCircle as Integer 'Eine Temporäre Variable die später signalisierung, ob wir einen Kreis zeichnen dürfen.
'Variablen für die Interaktion
Dim TMouseR as Integer 'Variable für GetMouse
Dim TMouseX as Integer '-||-
Dim TMouseY as Integer '-||-
Dim TMouseZ as Integer '-||-
Dim TMouseZL as Integer '-||-
Dim TMouseB as Integer '-||-
Dim TMouseBL as Integer '-||-
'Hauptprogramm-Schleife
Do Until InKey() = Chr(27) 'Das Programm solange laufen lassen, bis ESC gedrückt wurde
'Interaktion und Kreis-Parameter berechnen
TMouseR = GetMouse(TMouseX, TMouseY, TMouseZ, TMouseB) 'Die Aktuelle Mausposition erfassen
If TMouseR <> 0 Then 'Wenn die Rückgabe von GetMouse ungleich 1 ist, dann ist die Maus nicht im Fenster
Sleep 1, 1 'Kurz Warten
Continue Do 'Und die Schleife von vorne beginnen. Hauptprogramm muss dann nicht weiter ausgeführt werden.
End If
TCircleRadius += TMouseZL - TMouseZ 'Die Kreisgröse anhand des Mausrades neu bestimmen
If TCircleRadius < 10 Then TCircleRadius = 10 'Wir stellen Sicher, das der Kreis niemals kleiner als 10 ist!
TMouseZL = TMouseZ 'Den Aktuellen Mausrad-Wert speichern, um später die Gröse neu bestimmen zu können.
'Kreisberechnung und prüfung
Line TImageAND, (0, 0)-(G_ScreenW - 1, G_ScreenH - 1), &H00000000, BF 'Jedes Pixel des Bildspeicher für das AND ergebniss auf 0 setzen (Gefüllter Rechteckiger bereich mit der Farbe Schwarz ;)
Circle TImageAND, (TMouseX, TMouseY), TCircleRadius, &HFFFFFFFF, , , , F 'Einen Gefülten Kreis in die Maske zeichnen (weiß)
Put TImageAND, (0, 0), TImageOutput, AND 'Das Maskenbild (AND) mit dem aktuellen Ausgabebild AND verknüpfen
TCanAddCircle = 1 'Wir nehmen erstmal an, das wir später einen Kreis erzeugen dürfen
For Y as Integer = 0 to G_ScreenH - 1 'Wir gehen das Ergebnissbild Zeile für Zeile durch
For X as Integer = 0 to G_ScreenW - 1 'Wir gehen das Ergebnissbild Spalte für Spalte durch
If Point(X, Y, TImageAND) <> 0 Then 'Wenn wir einen Punkt finden, der nicht 0 (schwarz) ist
TCanAddCircle = 0 'Dann verweigern wir das spätere Zeichnen
Exit For 'Gleichzeitig beenden wir die Suche.
End If
Next
If TCanAddCircle = 0 Then Exit For 'Wenn wir nicht zeichnen dürfen, dann verlassen wir auch die nächste Schleife
Next
If (TMouseBL and &B00000001) <> 0 Then 'Wenn die Linke Maustaste gedrückt wurde
If TCanAddCircle = 1 Then 'Nur dann einen Kreis hinzufügen, wenn der Platz auch Frei ist
Circle TImageOutput, (TMouseX, TMouseY), TCircleRadius - 5, &HFFFFFFFF, , , , F 'Dann einen gefülten Kreis in das Ausgabebild einzeichnen. Wir Verkleinen den Radius um 5 Pixel!
End If
End If
TMouseBL = TMouseB 'Maustasten für nöchsten durchlauch speichern
'Ausgabebild neu aufbauen
ScreenLock() 'Die Bildaktualisierung sperren
CLS() 'Das Fenster Leeren, um alles neu zeichnen zu können
Put (0, 0), TImageOutput, PSET 'Das Ausgabebild auf das Fenster Zeichnen
Circle (TMouseX, TMouseY), TCircleRadius, &HFFFF0000
ScreenUnLock() 'Die Bildaktualisierung wieder freigeben
'Computer-Entlastung
Sleep 10, 1 'Die CPU schonen
Loop
End 0 'Anwendung sauber beenden
|
Einzigstes Nadelöhr ist die Suche mit der Funktion "Point()". Sie ist extrem langsam, im vergleich zu anderen Varianten.
Aber, Das Grundprinzip sollte im Code deutlich werden.
MfG
TPM
PS: Goto ist nicht böse! .. keine Angst davor! Man kann GoTo durchaus sinnvoll und nutzbringend einsetzen. Ich verstehe auch nicht, warum die Leute das immer wieder sagen.
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
dreael
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 2529
Wohnort: Hofen SH (Schweiz)
|
| Verfasst am: 10.03.2015, 22:55 Titel: |
|
|
Von mir sonst auch ein Beispiel:
http://beilagen.dreael.ch/QB/Zufallskreise.bas
@h7b5: Mit den vielen Konstanten kannst Du spielen. :-)
Vom Programm-Grundaufbau her einige Dinge:
- vollständig ohne GOTO
- Dinge wie gewünschter Mindestabstand der Kreise, Entfernung vom Bildschirmrand usw. als Konstanten (Const)
- Auch an den Fall gedacht, wenn schon derart viele Kreise vorhanden sind, dass man mit "Würfeln" keinen Erfolg mehr hat (Begrenzung der Zahl dieser Versuche)
Vom Algorithmus her: Keinerlei POINT() nötig (ist hier wirklich der falsche Ansatz!), sondern ein Array aus Kreisen (als Typ implementiert), was bisher gezeichnet wurde, denn ich muss nach jedem "Würfeln" überprüfen, ob es zu sämtlichen bisherigen Kreisen (in diesem Array) genügend Abstand hat.
@h7b5: Schon im ganz alten AmigaBASIC wie seinerzeit bei Workbench 1.3 dabei wäre eine solche GOTO-freie Umsetzung bereits möglich gewesen; dort hättest Du lediglich den Kreis-Typ halt durch drei Einzel-Arrays ersetzen müssen, Konstanten als normale Variablen.
_________________
Teste die PC-Sicherheit mit www.sec-check.net |
|
| Nach oben |
|
|
h7b5
Anmeldungsdatum: 13.07.2009
Beiträge: 10
|
| Verfasst am: 11.03.2015, 00:39 Titel: |
|
|
Hallo dreael
Ich muss mich sehr bedanken !
Das ist ziemlich genau das, was ich auch bauen wollte.
- wählbarer Mindestabstand
- min/max Punktdurchmesser
Das ist alles was das Herz begehrte.
Ich hab zwar irgendwie den Ehrgeiz das wenigstens zu verstehen
aber ich befürchte, das wird so bald nix. 
z.B. hab ich keine Idee wo und wie die Abfrage für den Abstand stattfindet
...aber warscheinlich würde lange Erklärungen mir da, bei meinem Wissensstand,
auch nicht viel weiter helfen.
Konkret stellt sich mir jedoch gerade die Frage, ob der Abstand zwischen den
Kreisen(von Rand zu Rand ) oder zwischen den Kreismittelpunkten berechnet wird ?
EDIT - OK, hab gerade "experimentell ermittelt", daß der Abstand von Rand zu Rand ist.
Zumindest ein wenig verstehe ich aber immerhin. Hab es jedenfalls
geschafft die Screen Auflösung zu ändern und weisse gefüllte Circle zeichnen zu lassen. 
Also nochmal vielen Dank und Gruß Martin |
|
| Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1278
Wohnort: Ruhrpott
|
| Verfasst am: 11.03.2015, 10:32 Titel: |
|
|
Hallo h7b5!
Noch eine Anmerkung zum "bösen" GOTO: Dieser Befehl bringt einen Hauch von Assmbler in die Basic - Programmierung - mit allen damit verbundenen Fallstricken. Richtig eingesetzt kann er - besonders bei kompliziert verschachtelten Strukturen - das Programm erheblich vereinfachen, man muß allerdings darauf achten, daß es keine Konflikte mit den übrigen Kontrollstrukturen gibt. Während das Herausspringen aus einer Schleife im allgemeinen unproblematisch und das Hineinspringen bei entsprechender Vorsicht noch beherrschbar ist... | Code: | Dim As Integer x = 5
GoTo schleife
For x = 1 To 20
schleife:
Print "x =";x
Next
Sleep |
... führt das Hineinspringen in einen Scope-Block zu undefinierten Ergebnissen: | Code: | Dim As Integer x = 5
GoTo schleife
For x As Integer = 1 To 20
schleife:
Print "x =";x
Next
Sleep |
Hier gibt der Compiler immerhin eine Warnmeldung aus.
Und das Hineinspringen in ein Unterprogramm führt mit Sicherheit zu einem Programmabsturz. | Code: | Declare Sub unterprogramm
Print "Vor dem Unterprogramm"
Sleep
GoTo sprung
Print "Nach dem Unterprogramm"
Sleep
Sub unterprogramm
sprung:
Print "Im Unterprogramm"
Sleep
End Sub
|
Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
| Nach oben |
|
|
dreael
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 2529
Wohnort: Hofen SH (Schweiz)
|
| Verfasst am: 11.03.2015, 19:39 Titel: |
|
|
| h7b5 hat Folgendes geschrieben: | | Ich muss mich sehr bedanken ! |
:-)))
| h7b5 hat Folgendes geschrieben: | Ich hab zwar irgendwie den Ehrgeiz das wenigstens zu verstehen
aber ich befürchte, das wird so bald nix. :oops:
z.B. hab ich keine Idee wo und wie die Abfrage für den Abstand stattfindet
...aber warscheinlich würde lange Erklärungen mir da, bei meinem Wissensstand,
auch nicht viel weiter helfen. |
Für Dich einmal das Wichtigste ein wenig auseinandergepflückt:
| Code: | | While anzKreise < MAX_KREISE And versuche < MAX_VERSUCH |
Grosse Schleife ums Ganze, die für das wiederholte Zeichnen sorgt. Soll abbrechen, sobald entweder die maximale Zahl der Kreise (Array ist begrenzt gross!) oder das Maximum an Versuchen verbraucht ist, um mit "Würfeln" noch eine Lücke zu finden.
| Code: | | k(anzKreise).r = RADIUS_MIN + (RADIUS_MAX - RADIUS_MIN) * Rnd |
"Würfeln": Zuerst immer der Radius
| Code: | k(anzKreise).mx = MIN_RAND + k(anzKreise).r + (xWeite - 2.0 * k(anzKreise).r) * Rnd
k(anzKreise).my = MIN_RAND + k(anzKreise).r + (yWeite - 2.0 * k(anzKreise).r) * Rnd |
Ein erstes bisshen jedoch wichtige Mathematik: Je grösser der "gewürfelte" Radius, desto kleiner der Bereich für die x- und y-Koordinate. Als kleine Übung für Dich kannst Du einmal eine kleine Massskizze mit den verschiedenen rechteckigen Bereichen zeichnen. Aufgrund der Eigenschaft, dass Rnd() immer eine Zahl im Intervall 0..1 liefert, kommst Du dann hoffentlich selber auf obige Formeln.
| Code: | ok = -1 ' wäre TRUE
For i=0 To anzKreise - 1 |
Und hier folgt die Filterung, ob der Kreis überhaupt passt. Zuerst einmal annehmen, dass er passt => ok = True. Dann die Liste (Array) aller bisherigen Kreise durchgehen.
| Code: | If quad(k(anzKreise).mx - k(i).mx) + quad(k(anzKreise).my - k(i).my) < _
quad(k(anzKreise).r + MIN_ABSTAND + k(i).r) Then
' liegt zu nahe zu einem bestehenden Kreis
ok = 0 ' wäre FALSE
EndIf |
Und hier liegt die von Dir gesuchte Abstandsberechnung bzw. Bedingung; ins Spiel kommt der berühmte Pythagoras, wo die Hypothenuse in unserem im Koordinatensystem gebildeten Dreiecks länger (oder gleich) als die Summe beider Kreisradien + Mindestabstand sein muss (Übung für Dich: Skizze auch hier zeichnen!). Folgende Geschwindigkeitsoptimierungen kommen noch hinein: Statt
| Code: | | If Sqr(dx ^ 2 + dy ^ 2) < r1 + r2 + a Then |
nehme ich diese Ungleichung ins Quadrat, weil Wurzelberechnung relativ langsam ist:
| Code: | | If dx ^ 2 + dy ^ 2 < (r1 + r2 + a)^2 Then |
Und weil ^ bei Fliesskommazahlen meistens als
| Code: | | a ^ b = Exp(Log(a) * b) |
implementiert ist (langsame Funktionen!), multipliziere ich lieber mit sich selbst, also als
| Code: | | If dx * dx + dy * dy < (r1 + r2 + a)*(r1 + r2 + a) Then |
formuliert. Ein wirklich harter Optimierer würde hier noch ein
hineinnehmen, sobald ok = False gesetzt ist.
| Code: | If ok Then
' Kreis passt von der Verteilung her
Circle(k(anzKreise).mx, k(anzKreise).my), k(anzKreise).r, 1 + anzKreise Mod 15
anzKreise += 1
versuche = 0
Else
' Versuchszähler erhöhen, sonst kann Routine in Endlosschleife geraten, wenn einmal
' alles ziemlich dicht belegt ist
versuche += 1
EndIf |
Und wenn der Kreis nirgens Überschneidungen verursacht (das "ok" konnte seinen True-Wert beibehalten, weil keine Abstandunterschreitungsbedingung in der For-Schleife zugetroffen ist), dann darf er gezeichnet und im Array gespeichert werden, ausserdem die Versuchszählung wieder von vorne beginnen, sonst wird jeder "Würfel"-Fehlversuch hochgezählt.
Und das WHILE zu Beginn sorgt dann schon dafür, dass es rechtzeitig abbricht.
_________________
Teste die PC-Sicherheit mit www.sec-check.net |
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
