Buchempfehlung
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
Windows-Programmierung. Das Entwicklerhandbuch zur WIN32-API
"Der" Petzold, das über 1000 Seiten starke Standardwerk zum Win32-API - besonders nützlich u. a. bei der GUI-Programmierung in FreeBASIC! [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

fb:porticula NoPaste

Info
Info / Hilfe
Liste
Übersicht / Liste
Neu
Datei hochladen
Suche
Quellcode suchen
Download
Dateidownload

light_test5

Uploader:MitgliedEternal_Pain
Datum/Zeit:28.02.2014 20:47:07

Function HelligkeitX(byval RGBvalue as UInteger,byval Helligkeitswert as Integer) as UInteger
    dim as integer r,g,b

    r=LoByte(HiWord(RGBvalue))+((Helligkeitswert-128)*2)
    g=HiByte(LoWord(RGBvalue))+((Helligkeitswert-128)*2)
    b=LoByte(LoWord(RGBvalue))+((Helligkeitswert-128)*2)
    '=HiByte(HiWord(RGBvalue))
    If r<0 Then r = 0
    If r>255 Then r= 255
    If g<0 then g = 0
    if g>255 then g = 255
    if b<0 then b = 0
    if b>255 then b = 255
    return rgb(r,g,b)
end function

Function Helligkeit(byval RGBvalue as UInteger,byval Helligkeitswert as Integer) as UInteger
    dim as integer RGB_Split(3)'[0]=rot,[1]=grün,[2]=blau,[3]=alpha
    dim as integer RGB_Max,RGB_Min,RGB_Range
    Dim as Double hue, saturation, value
    dim as integer huecase,r,g,b

    hue = 0 : saturation = 0 : value = 0

    RGB_Split(0)=LoByte(HiWord(RGBvalue))
    RGB_Split(1)=HiByte(LoWord(RGBvalue))
    RGB_Split(2)=LoByte(LoWord(RGBvalue))
    RGB_Split(3)=Helligkeitswert'HiByte(HiWord(RGBvalue))

    RGB_Max = 0 : RGB_Min = 255
    for i as integer=0 to 3
        if RGB_Split(i)>RGB_Max then RGB_Max=RGB_Split(i)
        if RGB_Split(i)<RGB_Min then RGB_Min=RGB_Split(i)
    next i
    RGB_Range=RGB_Max-RGB_Min

    if RGB_Range then'keine Grauwerte
        select case RGB_Max
            case RGB_Split(0)                                 'Maximalwert:rot
                hue=60 * (0 + (RGB_Split(1)-RGB_Split(2)) / RGB_Range)
            case RGB_Split(1)                                 'Maximalwert:grün
                hue=60 * (2 + (RGB_Split(2)-RGB_Split(0)) / RGB_Range)
            case RGB_Split(2)                                 'Maximalwert:blau
                hue=60 * (4 + (RGB_Split(0)-RGB_Split(1)) / RGB_Range)
        end select
        if hue<0 then hue += 360
    else'Grauwerte
        hue=0
    end if

    value=(Helligkeitswert/255)'(RGB_Max/255)
    'saturation = (RGB_range/RGB_Max)'+value
    saturation = (RGB_range/RGB_Max)-value
    If saturation<0 Then saturation = 0

  huecase=int(hue/60)+1
  select case huecase
    case 1                        'grün steigend
      r=255 : g=255 * hue/60 : b=0
    case 2                        'rot fallend
      r=255 - (255 * (hue-60) / 60) : g=255 : b=0
    case 3                        'blau steigend
      r=0 : g=255 : b=255 * (hue-120)/60
    case 4                        'grün fallend
      r=0 : g=255 - (255 * (hue-180)/60) : b=255
    case 5                        'rot steigend
      r=255 * (hue-240)/60 : g=0 : b=255
    case 6                        'blau fallend
      r=255 : g=0 : b=255 - (255 * (hue-300)/60)
  end select

  r=(255 - (255-r)*saturation) * value
  g=(255 - (255-g)*saturation) * value
  b=(255 - (255-b)*saturation) * value

  Return rgba(r,g,b,RGB_Split(3))
End Function

Type tmap
    as Integer   Width
    as Integer   Height
    as ubyte ptr map
End Type

Type tLight
    as Integer W 'Winkel
    as Integer H 'Höhe
    as Integer S 'Specular
End Type

Function EmbossLight(byref map as tmap ptr,byval Light as tLight) as UByte ptr
    if map=0 then return 0
    Dim as ubyte ptr lightmap = callocate(map->Width*map->Height)
    Dim as ubyte ptr specmap  = callocate(map->Width*map->Height)
    Dim as Integer   pix(0 to 4), nz 'pixel
    Dim as Single    pZRad, px, py   'Höhenwinkel
    Dim as Single    sl, ls, lw = (Light.W)*(ATN(1)/45)


    For y as Integer = 0 to map->Height-1
    For x as Integer = 0 to map->Width-1
        pix(0) = map->map[x+(y*map->Width)]
        If pix(0) = 0 Then Continue For

        If (y >          -1) andalso (x >          0) Then pix(1) = map->map[(x-1)+((y  )*map->Width)]     Else pix(1) = 0 'left
        If (y >           0) andalso (x >         -1) Then pix(2) = map->map[(x  )+((y-1)*map->Width)]     Else pix(2) = 0 'up middle
        If (y >          -1) andalso (x < map->Width) Then pix(3) = map->map[(x+1)+((y  )*map->Width)]     Else pix(3) = 0 'right
        If (y < map->Height) andalso (x >         -1) Then pix(4) = map->map[(x  )+((y+1)*map->Width)]     Else pix(4) = 0 'down middle

        nz = pix(0)*(Light.H*.02)

        px = (pix(3)-pix(0)) + (pix(0)-pix(1))
        py = (pix(4)-pix(0)) + (pix(0)-pix(2))

        If px<>0 or py<>0 Then
            pZRad = atan2(py,px)
            ls    = sin(pZRad-lw)

            If Light.S and ls>1-(Light.S/500) Then
                sl = (nz+Light.S)*ls
                if sl > 255 then sl = 255
                if sl <   0 then sl =   0
                specmap[x+(y*map->Width)]=sl
            End If

            nz += nz*ls
        End If

        If (nz <   1) Then nz =   1
        If (nz > 255) Then nz = 255
        lightmap[x+(y*map->Width)]=nz
    Next x
    Next y


    If Light.S Then
        For s as Integer = 0 to 3
            For y as Integer = 0 to map->Height-1
            For x as Integer = 0 to map->Width-1
                pix(0) = specmap[x+(y*map->Width)]*2
                If pix(0) = 0 Then Continue For
                If (x-1 >          -1) Then pix(1) = specmap[(x-1)+(y*map->Width)] Else pix(1) = 0 'l
                If (x+1 <  map->Width) Then pix(2) = specmap[(x+1)+(y*map->Width)] Else pix(2) = 0 'r
                If (y-1 >          -1) Then pix(3) = specmap[x+((y-1)*map->Width)] Else pix(3) = 0 'o
                If (y+1 < map->Height) Then pix(4) = specmap[x+((y+1)*map->Width)] Else pix(4) = 0 'u
                specmap[x+(y*map->Width)] = (pix(0)+pix(1)+pix(2)+pix(3)+pix(4))/6
            Next x
            Next y
        Next s

        For y as Integer = 0 to map->Height-1
        For x as Integer = 0 to map->Width-1
            pix(0) = lightmap[x+(y*map->Width)]
            If pix(0) = 0 Then Continue For
            pix(1) = specmap[x+(y*map->Width)]
            If pix(1) = 0 Then Continue For
            nZ = pix(0)+pix(1)
            If nZ>255 Then nZ = 255
            lightmap[x+(y*map->Width)] = nZ
        Next x
        Next y
    End If

    deallocate (specmap)
    return lightmap
End Function

Screenres 640,480,32
Dim as ubyte     z
Dim as tmap ptr  testmap = NEW tmap
Dim as tlight    testlight

testmap->Width  = 500
testmap->Height = 100
testmap->map    = callocate(500*100)

Dim as any ptr zimage = Imagecreate(500,100,0)
BLoad "light_test.bmp",zimage

For y as Integer = 0 to testmap->Height-1
For x as Integer = 0 to testmap->Width-1
    z = point(x,y,zimage) and &hFF
    testmap->map[x+(y*testmap->Width)] = z
Next x
Next y

Dim as Integer Changed=1
Dim as single w = 0,e = 35, l = 35
Dim as string k
Dim lightmap as ubyte ptr

Dim background as any ptr = imagecreate(500,100)
bload "background2.bmp",background
Do
    k = inkey
    If k<>"" Then Changed = 1
    if k="+" then e+=1
    if k="-" then e-=1
    if k="a" then w-=1
    if k="d" then w+=1
    if k="w" then l+=1
    if k="s" then l-=1

    if e<0 then e=0
    if e>255 then e=255
    if l<0 then l=0
    if l>255 then l=255
    if w > 359 then w-=360
    if w < 0 then w+=360
    If Changed Then
        lightmap = EmbossLight(testmap,type(w,l,e))
        if lightmap then
            screenlock
                cls
                line(0,0)-(testmap->Width-1,testmap->Height-1),&h555555,bf

                For y as Integer = 0 to testmap->Height-1
                For x as Integer = 0 to testmap->Width-1
                    z = lightmap[x+(y*testmap->Width)]
                    if z then
                        pset (x,y),Helligkeit(point(x,y,background),z)
                    else
                        'pset(x,y),point(x,y,background)
                    End If

                Next x
                Next y

                locate 20,1:?"Winkel:" & w &" Höhe:" & l & " Specular:" & e
            screenunlock
            deallocate(lightmap)
            lightmap = 0
        end if
    changed = 0
    End If
    sleep 5
Loop until multikey(&h01)


sleep
deallocate(testmap->map)
delete testmap
imagedestroy(zimage)