BlitzQuiz - AUFLÖSUNG: Geheime Bild-Botschaften

Übersicht Sonstiges Projekte

Gehe zu Seite Zurück  1, 2, 3, 4, 5  Weiter

Neue Antwort erstellen

grafe

 BeitragDi, Mai 24, 2011 14:17
Antworten mit Zitat
Benutzer-Profile anzeigen
@ToeB dein Code zeigt bei mir 641 Quadrate an :S

ToeB

 BeitragDi, Mai 24, 2011 14:59
Antworten mit Zitat
Benutzer-Profile anzeigen
Ja, bei mir komischerweise jetzt auch ... muss mal gucken was ich dran verändert habe. Hier der Beweis dass ich doch mal das richtige Ergebnis hatte :
user posted image

mfg ToeB
Religiöse Kriege sind Streitigkeiten erwachsener Männer darum, wer den besten imaginären Freund hat.
Race-Project - Das Rennspiel der etwas anderen Art
SimpleUDP3.0 - Neuste Version der Netzwerk-Bibliothek
Vielen Dank an dieser Stelle nochmal an Pummelie, welcher mir einen Teil seines VServers für das Betreiben meines Masterservers zur verfügung stellt!

mpmxyz

 BeitragDi, Mai 24, 2011 16:41
Antworten mit Zitat
Benutzer-Profile anzeigen
Bei mir gibt es nichts besonderes - maximal eine Doppelschleife und Pointer:
BlitzMax: [AUSKLAPPEN] 
SuperStrict
Local pixmap:TPixmap=LoadPixmap("BlitzQuiz-Quadrate.png")
Local time1:Int=MilliSecs()

Local sizeCounter:Int[,]=New Int[pixmap.width,pixmap.height] 'beinhaltet die Asymmetrie

Local totalSquares:Int=0

Local pixelPtr:Int Ptr=Int Ptr(pixmap.PixelPtr(1,1))
Local pitch:Int=pixmap.pitch
Local height:Int=pixmap.height

For Local x:Int=1 Until pixmap.width
	For Local y:Int=1 Until height
		If pixelPtr[0]=pixelPtr[-pitch/4]
			sizeCounter[x,y]=sizeCounter[x,y-1]+1
		ElseIf pixelPtr[0]=pixelPtr[-1]
			sizeCounter[x,y]=sizeCounter[x-1,y]-1
		EndIf
		If pixelPtr[-pitch/4-1]<>$FFFFFFFF	'weiß ignorieren
			If pixelPtr[-pitch/4-1]<>pixelPtr[-pitch/4] And pixelPtr[-pitch/4-1]<>pixelPtr[-1] 'Ende des Rechteckes
				If sizeCounter[x-1,y-1]=0
					totalSquares:+1
				EndIf
			EndIf
		EndIf
		pixelPtr=Int Ptr(Byte Ptr(pixelPtr)+pitch)
	Next
	pixelPtr=Int Ptr(Byte Ptr(pixelPtr)-(height-1)*pitch+4)
Next
Local time2:Int=MilliSecs()
Print totalSquares+" squares in "+(time2-time1)+"ms"

Falls die Pixmap nicht 32 Bit-Pixel enthalten sollte, funktioniert der Code aber nicht.
mfG
mpmxyz
Moin Moin!
Projekte: DBPC CodeCruncher Mandelbrot-Renderer

blackgecko

 BeitragDi, Mai 24, 2011 18:51
Antworten mit Zitat
Benutzer-Profile anzeigen
Das Bild wird von oben links nach unten rechts durchsucht. Gefundene Rechtecke werden mittels Flood-Fill transparent ausgemalt und dann ignoriert. Somit ist ein gefundener nicht-transparenter Pixel immer die linke obere Ecke eines Rechtecks.
Der weiße Hintergrund wird mitgezählt.
BlitzMax: [AUSKLAPPEN] 
SuperStrict

Framework brl.blitz
Import brl.pixmap
Import brl.pngloader

Const COLOR_CHECKED:Int = $00ffffff

Local map:TPixmap = LoadPixmap("squares.png")
Local squarecount:Int = 0
Local rectcount:Int = 0


Local time:Int = MilliSecs()
For Local y:Int = 0 Until map.height
	For Local x:Int = 0 Until map.width
		Local col:Int = map.ReadPixel(x,y)
		If col = COLOR_CHECKED Then Continue
		Local rectwidth:Int = readwidth(map,x,y,col)
		Local rectheight:Int = readheight(map,x,y,col)
		floodfill(map,x,y,col,COLOR_CHECKED)
		If rectwidth = rectheight Then squarecount :+ 1 Else rectcount :+ 1
	Next
Next
time = MilliSecs() - time

WriteStdout squarecount+"~n"
WriteStdout rectcount+"~n"
WriteStdout time+"ms~n"
ReadStdin()


Function readwidth:Int(map:TPixmap,start_x:Int,start_y:Int,findcolor:Int)
	Local x:Int = start_x
	Local result:Int = 0
	While x < map.width
		Local col:Int = map.ReadPixel(x,start_y)
		If col = findcolor Then result :+ 1
		x :+ 1
	Wend
	Return result
EndFunction

Function readheight:Int(map:TPixmap,start_x:Int,start_y:Int,findcolor:Int)
	Local y:Int = start_y
	Local result:Int = 0
	While y < map.height
		Local col:Int = map.ReadPixel(start_x,y)
		If col = findcolor Then result :+ 1
		y :+ 1
	Wend
	Return result
EndFunction

Function floodfill(map:TPixmap,x:Int,y:Int,color_find:Int,color_replace:Int=COLOR_CHECKED)
	If map.ReadPixel(x,y) <> color_find Then Return
	map.WritePixel(x,y,color_replace)
	If x > 0 Then floodfill(map,x-1,y,color_find,color_replace)
	If x < map.width-1 Then floodfill(map,x+1,y,color_find,color_replace)
	If y > 0 Then floodfill(map,x,y-1,color_find,color_replace)
	If y < map.height-1 Then floodfill(map,x,y+1,color_find,color_replace)
EndFunction
So long and thanks for all the fish.
Fedora 17 | Windows 7 || BlitzPlus | BlitzMax
Rechtschreibflame GO!!! Deppenapostroph | SeidSeit | Deppenakzent | DassDas | Deppenleerzeichen | TodTot | enzigste.info - Ja, ich sammel die.

Sir Gauss der III

 BeitragDi, Mai 24, 2011 21:13
Antworten mit Zitat
Benutzer-Profile anzeigen
Hab zwei Programme gemacht. Das längere einfach mal um die Aufgabe möglichst schnell zu lösen. Ansonsten so Einfach wie möglich

Code: [AUSKLAPPEN]
Graphics 800,600,32,2
Dim feld(805,605)
Global quadrat
Global rechteck
Global bild
Global dauer
Global b,l,fx,fy

bild=LoadImage("BlitzQuiz-Quadrate.png")
DrawImage bild,0,0
LockBuffer FrontBuffer()

Color 255,255,255
dauer=MilliSecs()


For y=1 To 600
   For x=1 To 800
      If feld(x,y)=0 Then
         feld(x,y)=ReadPixelFast(x-1,y-1)
         If feld(x-1,y)<>feld(x,y) Then
            If feld(x,y)<>-1 Then
               If feld(x,y-1)<>feld(x,y) Then
                  l=0
                  b=0
                  While feld(x,y)=feld(x+l,y)
                     l=l+1
                     feld(x+l,y)=ReadPixelFast(x+l-1,y-1)
                  Wend
                  While feld(x,y)=feld(x,y+b)
                     b=b+1
                     feld(x+l-1,y+b-1)=feld(x,y)
                     feld(x,y+b)=ReadPixelFast(x-1,y+b-1)
                  Wend
                  rechteck=rechteck+1
                  If b=l Then   quadrat=quadrat+1
               EndIf
            EndIf
         EndIf
      EndIf
   Next
Next
UnlockBuffer FrontBuffer()
dauer=MilliSecs()-dauer
Cls
Text 100,100,"ermitelte Quadrate: "+quadrat
n=rechteck-quadrat
Text 100,130,"ermitelte nicht-quadratische Rechtecke: "+n
Text 100,160,"ermitelte Rechtecke: "+rechteck
Text 100,190,"benötigte Zeit in Millisecs: "+dauer
WaitKey()
End


