 |
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: 02.01.2015, 07:38 Titel: [snippet]Rainbow_Fill |
 |
|
Ein kleiner bastelcode:
Ziel war ein (HUE) Radial Farbverlauf
 
Edit: erweitert, gekürzt, vereinfacht
| Code: | #Define Delta(X1,Y1,X2,Y2) int(sqr(((X1-X2)*(X1-X2))+((Y1-Y2)*(Y1-Y2))))
Function HSV(Byval H as Single) as UInteger
Static as Single Hue, Saturation, Value
Static as Single Red, Green, Blue
Static as Single f, p, q, t
Static as Integer Hs
Hue = ABS(H MOD 360) / 60
Saturation = 1
Value = 1
Hs = Int(Hue)
f = Frac(Hue)
p = Value * (1-Saturation)
q = Value * (1-(f*Saturation))
t = Value * (1-((1-f)*Saturation))
Select Case as Const Hs
Case 0 : Red = Value : Green = t : Blue = p
Case 1 : Red = q : Green = Value : Blue = p
Case 2 : Red = p : Green = Value : Blue = t
Case 3 : Red = p : Green = q : Blue = Value
Case 4 : Red = t : Green = p : Blue = Value
Case 5 : Red = Value : Green = p : Blue = q
End Select
Red *= 255 : Green *= 255 : Blue *= 255
Function = RGB(Red,Green,Blue)
End Function
Sub HUERadialGradient(byval centerx as integer, byval centery as integer, byref scrimage as any ptr = 0, byref selectmask as ubyte ptr = 0)
Dim as Integer fWidth, fHeight
Dim as Integer MaxDelta, CDelta
Dim as Single HueVal, HueCalc
If scrimage Then
imageinfo scrimage, fWidth, fHeight
Else
screeninfo fWidth, fHeight
End If
CDelta = Delta(centerx, centery, 0, 0)
If CDelta>MaxDelta Then MaxDelta = CDelta
CDelta = Delta(centerx, centery, fWidth-1, 0)
If CDelta>MaxDelta Then MaxDelta = CDelta
CDelta = Delta(centerx, centery, fWidth-1, fHeight-1)
If CDelta>MaxDelta Then MaxDelta = CDelta
CDelta = Delta(centerx, centery, 0, fHeight-1)
If CDelta>MaxDelta Then MaxDelta = CDelta
HueCalc = 360 / MaxDelta
For Y as Integer = 0 to fHeight-1
For X as Integer = 0 to fWidth-1
HueVal = Delta(centerx, centery, X, Y) * HueCalc
If selectmask Then
If selectmask[X + (Y*fWidth)] <> 0 Then pset scrimage,(X,Y),HSV(HueVal)
Else
pset scrimage,(X,Y),HSV(HueVal)
End If
Next X
Next Y
End Sub
Sub RadialGradient(byval centerx as integer, byval centery as integer, byval color1 as uinteger = &hFF000000, byval color2 as uinteger = &hFFFFFFFF, byref scrimage as any ptr = 0, byref selectmask as ubyte ptr = 0)
Dim as Integer fWidth, fHeight
Dim as Integer MaxDelta, CDelta
Dim Com1A as Integer = hibyte(hiword(color1))
Dim Com1R as Integer = lobyte(hiword(color1))
Dim Com1G as Integer = hibyte(loword(color1))
Dim Com1B as Integer = lobyte(loword(color1))
Dim Com2A as Integer = hibyte(hiword(color2))
Dim Com2R as Integer = lobyte(hiword(color2))
Dim Com2G as Integer = hibyte(loword(color2))
Dim Com2B as Integer = lobyte(loword(color2))
If scrimage Then
imageinfo scrimage, fWidth, fHeight
Else
screeninfo fWidth, fHeight
End If
CDelta = Delta(centerx, centery, 0, 0)
If CDelta>MaxDelta Then MaxDelta = CDelta
CDelta = Delta(centerx, centery, fWidth-1, 0)
If CDelta>MaxDelta Then MaxDelta = CDelta
CDelta = Delta(centerx, centery, fWidth-1, fHeight-1)
If CDelta>MaxDelta Then MaxDelta = CDelta
CDelta = Delta(centerx, centery, 0, fHeight-1)
If CDelta>MaxDelta Then MaxDelta = CDelta
Dim as Double DifA = (Com2A-Com1A) / (MaxDelta)
Dim as Double DifR = (Com2R-Com1R) / (MaxDelta)
Dim as Double DifG = (Com2G-Com1G) / (MaxDelta)
Dim as Double DifB = (Com2B-Com1B) / (MaxDelta)
For Y as Integer = 0 to fHeight-1
For X as Integer = 0 to fWidth-1
CDelta = Delta(centerx, centery, X, Y)
Com2A = Com1A + (DifA * CDelta)
Com2R = Com1R + (DifR * CDelta)
Com2G = Com1G + (DifG * CDelta)
Com2B = Com1B + (DifB * CDelta)
If selectmask Then
If selectmask[X + (Y*fWidth)] <> 0 Then pset scrimage,(X,Y),RGBA(Com2R,Com2G,Com2B,Com2A)
Else
pset scrimage,(X,Y),RGBA(Com2R,Com2G,Com2B,Com2A)
End If
Next X
Next Y
End Sub
|
Test-Code:
die testmaske
| Code: |
screenres 400,400,32
'Dim test as any ptr = imagecreate(400,400,0)
Dim maskimage as any ptr = imagecreate(400,400)
Dim bytemask as ubyte ptr = NEW ubyte[400*400]
Dim mif as uinteger
bload "bytemask.bmp",maskimage 'duotone (schwarz/weiß) bild 400*400
for y as integer = 0 to 399
for x as integer = 0 to 399
mif = point (x,y,maskimage)
if (mif and &hFFFFFF) <> 0 then bytemask[x+(y*400)]=1
next x
next y
'HueRadialGradient(0,0,0,bytemask)
RadialGradient(200,200,&hFFFFFFFF,&hFF000000,0,bytemask)
'put(0,0),test,pset
imagedestroy(test)
imagedestroy(maskimage)
delete[] bytemask
sleep
|
Zum Schluss noch ein wenig Werbung in eigener Sache 
Immer wieder Montag...
Hier geht es humorvoll rund um den Montag, zu frühes aufstehen, Arbeit und die Freude auf das Wochenende.
www.facebook.com/immerwiedermontag
_________________
 |
|
| Nach oben |
|
 |
volta
Anmeldungsdatum: 04.05.2005
Beiträge: 1876
Wohnort: D59192
|
| Verfasst am: 11.01.2015, 13:09 Titel: |
|
|
Hi,
eine einfache aber simple Methode...
| Code: | ScreenRes 400, 400, 32
BLoad "bytemask.bmp" '(schwarz/weiß) Bild 400*400
Dim As Single z = 400/256, w = 256/z
For x As Integer = 0 To 400-1
For y As Integer = 0 To 400-1
If Point(x, y) > -2 Then
PSet(x, y), RGB(w, y/z, x/z)
EndIf
Next
Next
Sleep
|
ohne Maske
| Code: | ScreenRes 400, 400, 32
Dim As Single z = 400/256, w = 256/z
For x As Integer = 0 To 400-1
For y As Integer = 0 To 400-1
PSet(x, y), RGB(w, y/z, x/z)
Next
Next
Sleep
|
_________________
Warnung an Choleriker:
Dieser Beitrag kann Spuren von Ironie & Sarkasmus enthalten.
Zu Risiken & Nebenwirkungen fragen Sie Ihren Therapeuten oder Psychiater. |
|
| 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
