 |
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 |
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
 Verfasst am: 27.11.2010, 02:21 Titel: Median-Cut (Nullpointer/Speicherzugriffsfehler) |
 |
|
Huhu, wollt nach einer weile mal wieder ein paar funktionen zu meinem liegen gebliebenen Projekt schreiben, bin leider schon wieder ein weilchen raus und schein echt 'n brett vorm kopf zu haben... denn kann die fehler nicht sehen... ist erstmal nur ein versuchscode aber der haengt sich leider schon direkt am anfang mit zugriffsfehlern auf...
| Code: | 'Farbreduzierung'
'Start: 26.11.2010 - EternalPain
Type MedPal
LRed as UByte
HRed as UByte
LGreen as UByte
HGreen as UByte
HBlue as UByte
LBlue as UByte
End Type
Declare Function MedCol (byref ListIn as UInteger PTR, byval S as UInteger, byval E as UInteger, Byref ListOut as MedPal PTR) as UInteger
Sub LSort (byref List as UInteger PTR, byval lo as Integer, Byval hi as Integer, byval Sort as Integer)
Dim l as Integer = lo
Dim r as Integer = hi
Dim p as UInteger
Dim vl as UInteger
Dim vr as UInteger
Select Case Sort
Case 0 'Red
p = LoByte(HiWord(List[(lo+hi)/2]))
Case 1 'Green
p = HiByte(LoWord(List[(lo+hi)/2]))
Case 2 'Blue
p = LoByte(LoWord(List[(lo+hi)/2]))
End Select
if r=1 then exit sub
Do
Select Case Sort
Case 0 'Red
vl = LoByte(HiWord(List[l]))
vr = LoByte(HiWord(List[r]))
Case 1 'Green
vl = HiByte(LoWord(List[l]))
vr = HiByte(LoWord(List[r]))
Case 2 'Blue
vl = LoByte(LoWord(List[l]))
vr = LoByte(LoWord(List[r]))
End Select
While vl > p : l+=1 : Wend
While vr < p : r-=1 : Wend
If l<=r Then
Swap List[l],List[r]
l+=1 : r-=1
End If
Loop while l<r
If lo<r Then LSort(List,lo,r,Sort)
If l<hi Then LSort(List,l,hi,Sort)
End Sub
SUB ColorReduce (byref Image as any ptr, byval CBit as UByte=8)
If Image=0 Then Exit Sub
Dim BufferVersion as UInteger=Peek(UInteger,Image)
If BufferVersion<>7 Then Exit Sub
Dim BufferBPP as UInteger=Peek(UInteger,Image+4)
Dim BufferSizeX as UInteger=Peek(UInteger,Image+8)
Dim BufferSizeY as UInteger=Peek(UInteger,Image+12)
Dim BufferPitch as UInteger=Peek(UInteger,Image+16)
Dim ColorBitList as UByte ptr=Callocate(2097152)
Dim CBLByte as UInteger
Dim CBLBit as UByte
Dim IndexColor as UInteger
Dim CountColor as UInteger
Dim ColorListTemp as any ptr
Dim ColorList as UInteger PTR
ColorList=Callocate(Len (UInteger))
''Farben zaehlen und speichern''
For Y as UInteger=0 to BufferSizeY-1
For X as UInteger=0 to BufferSizeX-1
IndexColor=Peek (UInteger ,Image+32+(X*BufferBPP)+(Y*BufferPitch)) and &h00FFFFFF
CBLByte = Fix(IndexColor/8)
CBLBit = (IndexColor mod 8)
If Bit(ColorBitList[CBLByte],CBLBit)=0 Then
ColorList[CountColor]=IndexColor
CountColor+=1
ColorBitList[CBLByte]+=(1 SHL CBLBit)
ColorListTemp=Reallocate(ColorList,CountColor * Len(UInteger))
Deallocate (ColorList)
ColorList=ColorListTemp
End If
Next X
Next Y
Deallocate (ColorListTemp)
Deallocate (ColorBitList)
'CountColor = Anzahl Farben
'ColorList (PTR) = Farbenwerte
Dim NewPal as MedPal PTR=Callocate(256*Len(MedPal))
'MedCol (ColorList,0,CountColor-1,NewPal)
End Sub
Function MedCol (byref ListIn as UInteger PTR, byval S as UInteger, byval E as UInteger, Byref ListOut as MedPal PTR) as UInteger
Static Colors as UInteger
Dim LRed as UByte=255
Dim HRed as UByte=0
Dim MRed as UInteger
Dim LGreen as UByte=255
Dim HGreen as UByte=0
Dim MGreen as UInteger
Dim LBlue as UByte=255
Dim HBlue as UByte=0
Dim MBlue as UInteger
Dim Sort as Integer
Dim S1 as UInteger=S
Dim E1 as UInteger=E
Dim S2 as UInteger
Dim E2 as UInteger
''' Wertvariablen: Zum besseren Verstaendnis bei spaeteren durchsehen.
Dim SortRed as Integer=0
Dim SortGreen as Integer=1
Dim SortBlue as Integer=2
'Laengste 'Schnitt-Achse' ermitteln'
For l as Integer=S to E
MRed = LoByte(HiWord(ListIn[l]))
MGreen = HiByte(LoWord(ListIn[l]))
MBlue = LoByte(LoWord(ListIn[l]))
If MRed > HRed Then HRed = MRed
If MRed < LRed Then LRed = MRed
If MGreen > HGreen Then HGreen = MGreen
If MGreen < LGreen Then LGreen = MGreen
If MBlue > HBlue Then HBlue = MBlue
If MBlue < LBlue Then LBlue = MBlue
Next l
MRed = (HRed-LRed)
MGreen = (HGreen-LGreen)
MBlue = (HBlue-LBlue)
Sort=IIF(MRed>=MGreen,IIF(MRed>=MBlue,SortRed,SortBlue),IIF(MGreen>=MBlue,SortGreen,SortBlue))
'LSort (ListIn,S1,E1,Sort)
Colors+=1
If (E1-S1)>1 Then
E2=E1
E1=(CInt(E1-S1)/2)
S2=E1+1
'MedCol (ListIn,S1,E1,ListOut)
'MedCol (ListIn,S2,E2,ListOut)
End If
Locate 1,1:?Colors
Colors=0
return 0
End Function
screen 19,32
Dim test as any ptr=ImageCreate(800,600)
BLoad "test.bmp",test
ColorReduce (test)
sleep
|
ich konnte zumindest den fehler soweit eingrenzen das er bereits schon beim 'speichern' der farben auftritt...
also in diesem bereich
| Code: | ''Farben zaehlen und speichern''
For Y as UInteger=0 to BufferSizeY-1
For X as UInteger=0 to BufferSizeX-1
IndexColor=Peek (UInteger ,Image+32+(X*BufferBPP)+(Y*BufferPitch)) and &h00FFFFFF
CBLByte = Fix(IndexColor/8)
CBLBit = (IndexColor mod 8)
If Bit(ColorBitList[CBLByte],CBLBit)=0 Then
ColorList[CountColor]=IndexColor
CountColor+=1
ColorBitList[CBLByte]+=(1 SHL CBLBit)
ColorListTemp=Reallocate(ColorList,CountColor * Len(UInteger))
Deallocate (ColorList)
ColorList=ColorListTemp
End If
Next X
Next Y
|
vielleicht sieht ja hier einer mehr 
_________________
 |
|
| Nach oben |
|
 |
Cherry
Anmeldungsdatum: 20.06.2007
Beiträge: 249
|
| Verfasst am: 27.11.2010, 06:45 Titel: |
|
|
| Code: | ColorListTemp=Reallocate(ColorList,CountColor * Len(UInteger))
Deallocate (ColorList)
ColorList=ColorListTemp
|
Mach stattdessen:
| Code: | | ColorList=Reallocate(ColorList,CountColor * Len(UInteger)) |
|
|
| Nach oben |
|
|
XOR
Anmeldungsdatum: 23.07.2010
Beiträge: 161
|
| Verfasst am: 27.11.2010, 07:16 Titel: |
|
|
| Code: |
ColorListTemp=Reallocate(ColorList,CountColor * Len(UInteger))
Deallocate (ColorList)
ColorList=ColorListTemp
|
Macht stattdessen
| Code: |
ColorList=Reallocate(ColorList,(CountColor + 1) * Len(UInteger))
|
Cherry hat das +1 vergessen, sonst waere der Speicher immer 1 UInteger zu klein
@Eternal_pain
du solltest ColorList nach der Function MedCol Deallocaten,
genauso den test-image Pointer am ende des Programmes |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 27.11.2010, 09:34 Titel: |
|
|
| Code: | | ColorList=Reallocate(ColorList,(CountColor + 1) * Len(UInteger)) |
Jop.. daemlicher fehler >.< danke 
joa, is wie gesagt bisher auch nur ein versuchscode, aufgeraeumt wird spaeter 
zumal MedCol noch gar nicht funktioniert, da haengt's in einer 'endlosschleife' ich mag Rekursive funktionen, wenn ich sie ned selber schreiben muss
_________________
|
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 07.12.2010, 08:47 Titel: |
|
|
Hab da mal ein Gedankenproblem
und zwar wollte ich die Funktion die meine gezaehlten farben in einer angegebenen anzahl von mittelwertfarben berechnet rekursiv in einer funktion packen, leider is mir bei meinem versuch irgendwie ein denkfehler unterlaufen...
Und zwar kann man sich das, wenn man das sortieren ect. mal ausser acht laesst, wie eine line unbekannter laenge vorstellen die man zuerst in der mitte teilt, dann diese beiden wiederrum jeweils in der mitte, diese vier dann jeweils wieder in der mitte usw usw....
jetzt ruft dir funktion bei dem beispiel nach dem ersten mal sich selber auf...
und teilt auch ordnungsgemaess EINE HAELFTE der linie bzw meiner liste...
nur durch den selbstaufruf gehen mir dabei im grunde wichtige informationen verloren fuer die zweite haelfte wo es natuerlich zu fehlern und letztenendes zu einem absturz kommt....
| Code: | Function MedCol (byref ListIn as UInteger PTR, byval S as UInteger, byval E as UInteger, Byref ListOut as MedPal PTR) as UInteger
Static Colors as UInteger
Dim LRed as UByte=255
Dim HRed as UByte=0
Dim MRed as UInteger
Dim LGreen as UByte=255
Dim HGreen as UByte=0
Dim MGreen as UInteger
Dim LBlue as UByte=255
Dim HBlue as UByte=0
Dim MBlue as UInteger
Dim Sort as Integer
Dim S1 as UInteger=S
Dim E1 as UInteger=E
Dim S2 as UInteger
Dim E2 as UInteger
''' Wertvariablen: Zum besseren Verstaendnis bei spaeteren durchsehen.
Dim SortRed as Integer=0
Dim SortGreen as Integer=1
Dim SortBlue as Integer=2
'Laengste 'Schnitt-Achse' ermitteln'
For l as Integer=S to E
MRed = LoByte(HiWord(ListIn[l]))
MGreen = HiByte(LoWord(ListIn[l]))
MBlue = LoByte(LoWord(ListIn[l]))
If MRed > HRed Then HRed = MRed
If MRed < LRed Then LRed = MRed
If MGreen > HGreen Then HGreen = MGreen
If MGreen < LGreen Then LGreen = MGreen
If MBlue > HBlue Then HBlue = MBlue
If MBlue < LBlue Then LBlue = MBlue
Next l
MRed = (HRed-LRed)
MGreen = (HGreen-LGreen)
MBlue = (HBlue-LBlue)
?"Sort start"
Sort=IIF(MRed>=MGreen,IIF(MRed>=MBlue,SortRed,SortBlue),IIF(MGreen>=MBlue,SortGreen,SortBlue))
LSort (ListIn,S1,E1,Sort)
?"Sort End"
Colors+=1
?Colors
' If (E1-S1)>2 Then
' E2=E1
'
' E1=(CInt(E1-S1)/2)
'
' S2=E1+1
' MedCol (ListIn,S1,E1,ListOut)
' MedCol (ListIn,S2,E2,ListOut)
' End If
Colors=0
return 0
End Function |
der ausgeklammerte teil ist mein problem...
und zwar wollte ich wie man vielleicht erkennen kann beide listenhaelften durch erneutes aufrufen der funktion teilen, jedoch bekommen hier die werte S2 und E2 ja durch neues aufrufen vom MedCol neue Werte ohne das sie genutzt worden sind....
hoffe konnte mich so frueh am morgen halbwegs erklaeren
_________________
|
|
| Nach oben |
|
|
Muttonhead
Anmeldungsdatum: 26.08.2008
Beiträge: 571
Wohnort: Jüterbog
|
| Verfasst am: 09.12.2010, 08:16 Titel: |
|
|
ka ob das richtig funzt und dir hilft...
eine Liste/Teilliste muss in diesem Beispiel aus mindestestens 2 Elementen bestehen
das Element welches die Mitte beim Split darstellt, wird in beiden entstehenden
Teillisten jeweils als ende bzw start benutzt
| Code: |
dim shared as string liste
liste="abcdefghijklmnopqrstuvwxyz"
declare sub test (start as integer,ende as integer,rektiefe as integer=0)
test ( 1 , len(liste) )
sleep
end
sub test (start as integer,ende as integer,tiefe as integer=0)
dim as integer mitte
'Aktion was mit dieser Liste passieren soll
'hier einmal nur nen printout
print "Tiefe: " & tiefe & " Laenge: " & (ende-start+1) & " : ";
for i as integer=start to ende
print mid(liste,i,1);
next i
print
'Teilen bzw Abbruchbedingung:
if ende-start>1 then 'Teilung nur durchführen, wenn Liste aus mind. 3 Elementen besteht
mitte= start + cint((ende-start)/2)
if mitte>=start+1 then test (start,mitte,tiefe+1)'Aufruf nur wenn erste Teilliste mind.2 Elemente besitzt
if ende>=mitte+1 then test (mitte,ende,tiefe+1) 'Aufruf nur wenn zweite Teilliste mind.2 Elemente besitzt
end if
end sub
|
Mutton |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 10.12.2010, 01:20 Titel: |
|
|
Das sieht ja super aus, und vorallem so viel einfacher als mein gedanke mit eine art liste zwischen zu speichern
Hab aber scheinbar immernoch irgendwo was falsch 
Werd mich wohl mal dran machen wenn ich bisschen mehr zeit und konzentration fuer habe...
In diesem Beispiel benutze ich eine Bitmap mit gezaehlten 248 farben,
eigentlich muesste ich bei so wenigen farben noch eine weitere abbruchbedingung einbauen da ich da normal keine reduzierung durchfuehren will... (ist immernoch bastelcode und nicht fertig)
jetzt sturzt mir zwar nichts mehr ab, zaehlt aber am schluss 255 farben...
sind nach einer reduzierung eindeutig zu viele
| Code: | 'Farbreduzierung'
'Start: 26.11.2010 - EternalPain
Type MedPal
LRed as UByte
HRed as UByte
LGreen as UByte
HGreen as UByte
HBlue as UByte
LBlue as UByte
End Type
Declare Function MedCol (byref ListIn as UInteger PTR, byval S as UInteger, byval E as UInteger, Byref ListOut as MedPal PTR) as UInteger
Sub LSort (byref List as UInteger PTR, byval lo as UInteger, Byval hi as UInteger, byval Sort as Integer)
if hi=1 or List=0 then exit sub
Dim l as UInteger = lo
Dim r as UInteger = hi
Dim p as UInteger
p = IIF(Sort=0,LoByte(HiWord(List[(l+r)/2])),IIF(Sort=1,HiByte(LoWord(List[(l+r)/2])),LoByte(LoWord(List[(l+r)/2]))))
Do
While IIF(Sort=0,LoByte(HiWord(List[l])),IIF(Sort=1,HiByte(LoWord(List[l])),LoByte(LoWord(List[l])))) < p : l+=1 : Wend
While IIF(Sort=0,LoByte(HiWord(List[r])),IIF(Sort=1,HiByte(LoWord(List[r])),LoByte(LoWord(List[r])))) > p : r-=1 : Wend
If l<=r Then
Swap List[l],List[r]
l+=1 : r-=1
End If
Loop while l<r
If lo<r Then LSort(List,lo,r,Sort)
If l<hi Then LSort(List,l,hi,Sort)
End Sub
SUB ColorReduce (byref Image as any ptr, byval CBit as UByte=8)
If Image=0 Then Exit Sub
Dim BufferVersion as UInteger=Peek(UInteger,Image)
If BufferVersion<>7 Then Exit Sub
Dim BufferBPP as UInteger=Peek(UInteger,Image+4)
Dim BufferSizeX as UInteger=Peek(UInteger,Image+8)
Dim BufferSizeY as UInteger=Peek(UInteger,Image+12)
Dim BufferPitch as UInteger=Peek(UInteger,Image+16)
Dim ColorBitList as UByte ptr=Callocate(2097152)
Dim CBLByte as UInteger
Dim CBLBit as UByte
Dim IndexColor as UInteger
Dim CountColor as UInteger
Dim ColorList as UInteger PTR
ColorList=Callocate(Len (UInteger))
''Farben zaehlen und speichern''
For Y as UInteger=0 to BufferSizeY-1
For X as UInteger=0 to BufferSizeX-1
IndexColor=Peek (UInteger ,Image+32+(X*BufferBPP)+(Y*BufferPitch)) and &h00FFFFFF
CBLByte = Fix(IndexColor/8)
CBLBit = (IndexColor mod 8)
If Bit(ColorBitList[CBLByte],CBLBit)=0 Then
ColorList[CountColor]=IndexColor
CountColor+=1
ColorBitList[CBLByte]+=(1 SHL CBLBit)
ColorList=Reallocate(ColorList,((CountColor+1) * Len(UInteger)))
End If
Next X
Next Y
Deallocate (ColorBitList)
'CountColor = Anzahl Farben
'ColorList (PTR) = Farbenwerte
Dim NewPal as MedPal PTR=Callocate(256*Len(MedPal))
MedCol (ColorList,0,CountColor-1,NewPal)
End Sub
Function MedCol (byref ListIn as UInteger PTR, byval start as UInteger, byval ende as UInteger, Byref ListOut as MedPal PTR) as UInteger
Static Colors as UInteger
Dim LRed as UByte=255
Dim HRed as UByte=0
Dim MRed as UInteger
Dim LGreen as UByte=255
Dim HGreen as UByte=0
Dim MGreen as UInteger
Dim LBlue as UByte=255
Dim HBlue as UByte=0
Dim MBlue as UInteger
Dim Sort as Integer
Dim As Integer mitte
''' Wertvariablen: Zum besseren Verstaendnis bei spaeteren durchsehen.
Dim SortRed as Integer=0
Dim SortGreen as Integer=1
Dim SortBlue as Integer=2
'Laengste 'Schnitt-Achse' ermitteln'
For l as Integer=start to ende
MRed = LoByte(HiWord(ListIn[l]))
MGreen = HiByte(LoWord(ListIn[l]))
MBlue = LoByte(LoWord(ListIn[l]))
If MRed > HRed Then HRed = MRed
If MRed < LRed Then LRed = MRed
If MGreen > HGreen Then HGreen = MGreen
If MGreen < LGreen Then LGreen = MGreen
If MBlue > HBlue Then HBlue = MBlue
If MBlue < LBlue Then LBlue = MBlue
Next l
MRed = (HRed-LRed)
MGreen = (HGreen-LGreen)
MBlue = (HBlue-LBlue)
Sort=IIF(MRed>=MGreen,IIF(MRed>=MBlue,SortRed,SortBlue),IIF(MGreen>=MBlue,SortGreen,SortBlue))
LSort (ListIn,start,ende,Sort)
Colors+=1
?Colors
If (ende-start)>1 Then
mitte = start + Fix((ende-start)/2)
If mitte >= start+1 Then
'Start-Mitte in ListOut verarbeiten
MedCol (ListIn, start , mitte, ListOut)
Else
'Start-Mitte in ListOut verarbeiten
EndIf
If (mitte+1) <= ende Then
'Mitte+1 - Ende in ListOut verarbeiten
MedCol (ListIn, mitte+1, ende , ListOut)
Else
'Mitte+1 - Ende in ListOut verarbeiten
EndIf
Else
'Start - Ende in ListOut verarbeiten
EndIf
'Colors=0
return 0
End Function
screen 19,32
Dim test as any ptr=ImageCreate(800,600)
BLoad "test.bmp",test
ColorReduce (test)
sleep
|
_________________
|
|
| 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