Code: [AUSKLAPPEN]
dauerges=MilliSecs()
Graphics 800,600,32,2
Dim feld(805,605)
Global quadrat
Global rechteck
Global bild
Global b,l,fx,fy

bild=LoadImage("BlitzQuiz-Quadrate.png")

DrawImage bild,0,0

LockBuffer FrontBuffer()

dauer=MilliSecs()

runde=0

For y=0 To 599
   runde=1-runde
   For x=0+(runde*2) To 799 Step 4
      If feld(x,y)>=0 Then
         n=feld(x,y)*-1
         feld(x,y)=ReadPixelFast(x,y)
         If feld(x,y)<>n Then
            If feld(x,y)<-1 Then
               fx=x
               fy=y
               l=0
               b=0
               Repeat
                  fx=fx-1
                  If feld(fx,y)=feld(x,y) Then
                     l=5
                  Else
                     feld(fx,y)=ReadPixelFast(fx,y)
                     l=l+1
                  EndIf
               Until feld(fx,y)<>feld(x,y) Or l>4
               If l<=4 Then
                  fx=fx+1
                  Repeat
                     fy=fy-1
                     If feld(x,fy)=feld(x,y) Then
                        b=5
                     Else
                        feld(fx,fy)=ReadPixelFast(fx,fy)
                        b=b+1
                     EndIf
                  Until feld(fx,fy)<>feld(x,y) Or b>2
                  If b<=2 Then
                     fy=fy+1
                     l=0
                     Repeat
                        l=l+1
                        feld(fx+l,fy)=ReadPixelFast(fx+l,fy)
                     Until feld(fx+l,fy)<>feld(x,y)
                     b=0
                     Repeat
                        b=b+1
                        feld(fx,fy+b)=ReadPixelFast(fx,fy+b)
                     Until feld(fx,fy+b)<>feld(x,y)
                     
                     For n=1 To l-1
                        For a=1 To b-1
                           feld(fx+n,fy+a)=feld(x,y)*-1
                        Next
                     Next
                     rechteck=rechteck+1
                     If l=b Then quadrat=quadrat+1
                  EndIf
               EndIf
               
            EndIf
            
         EndIf
         
      EndIf
   Next
Next

UnlockBuffer FrontBuffer()
dauer=MilliSecs()-dauer

Cls
Text 100,100,"ermitelte Quadrate:                      "+quadrat
n=rechteck-quadrat
Text 100,130,"ermitelte nicht-quadratische Rechtecke:  "+n
Text 100,160,"ermitelte Rechtecke:                     "+rechteck
Text 100,190,"benötigte Zeit für Prüfung in Millisecs: "+dauer
dauerges=MilliSecs()-dauerges
Text 100,220,"gesammte Programmdauer in Millisecs:     "+dauerges
WaitKey()
End

Noobody

 BeitragDi, Mai 24, 2011 23:28
Antworten mit Zitat
Benutzer-Profile anzeigen
Hier mein Code. Die Zeiger sind nur da, um den Overhead von ReadPixel zu vermeiden.

BlitzMax: [AUSKLAPPEN] 
SuperStrict

Local Pixmap:TPixmap = LoadPixmap("BlitzQuiz-Quadrate.png")

Local Timer:Int = MilliSecs()
Print CountSquares(Pixmap)
Print MilliSecs() - Timer

Function CountSquares:Int(Pixmap:TPixmap)
	Assert (Pixmap.Pitch Mod 4) = 0, "This should never happen"
	Assert Pixmap.Format = PF_RGBA8888, "Please make sure to save the image with alpha channel kthxbye"
	
	Local Pitch:Int = Pixmap.Pitch/4
	Local CurrPtr:Int Ptr = Int Ptr Pixmap.PixelPtr(0, 1)
	Local BGColor:Int = CurrPtr[0]
	
	Local SquareCount:Int
	
	For Local Y:Int = 1 Until Pixmap.Height
		Local CurrBGColor:Int = BGColor
		Local LastHeight:Int, LastColorChange:Int
		
		For Local X:Int = 1 Until Pixmap.Width
			If CurrPtr[X] <> CurrBGColor Then
				If X - LastColorChange = LastHeight Then SquareCount :+ 1
				
				CurrBGColor = CurrPtr[X]
				LastHeight = 0
				
				If CurrPtr[X - Pitch] <> CurrPtr[X] Then
					LastColorChange = X
					While Y + LastHeight < Pixmap.Height And CurrPtr[LastHeight*Pitch + X] = CurrBGColor
						LastHeight :+ 1
					Wend
				EndIf
			EndIf
		Next
		
		CurrPtr :+ Pitch
	Next
	
	Return SquareCount
End Function
Man is the best computer we can put aboard a spacecraft ... and the only one that can be mass produced with unskilled labor. -- Wernher von Braun

BlitzMoritz

Betreff: NEUES BLITZQUIZ: "Kreuzworträtsel"

 BeitragFr, Mai 27, 2011 11:19
Antworten mit Zitat
Benutzer-Profile anzeigen
(Das hier war das dritte BlitzQuiz-Rätsel:)

Es war einmal ein Kreuzworträtsel aus 9 x 6 Feldern, aus dem die folgenden Wörter "herausgepurzelt" sind:

"AIDA", "BARRIERE", "FERNE", "FIT", "KABINE", "KARTOFFEL", "LEUTE", "NASS", "NEREUS", "NUT", "OESE", "RADAR", "STRASS", "TOR", "TREU", "VERS"

Wie hatte das ursprüngliche Kreuzworträtsel ausgesehen?

Erläuterung:
Entwickelt ein Programm, welches das Kreuzworträtsel in der geforderten Größe aus den vorgegebenen Wörtern wieder zusammensetzt.
Es gelten die üblichen Kreuzworträtselgesetze:
Jedes Wort wird entweder von Links nach Rechts oder von Oben nach Unten geschrieben. Außerdem liegt unmittelbar VOR und HINTER jedem Wort entweder ein freies Feld oder der Rand des Kreuzworträtsels.

Alternativ-Beispiel:
Die Wörter "ABNEHMEN", "ANNO", "BOES", "DONNER", "FERNSEHER", "GEHABE", "HARKE", "IN", "KESS", "LABOR", "LERNEN", "MUH", "NIETE", "TELE", "UTE", "ZAEH" passen wie folgt in ein 9 x 6 Felder großes Kreuzworträtsel:

user posted image

Viel Spaß! Und nicht entmutigen lassen, wenn die Lösung einige Zeit braucht - Hauptsache, sie wird gefunden! Very Happy
Die Auflösung erfolgt wieder in einer Woche am Freitag, den 03.Juni.
  • Zuletzt bearbeitet von BlitzMoritz am Mo, Jun 06, 2011 8:51, insgesamt einmal bearbeitet

grafe

 BeitragFr, Mai 27, 2011 16:26
Antworten mit Zitat
Benutzer-Profile anzeigen
hui, eine schöne (und schwierige ^^) Aufgabe.
Ich werds auf jeden fall versuchen Very Happy

mfg grafe

Noobody

 BeitragSa, Mai 28, 2011 0:51
Antworten mit Zitat
Benutzer-Profile anzeigen
Mit simplem Backtracking ist es zwar relativ leicht gelöst, aber die Rechenzeit ist selbst für so ein kleines Kreuzworträtsel erstaunlich hoch Confused Mal sehen, ob das irgendwie schneller geht,
Man is the best computer we can put aboard a spacecraft ... and the only one that can be mass produced with unskilled labor. -- Wernher von Braun

BlitzMoritz

Betreff: Kreuzworträtsel-Auflösung

 BeitragFr, Jun 03, 2011 9:34
Antworten mit Zitat
Benutzer-Profile anzeigen
---------------------- Auflösung des dritten BlitzQuiz' "Kreuzworträtsel" ----------------------

Die Worte "AIDA", "BARRIERE", "FERNE", "FIT", "KABINE", "KARTOFFEL", "LEUTE", "NASS", "NEREUS", "NUT", "OESE", "RADAR", "STRASS", "TOR", "TREU", "VERS"
ließen sich zu folgendem 9 x 6 Felder großen Kreuzworträtsel zusammensetzen:

