Buchempfehlung
Visual Basic 6 Kochbuch
Visual Basic 6 Kochbuch
Viele praktische Tipps zum Programmieren mit Visual Basic 6, die sich oft auch auf FB übertragen lassen. [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

BevelFrame

Uploader:MitgliedEternal_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