Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
EmbossLight+Spec
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 19.02.2014 20:57:55 |
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)=HiByte(HiWord(RGBvalue))
RGB_Max = 0 : RGB_Min = 255
for i as integer=0 to 2
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)
'If Helligkeitswert<245 then
saturation = (RGB_range/RGB_Max)-value
'Else
' saturation = (RGB_range/RGB_Max)-value
'End If
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
Const as Single Deg2Rad = ATN(1)/45
Const as Single Rad2Deg = 45.0/Atn(1)
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 pLRad 'Azimut des Lichtes
Dim as Single pZRad 'Höhenwinkel
Dim as Single pSRad
Dim as Single pX 'Höhenwinkel bei 0 grd
Dim as Single pY 'Höhenwinkel bei 90 grd
Dim as Single lx, ly, ls, lw = Light.W*Deg2Rad
Dim as Single sx, sy, ss
' open cons for output as #1
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 (x-1 > -1) Then pix(1) = map->map[(x-1)+(y*map->Width)]-Light.H Else pix(1) = -Light.H 'l
If (x+1 < map->Width) Then pix(2) = map->map[(x+1)+(y*map->Width)]-Light.H Else pix(2) = -Light.H 'r
If (y-1 > -1) Then pix(3) = map->map[x+((y-1)*map->Width)]-Light.H Else pix(3) = -Light.H 'o
If (y+1 < map->Height) Then pix(4) = map->map[x+((y+1)*map->Width)]-Light.H Else pix(4) = -Light.H 'u
nZ = Light.H
lx = x+cos(lw) : ly = y+sin(lw)
pX = (pix(2)-pix(1))
pY = (pix(4)-pix(3))
If pX<>0 orelse pY<>0 Then
If Light.S Then
pLRad = atan2(ly-y,lx-x)
pZRad = atan2(y-(y+pY),x-(x+pX))
ls = sin(pLRad-pZRad)
nZ += nZ*ls
'Spec
If Light.S and ls>0.99f then specmap[x+(y*map->Width)]=255
End If
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
ss = Light.S/255
For s as Integer = 0 to 4
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)]
If pix(0) = 0 Then Continue For
If (x-1 > -1) Then pix(1) = specmap[(x-1)+(y*map->Width)] Else pix(1) = -Light.H 'l
If (x+1 < map->Width) Then pix(2) = specmap[(x+1)+(y*map->Width)] Else pix(2) = -Light.H 'r
If (y-1 > -1) Then pix(3) = specmap[x+((y-1)*map->Width)] Else pix(3) = -Light.H 'o
If (y+1 < map->Height) Then pix(4) = specmap[x+((y+1)*map->Width)] Else pix(4) = -Light.H 'u
specmap[x+(y*map->Width)] = ((pix(0)*2)+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)*ss)
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 = 640
testmap->Height = 480
testmap->map = callocate(640*480)
Dim as any ptr zimage = Imagecreate(640,480,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 w as single
Dim lightmap as ubyte ptr
Do
w += 2
if w > 359 then w-=360
lightmap = EmbossLight(testmap,type(w,60,175))
if lightmap then
screenlock
cls
line(0,0)-(testmap->Width-1,testmap->Height-1),&h333388,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(&hFF0000,z)
'z = point(x,y,zimage) and &hFF
'if z then pset(x,y),rgb(z,z,z)'testmap->map[x+(y*testmap->Width)] = z
Next x
Next y
line(250,50)-(250+(cos((w-90)*Deg2Rad)*100),50+(sin((w-90)*Deg2Rad)*100)),&hFF8800
locate 1,1:?w
screenunlock
deallocate(lightmap)
end if
lightmap = 0
sleep 50
Loop until multikey(&h01)
sleep
deallocate(testmap->map)
delete testmap
imagedestroy(zimage)