Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
light_test5
| Uploader: |  Eternal_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)