 |
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, 08: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, 14: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.
|
|