user posted image

Lösungscode:
BlitzMax: [AUSKLAPPEN] 
SuperStrict
'Man spart sehr viel Rechenzeit (ca. 75 %), wenn man die Wörter der Größe nach "per Hand" vorsortiert:
Global Wort$[] = [" KARTOFFEL ", " BARRIERE ", " KABINE ", " NEREUS ", " STRASS ", " RADAR ", " FERNE ", " LEUTE ", " OESE ", " NASS ", " TREU ", " VERS ", " AIDA ", " FIT ", " NUT ", " TOR "]
Global WortAnzahlMinusOne@ = Len(Wort)-1
'Jedes Wort wurde vorn und hinten mit einem zusätzlichen freien Platz versehen, um zu verhindern, dass sich dort andere Worte platzieren.
Const Spalten% = 9+2 '(jeweils zwei "zuviel", um die Leerzeichen VOR und NACH jedem Wort aufzufangen)
Const Reihen% = 6+2
Const SpaltenMinusOne% = 9+1
Const ReihenMinusOne% = 6+1
Graphics Spalten * 13 + 3, Reihen * 13 + 3
Global Array@[Spalten, Reihen], Time% = MilliSecs()
Global Crossword:TCrossword[Len(Wort)]
For Local w% = 0 Until Len(Wort)
	Crossword[w] = TCrossword.Create(Wort[w])
Next

Type TCrossword	 'dient dem schnelleren Bytevergleich statt andauernd mit "Mid(,,)" etc. herumzugurken.
	Field CountLetter@, ASCII@[], CountLetterMinusOne@
	Function Create:TCrossword(text$)
		Local NewCrossword:TCrossword = New TCrossword
		NewCrossword.CountLetter = Len(text)
		NewCrossword.CountLetterMinusOne = NewCrossword.CountLetter-1
		NewCrossword.ASCII = New Byte[NewCrossword.CountLetter]
		For Local l% = 0 Until NewCrossword.CountLetter
			NewCrossword.ASCII[l] = Asc(Mid(text, l+1, 1))
		Next
		Return NewCrossword
	End Function
End Type

Fillin()

Function Fillin@(Index% = 0)
	Local Erfolg@ = False
	Local i% = 0
	While i + Crossword[Index].CountLetter =< Spalten
		For Local j% = 1 Until ReihenMinusOne
			Local NewFilled@[] = FillArrayHorizontal(Index, i, j)
			If NewFilled <> Null Then

				If Index < WortAnzahlMinusOne Then
					Erfolg = Fillin(Index+1)
					If Erfolg = False Then
						For Local l% = 0 Until Len(NewFilled)
							If NewFilled[l] = True Then Array[i+l,j] = 0
						Next
					Else
						Return True
					End If
				Else
					Print "Rechendauer: " + (MilliSecs()-Time) + " Millisekunden"
					For Local r% = 0 Until ReihenMinusOne
						For Local s% = 0 Until SpaltenMinusOne
							DrawText Chr(Array[s,r]), s*13 + 3, r*13 + 2
						Next
					Next
					Flip
					WaitKey()
					End
					
				End If
			End If
			
		Next
		i:+1
	Wend
	Local j% = 0
	While j + Crossword[Index].CountLetter =< Reihen
		For Local i% = 1 Until SpaltenMinusOne
			Local NewFilled@[] = FillArrayVertikal(Index, i, j)
			If NewFilled <> Null Then
				If Index < WortAnzahlMinusOne Then
					Erfolg = Fillin(Index+1)
					If Erfolg = False Then
						For Local l% = 0 Until Len(NewFilled)
							If NewFilled[l] = True Then Array[i,j+l] = 0
						Next
					Else
						Return True
					End If
				Else
					Print "Rechendauer: " + (MilliSecs()-Time) + " Millisekunden"
					For Local r% = 0 Until ReihenMinusOne
						For Local s% = 0 Until SpaltenMinusOne
							DrawText Chr(Array[s,r]), s*13 + 3, r*13 + 2
						Next
					Next
					Flip
					WaitKey()
					End
					
				End If
			End If
		Next
		j:+1
	Wend
	Return Erfolg
End Function

Function FillArrayHorizontal@[](Index%, x%, y%)

	Local NewFilled@[Crossword[Index].CountLetter]
	For Local l% = 0 Until Crossword[Index].CountLetter
		If Array[x+l,y] <> Crossword[Index].ASCII[l] Then
			If Array[x+l,y] = 0 Then
				Array[x+l,y] = Crossword[Index].ASCII[l]
				NewFilled[l] = True
			Else
				Repeat
					If NewFilled[l] = True Then Array[x+l,y] = 0
					l:-1
				Until l < 0
				Return Null
			End If
		End If
	Next
	Return NewFilled
End Function

Function FillArrayVertikal@[](Index%, x%, y%)

	Local NewFilled@[Crossword[Index].CountLetter]
	For Local l% = 0 Until Crossword[Index].CountLetter
		If Array[x,y+l] <> Crossword[Index].ASCII[l] Then
			If Array[x,y+l] = 0 Then
				Array[x,y+l] = Crossword[Index].ASCII[l]
				NewFilled[l] = True
			Else
				Repeat
					If NewFilled[l] = True Then Array[x,y+l] = 0
					l:-1
				Until l < 0
				Return Null
			End If
		End If
	Next
	Return NewFilled
End Function
  • Zuletzt bearbeitet von BlitzMoritz am Do, Jun 16, 2011 20:03, insgesamt einmal bearbeitet

SpionAtom

 BeitragSa, Jun 04, 2011 15:57
Antworten mit Zitat
Benutzer-Profile anzeigen
Total unoptimiert, aber es sind MEINE unoptimierten 300 Zeilen*!

*Sind natürlich weitaus weniger als 300 Zeilen, wenn man die ganzen Leerzeilen und Kommentare abzieht

BlitzBasic: [AUSKLAPPEN] 
;------------------------------------------------------------------------------;
;	BLITZ MORITZ sein Blitz-Quiz vom Mai 27, 2011                              ;
;                                                                              ;
;	eine Lösung von SpionAtom (begonnen 28.5.2o11)                             ;
;------------------------------------------------------------------------------;



;------------------------------------------------------------------------------;
;	EINGABEN                                                                   ;
;------------------------------------------------------------------------------;
	
	Const breite = 9
	Const hoehe = 6
	Const wort_max_zahl = 16
	.WORTLISTE
	Data "KARTOFFEL", "BARRIERE", "KABINE", "STRASS", "NEREUS", "FERNE", "LEUTE", "RADAR", "AIDA", "NASS", "NUT", "OESE", "TOR", "TREU", "VERS", "FIT" 
	;Data "FERNSEHER", "ABNEHMEN", "DONNER", "LERNEN", "GEHABE", "HARKE", "LABOR", "NIETE", "ANNO", "BOES", "KESS", "MUH", "TELE", "UTE", "ZAEH", "IN"
	Const fg = 50
	Const delim$ = "-"
	
	
	
;------------------------------------------------------------------------------;
;	DATEN EINLESEN                                                             ;
; Wörter werden hier eingelesen und in eine Type-Liste eingetragen.            ;
;------------------------------------------------------------------------------;

	Global wort$[wort_max_zahl]
	max_laenge = breite: If max_laenge < hoehe Then max_laenge = hoehe
	Restore WORTLISTE
	Type Liste
		Field wort
		Field position
		Field vor_delim, nach_delim
	End Type
	Global liste.Liste
	For i = 0 To wort_max_zahl - 1
		Read  w$
		wort[i] = Left(w$, max_laenge)
		liste = New Liste
		liste\wort = i
		liste\position = -1 ;Position geht von 0 bis (2 * breite * hoehe) - 1. Die Feldposition ist int(position / 2), die Ausrichtung ist position mod 2
	Next
	

	

	Dim BFeld$(breite, hoehe)
	
	Graphics breite * fg, hoehe * fg, 0, 2
	Global bgcolor = 255
	ClsColor bgcolor, bgcolor, bgcolor

	Global pic_bg = CreateImage(fg * breite, fg * hoehe)
	SetBuffer ImageBuffer(pic_bg)
	Cls
	Color 127, 127, 127
	For i = 0 To breite - 1
	For j = 0 To hoehe - 1
		Rect i * fg, j * fg, fg, fg, 0
	Next
	Next


	SetBuffer BackBuffer()
	Global aktuellesWort.Liste = First Liste


