Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

[snippet]Rainbow_Fill

 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC.
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 02.01.2015, 08:38    Titel: [snippet]Rainbow_Fill Antworten mit Zitat

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 lächeln

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
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
volta



Anmeldungsdatum: 04.05.2005
Beiträge: 1876
Wohnort: D59192

BeitragVerfasst am: 11.01.2015, 14:09    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden Website dieses Benutzers besuchen
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC. Alle Zeiten sind GMT + 1 Stunde
Seite 1 von 1

 
Gehe zu:  
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.

 Impressum :: Datenschutz