Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
BevelFrame
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 19.02.2014 16:37:02 |
#Define MinMax(v,min,max) IIF(v<min,0,IIF(v>max,0,1))
Declare Function Decode Alias "fb_hDecode" (Byval lpIn As Any Ptr, Byval asize As Integer, Byval lpOut As Any Ptr, Byref out_size As Integer ) As Integer
Type tFrame
as Integer Width
as Integer Height
as ubyte ptr FrameHeightMap
as ubyte ptr BackgroundAlpha
Declare Function LoadFRM(byval FRMFile as String) as Integer
Declare Sub DeleteFRM()
End Type
Function tFrame.LoadFRM(byval FRMFile as String) as Integer
Dim as String*3 HeaderString
Dim as Integer ff = FreeFile
Dim as Integer flen, mlen
Dim as ubyte ptr fmap,tmap
Open FRMFile for Binary as #ff
flen = LoF(ff)-11
get #ff,,HeaderString
get #ff,,this.Width
get #ff,,this.Height
mlen = this.Width*this.Height
fmap = callocate(flen)
tmap = callocate(mlen)
get #ff,,*fmap,flen
Close #ff
this.FrameHeightMap = callocate(mlen)
this.BackgroundAlpha = callocate(mlen)
Decode (fmap, flen, tmap, mlen)
deallocate fmap
For l as Integer = 0 to mlen-1
If tmap[l] Then
If tmap[l]=255 then
this.FrameHeightMap[l]=255
Else
this.BackgroundAlpha[l]=tmap[l]+1
End If
End If
Next l
deallocate tmap
return 0
End Function
Function BevelFrame (byref frame as tFrame, byval bevel as Integer, byval size as Integer=5, byval Smoothlevel as Integer = 0) as ubyte ptr
Dim as ubyte zlevel(0, 0 to 8) = { {1,33,65,97,129,161,193,225,255} }
Dim as Integer LeftRight, UpDown
Dim as ubyte ptr tempmap, bevelmap
tempmap = callocate(frame.Width*frame.Height)
bevelmap = callocate(frame.Width*frame.Height)
'1. scan/dest-lines
For y as Integer = 0 to frame.Height-1
For x as Integer = 0 to frame.Width-1
If (frame.FrameHeightMap[x+(y*frame.Width)]<>0) and (LeftRight=0) Then
LeftRight = 1 : tempmap[x+(y*frame.Width)]=BitSet(tempmap[x+(y*frame.Width)],1)'+=&b00000010
ElseIf (frame.FrameHeightMap[x+(y*frame.Width)]=0) and (LeftRight=1) Then
LeftRight = 0 : tempmap[(x-1)+(y*frame.Width)]=BitSet(tempmap[(x-1)+(y*frame.Width)],0)'+=&b00000001
End If
Next x
If (LeftRight = 1) Then LeftRight = 0 : tempmap[(frame.Width-1)+(y*frame.Width)]=BitSet(tempmap[(frame.Width-1)+(y*frame.Width)],0)'+=&b00000001
Next y
For x as Integer = 0 to frame.Width-1
For y as Integer = 0 to frame.Height-1
If (frame.FrameHeightMap[x+(y*frame.Width)]<>0) and (UpDown=0) Then
UpDown = 1 : tempmap[x+(y*frame.Width)]=BitSet(tempmap[x+(y*frame.Width)],3)'+=00001000
ElseIf (frame.FrameHeightMap[x+(y*frame.Width)]=0) and (UpDown=1) Then
UpDown = 0 : tempmap[x+((y-1)*frame.Width)]=BitSet(tempmap[x+((y-1)*frame.Width)],2)'+=00000100
End If
Next y
If (UpDown = 1) Then UpDown = 0 : tempmap[x+((frame.Height-1)*frame.Width)]=BitSet(tempmap[x+((frame.Height-1)*frame.Width)],2)'+=&b00000100
Next x
'------------
Dim as Integer dl,dx,dy,dz,xx,yy,stepdist
Dim as Single scz, sc, stepcalc, stepint, stepfrac
sc = 9 / size
open cons for output as #1
For s as Integer = 0 to size-1
stepcalc = sc*s
stepint = fix(stepcalc)
stepfrac = frac(stepcalc)
scz = zlevel(bevel,stepint)
If stepint < 8 Then
stepdist = zlevel(bevel,stepint)-zlevel(bevel,stepint+1)
scz += (stepdist * (1-stepfrac))
End If
scz = int(scz)
if scz < 1 then scz = 1
If scz > 255 then scz = 255
print #1,scz,stepdist
For y as Integer = 0 to frame.Height-1
For x as Integer = 0 to frame.Width-1
xx = 0 : yy = 0 : dz = 0
dl = tempmap[x+(y*frame.Width)]
If dl Then
'dz = (255/size)*(s+1)
dz = scz
dx = 0 : dy = 0
If (dl and &b00000010) Then dx = +1
If (dl and &b00000001) Then dx = -1
If (dl and &b00001000) Then dy = +1
If (dl and &b00000100) Then dy = -1
xx = x + (s*dx)
yy = y + (s*dy)
If dx<>0 and dy=0 Then
If MinMax(xx,0,frame.Width-1) and MinMax(y,0,frame.Height-1) and _
(frame.FrameHeightMap[xx+(y*frame.Width)]<>0) and (bevelmap[xx+(y*frame.Width)]=0) Then bevelmap[xx+(y*frame.Width)]=dz
End If
If dy<>0 and dx=0 Then
If MinMax(x,0,frame.Width-1) and MinMax(yy,0,frame.Height-1) and _
(frame.FrameHeightMap[x+(yy*frame.Width)]<>0) and (bevelmap[x+(yy*frame.Width)]=0) Then bevelmap[x+(yy*frame.Width)]=dz
End If
If dx<>0 and dy<>0 Then
If MinMax(xx,0,frame.Width-1) and MinMax(y,0,frame.Height-1) and _
(frame.FrameHeightMap[xx+(y*frame.Width)]<>0) and (bevelmap[xx+(y*frame.Width)]=0) Then bevelmap[xx+(y*frame.Width)]=dz
If MinMax(x,0,frame.Width-1) and MinMax(yy,0,frame.Height-1) and _
(frame.FrameHeightMap[x+(yy*frame.Width)]<>0) and (bevelmap[x+(yy*frame.Width)]=0) Then bevelmap[x+(yy*frame.Width)]=dz
End If
End If
Next x
Next y
Next s
close #1
'fill
For y as Integer = 0 to frame.Height-1
For x as Integer = 0 to frame.Width-1
tempmap[x+(y*frame.Width)]=0
if (frame.FrameHeightMap[x+(y*frame.Width)]<>0) andalso (bevelmap[x+(y*frame.Width)]=0) Then
bevelmap[x+(y*frame.Width)]=scz
End If
Next x
Next y
'smooth
Dim as Integer SmoothCalc
For s as Integer = 0 to SmoothLevel-1
For y as Integer = 0 to frame.Height-1
For x as Integer = 0 to frame.Width-1
If (bevelmap[x+(y*frame.Width)]<>0) Then
SmoothCalc = bevelmap[x+(y*frame.Width)]*2
If x>0 Then
If bevelmap[(x-1)+(y*frame.Width)]<>0 Then SmoothCalc += bevelmap[(x-1)+(y*frame.Width)]
End If
If x<frame.Width-1 Then
If bevelmap[(x+1)+(y*frame.Width)]<>0 Then SmoothCalc += bevelmap[(x+1)+(y*frame.Width)]
End If
If y>0 Then
If bevelmap[x+((y-1)*frame.Width)]<>0 Then SmoothCalc += bevelmap[x+((y-1)*frame.Width)]
End If
If y<frame.Height-1 Then
If bevelmap[x+((y+1)*frame.Width)]<>0 Then SmoothCalc += bevelmap[x+((y+1)*frame.Width)]
End If
SmoothCalc \= 6
If SmoothCalc < 1 Then SmoothCalc = 1
If SmoothCalc > 255 Then SmoothCalc = 255
tempmap[x+(y*frame.Width)] = SmoothCalc
End If
Next x
Next y
swap bevelmap, tempmap
Next s
deallocate tempmap
return bevelmap
End Function
'screenres 640,480,32
screenres 640,480,32
Dim frame as tFrame
'frame.LoadFRM("frm\testframe.frm")
frame.LoadFRM("frm\testframe.frm")
Dim xm as ubyte ptr
xm = BevelFrame(frame,0,9,0)
Dim as Integer z
For y as Integer = 0 to frame.Height-1
For x as Integer = 0 to frame.Width-1
z=xm[x+(y*frame.Width)]
if z then pset(x,y),rgb(z,z,z)
Next x
Next y
Dim lighttestbmp as any ptr = Imagecreate(500,100)
get (0,0)-(499,99),lighttestbmp
bsave "light_test.bmp",lighttestbmp
Imagedestroy(lighttestbmp)
sleep