Function positionFinden()
	
	While (aktuellesWort\position < 2 * breite * hoehe)
		If wortPasst() Then
			Return True
		End If
		aktuellesWort\position = aktuellesWort\position + 1
	Wend
	Return False

End Function
	
	
	Global tiefe = 0
	zaehler = 0

	Repeat
	
		wortEingetragen = positionFinden()
		If wortEingetragen Then
			
			;Lösung gefunden, wenn das letzte Wort der Liste eingetragen wurde
			If aktuellesWort = Last Liste Then
				Ausgabe()
				Color 0, 255, 0
				Text 0, 0, "Fertig... keine Lust auf weitersuchen... [esc]"
				Flip()
				Repeat
				Until KeyDown(1)
				End
			End If
			
			;Nächstes Wort prüfen
			aktuellesWort = After aktuellesWort
			aktuellesWort\position = 0
			tiefe = tiefe + 1
			
		Else

			;Keine Lösung gefunden, wenn erstes Wort der Liste nicht eingetragen werden kann
			If aktuellesWort = First Liste Then
				Ausgabe()
				Color 255, 0, 0
				Text 0, 0, "keine Lösung gefunden... [esc]"
				Flip()
				Repeat
				Until KeyDown(1)
				End
			End If
			
			;Vorheriges Wort prüfen
			aktuellesWort = Before aktuellesWort
			
			feld = Int(aktuellesWort\position / 2)
			ausrichtung = aktuellesWort\position Mod 2
			x = feld Mod breite
			y = feld / breite			
			wort_Eintragen(False, x, y, ausrichtung)
			aktuellesWort\position = aktuellesWort\position + 1
			tiefe = tiefe - 1
			
		End If
	
			If aktuellesWort\wort = wort_max_zahl / 7 Then
				Ausgabe()
			End If

	
	Until KeyDown(1)
	WaitKey
	End

Function wortPasst()

		feld = Int(aktuellesWort\position / 2)
		ausrichtung = aktuellesWort\position Mod 2
		x = feld Mod breite
		y = feld / breite
		w$ = wort[aktuellesWort\wort]
		l = Len(w)
		
		aktuellesWort\vor_delim = False
		aktuellesWort\nach_delim = False
		
		DebugLog("passt? " + wort[aktuellesWort\wort] + ", " + x + ", " + y + ", ausrichtung: " + ausrichtung)
		
		If ausrichtung = 0 Then ;horizontale Ausrichtung
		
			If x + l > breite Then Return False ;Wort ragt nacht rechts raus
			If x > 0 Then ;Prüfe, ob linker Nachbar entweder frei oder delimiter ist, falls nicht, geh raus
				aktuellesWort\vor_delim = True
				rb$ = Right(BFeld(x - 1, y), 1)
				If rb <> "" Then
					If rb <> delim Then Return False
				End If
			End If
			
			If x + l < breite Then ;Prüfe, ob rechter Nachbar entweder frei oder delimiter ist, falls nicht, geh raus
				aktuellesWort\nach_delim = True
				rb$ = Right(BFeld(x + l, y), 1)
				If rb <> "" Then
					If rb <> delim Then Return False
				End If
			End If
			
			;Prüfe alle Zeichen des Wortes
			For i = 0 To l - 1
				rb$ = Right(BFeld(x + i, y), 1)
				If rb <> "" Then ;Prüfe, ob das Feld dem Zeichen entspricht oder leer ist
					If rb <> Mid(w, i + 1, 1) Then Return False
				End If
			Next
			
			wort_Eintragen(True, x, y, ausrichtung)
			Return True
		
		End If
		

		If ausrichtung = 1 Then ;vertikale Ausrichtung
			
			If y + l > hoehe Then Return False ;Wort ragt nacht unten raus
			
			If y > 0 Then ;Prüfe, ob oberer Nachbar entweder frei oder delimiter ist, falls nicht, geh raus
				rb$ = Right(BFeld(x, y - 1), 1)
				If rb <> "" Then
					If rb <> delim Then Return False Else aktuellesWort\vor_delim = True
				End If
			End If
			
			
			
			If y + l < hoehe Then ;Prüfe, ob unterer Nachbar entweder frei oder delimiter ist, falls nicht, geh raus
				rb$ = Right(BFeld(x, y + l), 1)
				If rb <> "" Then
					If rb <> delim Then Return False Else aktuellesWort\nach_delim = True
				End If
			End If
			
			
			
			;Prüfe alle Zeichen des Wortes
			For i = 0 To l - 1
				rb$ = Right(BFeld(x, y + i), 1)
				If rb <> "" Then ;Prüfe, ob das Feld dem Zeichen entspricht oder leer ist
					If rb <> Mid(w, i + 1, 1) Then Return False
				End If
			Next
			
			wort_Eintragen(True, x, y, ausrichtung)
			Return True
		
		End If	

End Function

Function wort_Eintragen(eintragen, x, y, ausrichtung)


		w$ = wort[aktuellesWort\wort]
		l = Len(w)
		
		If ausrichtung = 0 Then ;Horizontal eintragen
		
			For i = 0 To l - 1
				rb$ = Mid(w, i + 1, 1)
				zeichenEintragen(rb, x + i, y, eintragen)
			Next
			;delimiter eintragen
			If aktuellesWort\vor_delim Then
				zeichenEintragen(delim, x - 1, y, eintragen)
			End If
			If aktuellesWort\nach_delim Then
				zeichenEintragen(delim, x + l, y, eintragen)
			End If
		
		End If
		
		If ausrichtung = 1 Then ;Vertikal eintragen
		
			For i = 0 To l - 1
				rb$ = Mid(w, i + 1, 1)
				zeichenEintragen(rb, x, y + i, eintragen)
			Next
			;delimiter eintragen
			If aktuellesWort\vor_delim Then
				zeichenEintragen(delim, x, y - 1, eintragen)
			End If
			If aktuellesWort\nach_delim Then
				zeichenEintragen(delim, x, y + 1, eintragen)
			End If
			
		End If
		
		
		

End Function


Function zeichenEintragen(z$, x, y, eintragen)
	
	If eintragen Then
		BFeld(x, y) = BFeld(x, y) + z
	Else
		If Len(BFeld(x, y)) > 1 Then
			BFeld(x, y) = Left(BFeld(x, y), Len(BFeld(x, y)) - 1)
		Else
			BFeld(x, y) = ""
		End If
	End If

End Function

Function Ausgabe()

	DrawBlock pic_bg, 0, 0
	
	For ausgabeWort.Liste = Each Liste
		If ausgabeWort\position > -1 Then
			feld = Int(ausgabeWort\position / 2)
			ausrichtung = ausgabeWort\position Mod 2
			x = feld Mod breite
			y = feld / breite
			w$ = wort[ausgabeWort\wort]
			l = Len(w)
		
			Color 0, 0, 0
		
		
			If ausrichtung = 0 Then
				For i = 0 To l - 1
					z$ = Mid(w, i + 1, 1)
					Text (x + i) * fg + (fg - StringWidth(z)) / 2, y * fg + (fg - StringHeight(z)) / 2, z
				Next
			Else
				For i = 0 To l - 1
					z$ = Mid(w, i + 1, 1)
					Text x * fg + (fg - StringWidth(z) )/ 2, (y + i) * fg + (fg - StringHeight(z)) / 2, z
				Next
			End If
		
		End If
		
	Next


	Flip(0)


End Function
os: Windows 10 Home cpu: Intel Core i7 6700K 4.00Ghz gpu: NVIDIA GeForce GTX 1080

Lobby

 BeitragSa, Jun 04, 2011 16:12
Antworten mit Zitat
Benutzer-Profile anzeigen
Noch mein Senf. Fertig in eine Engine Verpackt, daher aber auch leider kein schönes Zugucken bei der Lösungsfindung.

BlitzMax: [AUSKLAPPEN] 
SuperStrict
Framework brl.standardio

Local crossword:TCrossword = New TCrossword
crossword.addWord("AIDA")
crossword.addWord("BARRIERE")
crossword.addWord("FERNE")
crossword.addWord("FIT")
crossword.addWord("KABINE")
crossword.addWord("KARTOFFEL")
crossword.addWord("LEUTE")
crossword.addWord("NASS")
crossword.addWord("NEREUS")
crossword.addWord("NUT")
crossword.addWord("OESE")
crossword.addWord("RADAR")
crossword.addWord("STRASS")
crossword.addWord("TOR")
crossword.addWord("TREU")
crossword.addWord("VERS")
crossword.setWidth(9)
crossword.setHeight(6)
crossword.setCallbackFunc(callback)

Print "Suche gestartet..."
crossword.performSearch()
Print "Suche abgeschlossen, " + crossword.countResults() + " Ergebnis(se) gefunden."

Function callback:Int(Result:String[,], blackList:Int[,], obj:Object)
	printResult(Result)	'Print found result
	Print ""
	Return(True)	'Continue the search
End Function

Function printResult(Result:String[,])
	For Local y:Int = 0 Until Result.Dimensions()[1]
		Local line:String = ""
		For Local x:Int = 0 Until Result.Dimensions()[0]
			line:+Result[x, y] + ", "
		Next
		line = ("[" + line + "]").Replace(", ]", "]").Replace(", ,", ",  ,").Replace(", ,", ",  ,").Replace("[,", "[ ,").Replace(", ]", ",  ]")
		Print line
	Next
End Function




Type TCrossword
	Const _align_horizontal:Int = 0
	Const _align_vertical:Int = 1
	Field _words:String[]
	Field _width:Int
	Field _height:Int
	Field _callback:Int(Result:String[,], blacklist:Int[,], obj:Object)
	Field _callbackObj:Object
	Field _Result:String[,][]
	Field _blacklist:Int[,][]
	
	Method setWords(words:String[])
		Self._words = words
	End Method
	Method addWord(word:String)
		Self._words:+[word]
	End Method
	Method clearWords()
		Self._words = Null
	End Method
	Method getWords:String[] ()
		Return(Self._words)
	End Method
	Method setWidth(w:Int)
		Self._width = w
	End Method
	Method setHeight(h:Int)
		Self._height = h
	End Method
	Method getWidth:Int()
		Return(Self._width)
	End Method
	Method getHeight:Int()
		Return(Self._height)
	End Method
	Method setCallbackFunc(func:Int(Result:String[,], blacklist:Int[,], obj:Object), funcObj:Object = Null)
		Self._callback = func
		Self._callbackObj = funcObj
	End Method
	Method performSearch()
		Local Result:String[,] = New String[Self._width, Self._height]
		Local blacklist:Int[,] = New Int[Self._width, Self._height]
		Self._Result = Null
		Self._blacklist = Null
		If Self._callback Then
			Self._formResult(Self._words, Result, blacklist, Self._callback, Self._callbackObj)
		Else
			Self._formResult(Self._words, Result, blacklist, Self._emptyFunc, Self)
		End If
	End Method
	Method countResults:Int()
		Return(Self._Result.Length)
	End Method
	Method getResult:String[,] (idx:Int)
		Return(Self._Result[idx])
	End Method
	
	Function _emptyFunc:Int(Result:String[,], blacklist:Int[,], obj:Object)
		Return(True)
	End Function
	Method _addResult:Int(Result:String[,], blacklist:Int[,])
		Self._Result:+[Result]
		Self._blacklist:+[blacklist]
		Return(True)
	End Method
	Method _formResult:Int(words:String[], Result:String[,] Var, blackList:Int[,] Var, successCallback:Int(Result:String[,], blackList:Int[,], successObj:Object), successObj:Object)
		Local myWord:String = words[0]
		Local restWords:String[] = words[1..]
		For Local x:Int = 0 To Self._width - myWord.Length
			For Local y:Int = 0 Until Self._height
				If Self._insertWordPossible(myWord, x, y, Self._align_horizontal, Result, blackList) Then
					Local newResult:String[,] = Self._copyResult(Result)
					Local newBlackList:Int[,] = Self._copyBlackList(blackList)
					Self._insertWord(myWord, x, y, Self._align_horizontal, newResult, newBlackList)
					If restWords.Length > 0 Then
						If Not Self._formResult(restWords, newResult, newBlackList, successCallback, successObj) Then
							Return(False)
						End If
					Else
						Self._addResult(newResult, newBlackList)
						If Not successCallback(newResult, newBlackList, successObj) Then
							Return(False)
						End If
					End If
				End If
			Next
		Next
		For Local x:Int = 0 Until Self._width
			For Local y:Int = 0 To Self._height - myWord.Length
				If Self._insertWordPossible(myWord, x, y, Self._align_vertical, Result, blackList) Then
					Local newResult:String[,] = Self._copyResult(Result)
					Local newBlackList:Int[,] = Self._copyBlackList(blackList)
					Self._insertWord(myWord, x, y, Self._align_vertical, newResult, newBlackList)
					If restWords.Length > 0 Then
						If Not Self._formResult(restWords, newResult, newBlackList, successCallback, successObj) Then
							Return(False)
						End If
					Else
						Self._addResult(newResult, newBlackList)
						If Not successCallback(newResult, newBlackList, successObj) Then
							Return(False)
						End If
					End If
				End If
			Next
		Next
		Return(True)
	End Method
	Method _insertWord(word:String, x:Int, y:Int, align:Int, Result:String[,], blackList:Int[,])
		Select align
			Case Self._align_horizontal
				For Local i:Int = 0 Until word.Length
					Result[x + i, y] = Chr(word[i])
				Next
				If x - 1 >= 0 Then blackList[x - 1, y] = 1
				If x + word.Length < Self._width Then blackList[x + word.Length, y] = 1
			Case Self._align_vertical
				For Local i:Int = 0 Until word.Length
					Result[x, y + i] = Chr(word[i])
				Next
				If y - 1 >= 0 Then blackList[x, y - 1] = 1
				If y + word.Length < Self._height Then blackList[x, y + word.Length] = 1
		End Select
	End Method
	Method _insertWordPossible:Int(word:String, x:Int, y:Int, align:Int, Result:String[,], blackList:Int[,])
		Select align
			Case Self._align_horizontal
				For Local i:Int = 0 Until word.Length
					If blackList[x + i, y] Then
						Return(False)
					ElseIf Result[x + i, y] <> "" And Result[x + i, y] <> Chr(word[i]) Then
						Return(False)
					End If
				Next
			Case Self._align_vertical
				For Local i:Int = 0 Until word.Length
					If blackList[x, y + i] Then
						Return(False)
					ElseIf Result[x, y + i] <> "" And Result[x, y + i] <> Chr(word[i]) Then
						Return(False)
					End If
				Next
		End Select
		Return(True)
	End Method
	Method _copyResult:String[,] (Result:String[,])
		Local newResult:String[,] = New String[Self._width, Self._height]
		For Local y:Int = 0 Until Self._height
			For Local x:Int = 0 Until Self._width
				newResult[x, y] = Result[x, y]
			Next
		Next
		Return(newResult)
	End Method
	Method _copyBlackList:Int[,] (blackList:Int[,])
		Local newBlackList:Int[,] = New Int[Self._width, Self._height]
		For Local y:Int = 0 Until Self._height
			For Local x:Int = 0 Until Self._width
				newBlackList[x, y] = blackList[x, y]
			Next
		Next
		Return(newBlackList)
	End Method
End Type
TheoTown - Eine Stadtaufbausimulation für Android, iOS, Windows, Mac OS und Linux

BlitzMoritz

Betreff: 4.BlitzQuiz

 BeitragMo, Jun 06, 2011 8:47
Antworten mit Zitat
Benutzer-Profile anzeigen
Ich danke allen bisherigen Interessenten für ihre Teilnahme und möchte das nächste kleine Rätsel stellen, diesmal etwas leichter bzw. weniger umfangreich, so dass es wohl v.a. auf die Schnelligkeit ankommen soll:
---------------------------------------------------------------------------------------------------------------
(Das hier war das vierte BlitzQuiz:)
Wie lauten die größten Integer-Primzahlzwillinge,
die keine geraden Ziffern enthalten?

Hilfestellung:
Zwischen 1 und 100 liegen die folgenden ersten 25 Primzahlen:
2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97
Primzahlzwillinge sind Primzahlen, welche die Differenz von 2 haben, also gewissermaßen "engst möglich benachbart sind", z.B. 59 und 61. Wie man in obiger Liste ablesen kann, sind 71 und 73 die größten Primzahlzwillinge unter 100, welche obendrein keine geraden Ziffern enthalten. (Natürlich zählt auch die Null als gerade Ziffer)

In genau einer Woche, also am Montag, den 13.Juni, wird die Lösung veröffentlicht und können die Lösungscodes verglichen werden. Ich wünsche gutes Gelingen!
  • Zuletzt bearbeitet von BlitzMoritz am Do, Jun 16, 2011 20:04, insgesamt 2-mal bearbeitet

BlitzMoritz

Betreff: Auflösung 4.) "Zwillinge"

 BeitragMo, Jun 13, 2011 13:09
Antworten mit Zitat
Benutzer-Profile anzeigen
Hier erfolgt die Auflösung des 4.BlitzQuiz "Zwillinge":
--------------------------------------------------

Die größten Integer-Primzahlzwillinge ohne gerade Ziffern lauten
1999995911 und 1999995913

Der Lösungscode sieht vielleicht etwas komisch aus, sollte aber ziemlich ökonomisch vorgehen, um Zeit zu sparen:
Als erstes werden jene zehnstelligen Zahlen ausgesiebt, welche ganz Links eine 1, ganz Rechts eine 2 und dazwischen nur ungerade Ziffern haben. Warum rechts eine 2? Weil das Primzahlzwillingspaar nur die Endziffern 1 und 3 oder 7 und 9 haben kann. 9 und 1 ginge nicht, weil dann eine der Zehnerziffern gerade wäre.
Bei der Zahl mit der 2 ganz Rechts wird untersucht, ob sie durch 6 teilbar ist. Primzahlzwillinge umrahmen nämlich stets eine solche Zahl. Gehört sie zur erweiterten 6er-Reihe, dann auch notwendigerweise die gleiche Zahl mit einer 8 statt der 2 als Einerziffer. Ist dies also der Fall, wird zuletzt geprüft, ob die beiden in Frage kommenden Zahlenpaare Primzahlen sind oder nicht.

BlitzMax: [AUSKLAPPEN] 
Local Ziffer%[9], Zeit% = MilliSecs()
For Ziffer[1] = 9 To 1 Step -2
	For Ziffer[2] = 9 To 1 Step -2
		For Ziffer[3] = 9 To 1 Step -2
			For Ziffer[4] = 9 To 1 Step -2
				For Ziffer[5] = 9 To 1 Step -2
					For Ziffer[6] = 9 To 1 Step -2
						For Ziffer[7] = 9 To 1 Step -2
							For Ziffer[8] = 9 To 1 Step -2
								Local SechserZahl% = 1000000000 + Ziffer[1] * 100000000 + Ziffer[2] * 10000000 + Ziffer[3] * 1000000 + Ziffer[4] * 100000 + Ziffer[5] * 10000 + Ziffer[6] * 1000 + Ziffer[7] * 100 + Ziffer[8] * 10 + 2
								'Gucksdu Wikipedia: Alle Primzahlzwillinge schließen eine durch 6 teilbare Zahl ein:
								If SechserZahl Mod 6 = 0 Then
									If isPrime(SechserZahl-1) = True Then
										If isPrime(SechserZahl+1) = True Then
											Print "Nach " + (MilliSecs()-Zeit) + " Millisekunden steht fest:"
											Print (SechserZahl-1) + " und " + (SechserZahl+1) + " sind die größten Integer-Primzahlzwillinge ohne gerade Ziffern"
											End
										End If
									End If
									If isPrime(SechserZahl+5) = True Then
										If isPrime(SechserZahl+7) = True Then
											Print "Nach " + (MilliSecs()-Zeit) + " Millisekunden steht fest:"
											Print (SechserZahl-5) + " und " + (SechserZahl+6) + " sind die größten Integer-Primzahlzwillinge ohne gerade Ziffern"
											End
										End If
									End If
								End If
							Next
						Next
					Next	
				Next
			Next
		Next
	Next	
Next

Function isPrime@(integer%)
	Local last_i% = Sqr(integer)
	For Local i% = 3 To last_i Step 2
		If integer Mod i = 0 Then Return False
	Next
	Return True
End Function
  • Zuletzt bearbeitet von BlitzMoritz am Do, Jun 16, 2011 20:04, insgesamt einmal bearbeitet

BlitzMoritz

Betreff: 5.BlitzQuiz

 BeitragDo, Jun 16, 2011 20:02
Antworten mit Zitat
Benutzer-Profile anzeigen
Ich weiß ja nicht, ob mir die Mehrfach-Posts gestattet sind, aber wenn keiner mitmacht, gibt's eben nix dazwischen...

5.BlitzQuiz:
__________________
Wer bin ich?

user posted image

Anmerkung:
Erstellt ein Programm, welches obiges Puzzle automatisch richtig zusammenbaut.
Die Puzzleteile haben alle die gleiche Größe von 30 x 30 Pixeln und sind nicht gedreht.
Das verwendete Originalfoto ist so präpariert, dass entsprechende Lösungsansätze Erfolg versprechen sollten.

Viel Spaß Smile
  • Zuletzt bearbeitet von BlitzMoritz am Fr, Jun 24, 2011 20:31, insgesamt 2-mal bearbeitet

ToeB

 BeitragDo, Jun 16, 2011 22:17
Antworten mit Zitat
Benutzer-Profile anzeigen
Hab raus Very Happy

War ein wenig gefrickel und irgendwie werden die letzten Zeilen nicht mit gespeichert, aber die Lösung ist innerhalb von 168ms da (Komplett mit Abspeichern etc.)
Einlesen : 25ms
Sortieren : 142ms
Speichern : 1ms


Mal gucken ob ich den Bug noch weg bekomme ^^

mfg ToeB
Religiöse Kriege sind Streitigkeiten erwachsener Männer darum, wer den besten imaginären Freund hat.
Race-Project - Das Rennspiel der etwas anderen Art
SimpleUDP3.0 - Neuste Version der Netzwerk-Bibliothek
Vielen Dank an dieser Stelle nochmal an Pummelie, welcher mir einen Teil seines VServers für das Betreiben meines Masterservers zur verfügung stellt!

BlitzMoritz

Betreff: Auflösung 5.BlitzQuiz (Puzzle)

 BeitragFr, Jun 24, 2011 20:21
Antworten mit Zitat
Benutzer-Profile anzeigen
Auflösung des BlitzQuiz "Wer bin ich?"
----------------------------------------------------------
Es handelt sich um unseren Bundespräsidenten Christian Wulff.
Das Foto ist gemeinfrei und stammt aus dieser Wikipedia-Sammlung.

Zur Lösung:
Alle vier Ränder (bzw. deren Pixel-Farbwerte) jedes 30x30-Quadratteils werden entsprechend verglichen und sortiert, also zum Beispiel: Welches Quadrat ist mit der rechten Seite summa summarum am ähnlichsten mit der linken Seite welchen anderen Quadrates? Eine absolute Gleichheit ist natürlich nie da, aber ein statistisches Ranking sinnvoll.
Nach diesem Sortieren besitzt also jedes Quadrat vier potentiell "beste" Nachbarn. Die Schwierigkeit lag nun noch darin, zu beurteilen, wo ein echter Nachbar liegt oder eventuell DOCH gar kein Nachbar, sondern der Rand. Das wurde gelöst, indem jene (rechte untere) Ecke gesucht wurde, die in der zweifachen Summe einen eklatanten Unterschied zu den vermeintlichen Nachbarn besitzt. Alle Puzzleteile werden dann entsprechend verschoben gezeichnet:
BlitzMax: [AUSKLAPPEN] 
SuperStrict
Graphics 600,600
Const Size% = 30
Global Columns% =GraphicsWidth() / Size
Global Rows% = GraphicsHeight() / Size
Global Count% = Columns * Rows
Global Puzzle:TImage = LoadAnimImage("Puzzle.png", Size, Size, 0, Count)
Global Square:TSquare[Count]
For Local frame% = 0 Until Count
	Square[frame] = TSquare.Create(frame)
Next
Local CornerFrame% = SortFrames()
DrawSortedFrames(CornerFrame)
Flip
WaitKey()

'####################################################################

Function DrawSortedFrames(frame1%)
	Local x_start% = (Columns - 1) * Size
	Local y_start% = (Rows - 1) * Size
	For Local i% = 0 Until Columns
		Local frame2% = frame1
		For Local j% = 0 Until Rows
			Square[frame2].Draw(x_start - i * size, y_start - j * size)
			frame2 = Square[frame2].neighbour_frame[0]
		Next
		frame1 = Square[frame1].neighbour_frame[3]
	Next
End Function

'####################################################################

Function SortFrames%()

	'Fuer alle vier Seiten Nachbarn suchen:

	For Local frame% = 0 Until Count

		For Local side% = 0 To 3
			Local RGB_difference%, Min_RGB_difference_frame%, Min_RGB_difference% = 999999999
			For Local otherframe% = 0 Until Count
				RGB_difference = 0
				If otherframe <> frame Then
					Local otherside% = (side + 2) Mod 4
					For Local i% = 0 Until Size
						RGB_difference = RGB_difference + Abs(Square[frame].Red[side, i] - Square[otherframe].Red[otherside, i]) + Abs(Square[frame].Green[side, i] - Square[otherframe].Green[otherside, i]) + Abs(Square[frame].Blue[side, i] - Square[otherframe].Blue[otherside, i])
					Next
					If RGB_difference < Min_RGB_difference Then
						Min_RGB_difference = RGB_difference
						Min_RGB_difference_frame = otherframe
					End If
				End If
			Next
			Square[frame].neighbour_frame[side] = Min_RGB_difference_frame

		Next 'side
	
	Next 'frame
	
	'=======================
	'Rechten unteren Eckstein suchen:
	
	Local testframe%[Columns, Rows]
	Local frame1% = 0
	For Local i% = 0 Until Columns
		Local frame2% = frame1
		For Local j% = 0 Until Rows
			testframe[i,j] = frame2
			frame2 = Square[frame2].neighbour_frame[2]
		Next
		frame1 = Square[frame1].neighbour_frame[1]
	Next
	
	Local RightCorner% = -1
	For Local j% = 0 Until Rows
		For Local i% = 0 Until Columns
			If i = Columns-1 Or Square[testframe[i,j]].neighbour_frame[1] <> testframe[i+1,j] Or Square[testframe[i+1,j]].neighbour_frame[3] <> testframe[i,j] Then
				RightCorner = i
				Exit
			End If
		Next
		If RightCorner > -1 Then Exit
	Next
	
	Local DownCorner% = -1
	For Local i% = 0 Until Columns
		For Local j% = 0 Until Rows
			If j = Rows-1 Or Square[testframe[i,j]].neighbour_frame[2] <> testframe[i,j+1] Or Square[testframe[i,j+1]].neighbour_frame[0] <> testframe[i,j] Then
				DownCorner = j
				Exit
			End If
		Next
		If DownCorner > -1 Then Exit
	Next

	Return testframe[RightCorner, DownCorner]
	
End Function

'####################################################################

Type TSquare

	Field frame%, neighbour_frame%[4], column%, row%
	Field Red%[4, Size], Green%[4, Size], Blue%[4, Size]
	
	Function Create:TSquare(frame%)
		Local NewSquare:TSquare = New TSquare
		NewSquare.frame = frame
		Local Pixmap:TPixmap = LockImage(Puzzle, frame)
		Local ARGB%[4]
		For Local d% = 0 Until Size
			ARGB[0] = ReadPixel(Pixmap, d, 0)
			ARGB[1] = ReadPixel(Pixmap, Size - 1, d)
			ARGB[2] = ReadPixel(Pixmap, d, Size - 1)
			ARGB[3] = ReadPixel(Pixmap, 0, d)
			For Local e% = 0 To 3
				NewSquare.Red[e, d] = (ARGB[e] & $00FF0000:Int) / $10000:Int
				NewSquare.Green[e, d] = (ARGB[e] & $0000FF00:Int) / $100:Int
				NewSquare.Blue[e, d] = ARGB[e] & $000000FF:Int
			Next
		Next
		Return NewSquare
	End Function
	
	Method Draw(x%, y%)
		DrawImage Puzzle, x, y, frame
	End Method
	
End Type

Damit verabschiedet sich der BlitzQuiz-Thread erst einmal in die Sommerpause ... Cool

BlitzMoritz

Betreff: 6.BlitzQuiz: "Die Ameise"

 BeitragSo, Sep 11, 2011 21:05
Antworten mit Zitat
Benutzer-Profile anzeigen
Nach einer längeren Pause bin ich so frei und möchte die Quizreihe mit einem neuen faszinierenden Problem fortsetzen. Dazu eins vorweg: Waren die bisherigen Quizfragen ganz auf meinem eigenen Mist gewachsen, bediene ich mich hier anderer Quellen, weil diese sehr lohnenswert sind. Wer sie (wieder-)erkennt, bitte ich, sie nicht zu verraten.
_________________________________________________

"Die Ameise"

Gegeben sei ein unendlich großes Schachbrett, dessen Quadratfelder allerdings zu Beginn ohne Ausnahme weiß sind.
Auf diesen Quadratfeldern läuft schrittweise eine Ameise. Jedes Quadrat, auf welchem sich die Ameise befindet, wechselt die Farbe:
War es weiß, wird es schwarz; ist es schwarz, wird es wieder weiß.
Gleichzeitig ändert die Ameise ihre Bewegungsrichtung:
Tritt die Ameise auf ein weißes Quadrat, (wird es Schwarz und) dreht sich die Ameise um 90° im Uhrzeigersinn und läuft eins weiter.
Tritt die Ameise auf ein schwarzes Quadrat (wird es Weiß und) dreht sich die Ameise um 90° gegen den Uhrzeigersinn und läuft eins weiter.

Nun die 1.Frage: Wieviel Quadratfelder sind schwarz, wenn die Ameise 10000 Schritte gemacht hat?
Dann die 2.Frage: Wieviel Quadratfelder sind schwarz, wenn die Ameise eine Trilliarde Schritte gemacht hat?

Anmerkungen:
Auch das Quadrat, auf dem die Ameise am Anfang sitzt und startet, wird schwarz.
Die allererste Bewegungsrichtung zu Beginn ist für die Aufgabenstellung unerheblich.
Eine Trilliarde sind zehn hoch einundzwanzig: 1000000000000000000000

_________________________________________________
Ich wünsche viel Spaß und bitte, erst nach der Auflösung in einer Woche entsprechende Lösungscodes zu veröffentlichen.
_________________________________________________
1.Edit (um permanente Doppelposts zu vermeiden): Eine gute Woche ist nun vorbei. Gibt es jemanden, der die Aufgabe gelöst hat? Da bin ich gespannt ... Nun wäre es Zeit, Lösungscodes zu veröffentlichen.
_________________________________________________
2.Edit: Erneut ist eine Woche 'rum - schade, dass es keinen interessiert. So drehe ich weiter meine einsamen Runden. Doch anstatt die Antwort und den Lösungscode zu veröffentlichen, zeige ich nur zwei Bilder, die das Geschehen simulieren und vor allem einen wichtigen Hinweis liefern, wieso das Problem auch für eine Trilliarden Schritte lösbar ist:

So sieht die Situation nach 10000 Schritten aus:
user posted image

... und so nach 13000 Schritten:
user posted image

Ahaaaaa! - möchte man da sagen ....
  • Zuletzt bearbeitet von BlitzMoritz am So, Nov 06, 2011 22:31, insgesamt 2-mal bearbeitet

DaysShadow

 BeitragSa, Okt 01, 2011 0:11
Antworten mit Zitat
Benutzer-Profile anzeigen
Ich habe den letzten Beitrag erst vorhin gesehen und fand es interessant, erinnerte mich ein wenig an "The Game Of Life", welches ich auch gerne umgesetzt hatte bzw. faszinierend fand und finde.

Ich weiß jetzt nicht, ob ich einen Fehler gemacht habe, aber nach 9000 Schritten sieht es bei mir nicht so aus wie bei dir sondern erst bei 10000 Schritten, da dann aber auch wirklich übereinstimmend.
Ich denke daher, dass du dich einfach vertan hast.

Für 10000 Schritte habe ich jedenfalls 659 weiße und 720 schwarze Quadrate heraus.

Eine Lösung zur Trilliarde fiel mir allerdings nicht ein.
Klar, irgendwann entsteht dieser Periodische Anhang, allerdings weiß ich nicht genau wann und wieviele weiße und schwarze Quadrate eine Periode quasi hinzufügt.
Ich habe auch nicht gegoogelt oder mir sonstiges angeschaut...ich grüble noch ein wenig ^^

Hier jedenfalls der Code oder Download:

DieAmeise.bmx
BlitzMax: [AUSKLAPPEN] 
Type TAntField

	Const NONE:Int = 0
	Const WHITE:Int = $FFFFFFFF	
	Const BLACK:Int = $FF000000

	Field _ant:TAnt
	Field _fields:Int[ ]

	Field _count_white:Int	
	Field _count_black:Int

	Field _size_x:Int
	Field _size_y:Int
	
	Method Init:TAntField( size_x:Int, size_y:Int )
		
		_size_x = size_x
		_size_y = size_y
		
		_fields = New Int[ _size_x * _size_y ]
		
		For Local y:Int = 0 Until _size_y
			
			For Local x:Int = 0 Until _size_x
				
				_fields[ y * _size_x + x ] = NONE
				
			Next
			
		Next
		
		_count_white = 0
		_count_black = 0
		
		_ant = New TAnt.Init( _size_x, _size_y )
		
		Return Self
		
	End Method
	
	Method RunTurn:Int( )
				
		If( _fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = WHITE Or ..
		    _fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = NONE )
			
			If( _fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = WHITE )
				
				_count_white:- 1
				
			End If
			
			_count_black:+ 1

			_fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = BLACK
		
		Else
		
			_fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = WHITE

			_count_white:+ 1
			_count_black:- 1
	
		End If
		
		_ant.Move( )
		
		_ant.ChangeDirection( _fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] )

		If( Not( _ant.IsInsideField( _size_x, _size_y ) ) )
		
			Return False
			
		End If
	
		Return True
			
	End Method
	
	Method RunTimes( times:Int )
		
		Local i:Int = 0
		
		For i = 0 Until times
			
			If( _fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = WHITE Or ..
			    _fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = NONE )

				If( _fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = WHITE )
					
					_count_white:- 1
					
				End If
			
				_count_black:+ 1
			
				_fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = BLACK
			
			Else
			
				_fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] = WHITE
	
				_count_white:+ 1
				_count_black:- 1
		
			End If
			
			_ant.Move( )
			
			_ant.ChangeDirection( _fields[ _ant.GetPosY( ) * _size_x + _ant.GetPosX( ) ] )
			
			If( Not( _ant.IsInsideField( _size_x, _size_y ) ) )
			
				Exit
								
			End If
			
		Next
		
		Print( "Ran " + i + " times of expected " + times + " times" )
		
	End Method
	
	Method ToPixmap:TPixmap( )
		
		Local pixmap:TPixmap = CreatePixmap( _size_x, _size_y, PF_BGRA8888 )
		
		pixmap.ClearPixels( $FF808080 )
		
		For Local y:Int = 0 Until _size_y
			
			For Local x:Int = 0 Until _size_x
				
				If( _fields[ y * _size_x + x ] = WHITE )
				
					pixmap.WritePixel( x, y, WHITE )
					
				Else If( _fields[ y * _size_x + x ] = BLACK )
				
					pixmap.WritePixel( x, y, BLACK )
					
				End If
				
			Next
			
		Next
		
		Return pixmap
		
	End Method
	
	Method GetCountWhite:Int( )
		
		Return _count_white
		
	End Method
	
	Method GetCountBlack:Int( )
		
		Return _count_black
		
	End Method
	
End Type

Type TAnt
	
	Field _pos_x:Int
	Field _pos_y:Int
	Field _dir:Int
	
	Method Init:TAnt( field_width:Int, field_height:Int )
		
		_dir = 1
		
		_pos_x = field_width / 2
		_pos_y = field_height / 2
		
		Return Self
		
	End Method
	
	Method Move( )
		
		Select( _dir )
		
			Case 0
			
				_pos_y:- 1
			
			Case 1
			
				_pos_x:+ 1
			
			Case 2
			
				_pos_y:+ 1			
			
			Case 3
			
				_pos_x:- 1
			
		End Select
		
	End Method
	
	Method ChangeDirection( field_color:Int )
		
		If( field_color = TAntField.WHITE Or ..
		    field_color = TAntField.NONE )
		
			_dir = ( _dir + 1 ) Mod 4
			
		Else If( field_color = TAntField.BLACK )
		
			_dir:- 1
			
			If( _dir < 0 )
			
				_dir = 3
				
			End If
						
		End If
					
	End Method
	
	Method IsInsideField:Int( field_width:Int, field_height:Int )
		
		If( _pos_x >= 0 And _pos_x < field_width And _pos_y >= 0 And _pos_y < field_height )
		
			Return True
			
		Else
		
			Return False
			
		End If
		
	End Method
	
	Method GetPosX:Int( )
		
		Return _pos_x
		
	End Method
	
	Method GetPosY:Int( )
		
		Return _pos_y
		
	End Method
	
End Type


DieAmeise_Fast.bmx
Geht die Schritte ab, erstellt dann eine Pixmap, speichert diese als ant.png, lädt sie noch als Image und zeigt es an.
Ist das AntField kleiner, als die Schritte Platz benötigen, wird abgebrochen.
BlitzMax: [AUSKLAPPEN] 
SuperStrict

Include "DieAmeise.bmx"

Graphics( 800, 600, 0, 60 )

Global antfield:TAntField = New TAntField.Init( 200, 200 )

antfield.RunTimes( 10000 )

Global antfield_image:TImage = LoadImage( antfield.ToPixmap( ) )

SavePixmapPNG( LockImage( antfield_image ), "ant.png" )
UnlockImage( antfield_image )

Repeat
	
	Cls( )
	
		DrawImage( antfield_image, 0, 0 )
	
	Flip( )
	
Until( KeyHit( KEY_ESCAPE ) Or AppTerminate( ) )


DieAmeise_SlowWatch.bmx
Hier kann man zusehen wie das ganze entsteht, Delay entsprechend abändern damit es langsamer/schneller geht.
Die Variante hier geht solange bis sie aus der Pixmap schreitet.
Will man eine feste Schrittanzahl kann man entweder eine Zählvariable mitführen oder das ganze als For-Next Schleife aufbauen.
BlitzMax: [AUSKLAPPEN] 
SuperStrict

Include "DieAmeise.bmx"

Graphics( 800, 600, 0, 60 )

Global antfield:TAntField = New TAntField.Init( 200, 200 )
Global antfield_image:TImage

While( antfield.RunTurn( ) And ( Not( KeyHit( KEY_ESCAPE ) Or AppTerminate( ) ) ) )

	antfield_image = LoadImage( antfield.ToPixmap( ) )
	Cls
	
	SetScale( 3, 3 )
	DrawImage( antfield_image, 0, 0 )
	
	Flip
	
	Delay 10

Wend

SavePixmapPNG( antfield.ToPixmap( ), "ant.png" )

Noobody

 BeitragSa, Okt 01, 2011 0:45
Antworten mit Zitat
Benutzer-Profile anzeigen
Hoppla, den Beitrag habe ich auch glatt übersehen Razz

Falls ich morgen Zeit finde, werde ich mich daran versuchen. Ist auf jeden Fall eine interessante Aufgabenstellung, so wie alle Blitz-Quiz Aufgaben bisher - wäre also toll, falls du mit der Serie weitermachst.
Man is the best computer we can put aboard a spacecraft ... and the only one that can be mass produced with unskilled labor. -- Wernher von Braun

Gehe zu Seite Zurück  1, 2, 3, 4, 5  Weiter

Neue Antwort erstellen


Übersicht Sonstiges Projekte

Nach Oben

Gehe zu:

Powered by phpBB © 2001 - 2006, phpBB Group