fb:porticula NoPaste

Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen
Dateidownload
LightFX.bas debug und was schneller

Uploader:	Muttonhead
Datum/Zeit:	28.02.2014 11:16:56
'******************************************************************************

const as single pi =atn (1) * 4

const as single doublepi=pi*2

const as single halfpi=pi/2

const as single quarterpi=atn (1)



'******************************************************************************

#include "ColorDefinition.bi"





'******************************************************************************

declare sub GetImageSizes(filename as string, byref BMPWidth as integer, byref BMPHeight as integer)

declare sub CreateMask(source as any ptr, dest as any ptr, excludeColor as uinteger)

declare sub SmoothIt(source as any ptr, repeat as integer=1)

declare sub LightOn(source as any ptr, bump as any ptr,dest as any ptr, LightAzimutRad as single, LightHeightRad as single, BackgroundColor as uinteger)

declare function GetDiffHeight(Azimut as single, PixelHeights() as ubyte ) as integer



Screen 20,32

dim as string filename

dim as integer imgw,imgh

dim as any ptr img,bumpmask,destimg

dim as uinteger BackgroundColor

dim as single LightAzimutRad,LightHeightRad



'*******************************************************************************

filename="image4.bmp"

GetImageSizes(filename,imgw,imgh)

img       =imagecreate(imgw,imgh)

bumpmask  =imagecreate(imgw,imgh)

destimg   =imagecreate(imgw,imgh)

BackgroundColor=&H0



bload filename,img

put(0,0),img,pset

CreateMask(img,bumpmask,BackgroundColor)

put(0,imgh),bumpmask,pset

SmoothIt(bumpmask,6)

put(0,imgh*2),bumpmask,pset

LightHeightRad=halfpi * .75

do

  LightOn(img, bumpmask,destimg, LightAzimutRad, LightHeightRad,BackgroundColor)

  put(0,imgh*3),destimg,pset

  LightAzimutRad +=.1

  if LightAzimutRad>doublepi then LightAzimutRad -=doublepi

loop until inkey<>""





bsave "screenshot.bmp",img



imagedestroy img

imagedestroy bumpmask

imagedestroy destimg

sleep



'*******************************************************************************

'*******************************************************************************

'*******************************************************************************



'*******************************************************************************

sub GetImageSizes(filename as string, byref BMPWidth as integer, byref BMPHeight as integer)

  dim as integer ff = freefile

  open filename for binary as ff

    get #ff,19,BMPWidth

    get #ff,23,BMPHeight

  close ff

end sub







'*******************************************************************************

sub CreateMask(source as any ptr, dest as any ptr, excludeColor as uinteger)

  dim as any ptr sourcepxl,destpxl

  dim as integer h,w,bpp,ptch

  dim as uinteger ptr sourcerow,destrow

  ImageInfo(source,w,h,bpp,ptch,sourcepxl)

  ImageInfo(dest,,,,,destpxl)



  for y as integer=0 to h-1

    sourcerow=sourcepxl + y * ptch

    destrow=destpxl + y * ptch

    for x as integer=0 to w-1

      if (sourcerow[x] and &HFFFFFF)=excludeColor then  destrow[x]=&H000000 else destrow[x]=&HFFFFFF

    next x

  next y

end sub







'*******************************************************************************

sub SmoothIt(dest as any ptr, repeat as integer=1)

  dim as any ptr destpxl

  dim as integer h,w,bpp,ptch

  dim as uinteger ptr rowa,rowb,rowc

  ImageInfo(dest,w,h,bpp,ptch,destpxl)

  dim as ColorDefinition Ca,Cb,Cc

  dim as integer Xa,Xb,Ya,Yb



  for r as integer=1 to repeat

    for y as integer=0 to h-1

      rowa=destpxl + y * ptch



      Xa=0

      Xb=w-1

      do

        Ca.SetRGB(rowa[Xa] and &HFFFFFF)

        Cb.SetRGB(rowa[Xb] and &HFFFFFF)

        'l->r

        if Ca.GetValue>0 then

          if (Xa>0) then Cc.SetRGB(rowa[Xa-1] and &HFFFFFF) else Cc.SetRGB(&H0)

          if Ca.GetValue>Cc.GetValue then

            Ca.SetValue((Ca.GetValue + Cc.GetValue)/2)

            rowa[Xa]=Ca.GetRGB

          end if

        end if

        'r->l

        if Cb.GetValue>0 then

          if (Xb<w-1) then Cc.SetRGB(rowa[Xb+1] and &HFFFFFF) else Cc.SetRGB(&H0)

          if Cb.GetValue>Cc.GetValue then

            Cb.SetValue((Cb.GetValue + Cc.GetValue)/2)

            rowa[Xb]=Cb.GetRGB

          end if

        end if

        Xa +=1

        Xb -=1

      loop until Xa=w

    next y



    for x as integer=0 to w-1

      Ya=0

      Yb=h-1

      do

        rowa=destpxl + Ya * ptch

        rowb=destpxl + Yb * ptch

        Ca.SetRGB(rowa[x] and &HFFFFFF)

        Cb.SetRGB(rowb[x] and &HFFFFFF)

        'o->u

        if Ca.GetValue>0 then

          if (Ya>0) then

            rowc=destpxl + (Ya-1) * ptch

            Cc.SetRGB(rowc[x] and &HFFFFFF)

          else

            Cc.SetRGB(&H0)

          end if

          if Ca.GetValue>Cc.GetValue then

            Ca.SetValue((Ca.GetValue + Cc.GetValue)/2)

            rowa[x]=Ca.GetRGB

          end if

        end if

        'u->o

        if Cb.GetValue>0 then

          if (Yb<h-1) then

            rowc=destpxl + (Yb+1) * ptch

            Cc.SetRGB(rowc[x] and &HFFFFFF)

          else

            Cc.SetRGB(&H0)

          end if

          if Cb.GetValue>Cc.GetValue then

            Cb.SetValue((Cb.GetValue + Cc.GetValue)/2)

            rowb[x]=Cb.GetRGB

          end if

        end if

        Ya +=1

        Yb -=1

      loop until Ya=h

    next x

  next r

end sub







'******************************************************************************

sub LightOn(source as any ptr, bump as any ptr,dest as any ptr, LightAzimutRad as single, LightHeightRad as single,BackgroundColor as uinteger)

  dim as any ptr sourcepxl,bumppxl,destpxl

  dim as integer h,w,bpp,ptch

  dim as uinteger ptr sourcerow,bumprow,destrow

  ImageInfo(source,w,h,bpp,ptch,sourcepxl)

  ImageInfo(bump,,,,,bumppxl)

  ImageInfo(dest,,,,,destpxl)



  line dest,(0,0)-(w-1,h-1),BackgroundColor,bf

  'das zu untersuchende Pixel

  dim as integer PixelPosZ'Position desPixels

  'Höhe der Nachbarpixel, Index[1,1], also das Zentrum, ist das Pixel worum sich hier eigentlich alles dreht

  dim as ubyte PixelHeights(2,2)

  'Umgebung

  dim as integer EnvDiffHeight' Höhendifferenz der Umgebung zur Höhe des zu untersuchenden Pixels

  dim as single EnvRad'Neigungswinkel der Umgebung in Richtung Lichtquelle

  dim as single LightEnvRad'Höhe Licht bezogen auf Neigung der Umgebung

  dim as single LightenRange,Darkenrange,satfact

  'Berechnungshilfen

  dim as integer EnvDist=25'künstlicher Wert, Entfernung unter der die benachbarten Pixel, interpolierten Höhen betrachtet werden

  dim as integer xx,yy

  'Farbzeugs

  dim as ColorDefinition cs,bm



  LightenRange=halfpi-LightHeightRad

  DarkenRange=LightHeightRad



  For y As integer= 0 to h-1

    For x As integer=0 to w-1



      '0.alle Höhen der Pixel aus bump holen

        for k as integer=-1 to 1

          for i as integer=-1 to 1

            xx=x+i

            yy=y+k

            if (xx<0) or (xx=w) then xx=x

            if (yy<0) or (yy=h) then yy=y

            bumprow=bumppxl + yy * ptch

            bm.SetRGB(bumprow[xx])

            PixelHeights(1+i,1+k)=255 * bm.GetValue/100

          next i

        next k



      if Pixelheights(1,1)>0 then



        '1. Höhendifferenz Gelände in Richtung Licht berechnen

        EnvDiffHeight=GetDiffHeight(LightAzimutRad,PixelHeights())



        '2.Neigungswinkel der Umgebung in Richtung Licht(Azimut Licht) berechnen

        'Höhendifferenz aus einer bestimmten "Entfernung" betrachtet

        EnvRad=atan2(EnvDiffHeight,EnvDist)



        '3.relativer Lichteinfallswinkel im Bezug zur Neigung der Umgebung berechnen

        LightEnvRad=LightHeightRad-EnvRad

        'Limiter, relativer Winkel somit im Bereich 0 bis pi/2

        if LightEnvRad>halfpi then LightEnvRad=halfpi

        if LightEnvRad<0 then LightEnvRad=0



        '4. Farbe berechnen

        sourcerow=sourcepxl + y * ptch

        cs.SetRGB(sourcerow[x])

        if LightEnvRad>LightHeightRad then'Falls Licht reativ zur Umgebung "höher einfällt" als der "globale" Lichteinfallswinkel dann aufhellen

          cs.SetValue(cs.GetValue + 40*((LightEnvRad-LightHeightRad)/LightenRange))

          cs.SetSaturation(cs.GetSaturation - 75*((LightEnvRad-LightHeightRad)/LightenRange))'

        else'anderenfalls abdunkeln

          cs.SetValue(cs.GetValue -40*((LightHeightRad-LightEnvRad)/DarkenRange))'

        end if



       '5. Pixel setzen

        destrow=destpxl + y * ptch

        destrow[x]=cs.GetRGB

      end if



    next x

  next y

end sub







'*******************************************************************************

function GetDiffHeight(Azimut as single, PixelHeights() as ubyte ) as integer

  dim as integer Oktant,OStartHeight,OEndHeight

  dim as single ORad

  Oktant=int((Azimut/quarterpi)+1)

  select case Oktant

  case 1

    OStartHeight=PixelHeights(2,1)

    OEndHeight=PixelHeights(2,0)

    ORad=Azimut

  case 2

    OStartHeight=PixelHeights(2,0)

    OEndHeight=PixelHeights(1,0)

    ORad=Azimut-quarterpi

  case 3

    OStartHeight=PixelHeights(1,0)

    OEndHeight=PixelHeights(0,0)

    ORad=Azimut-(quarterpi*2)

  case 4

    OStartHeight=PixelHeights(0,0)

    OEndHeight=PixelHeights(0,1)

    ORad=Azimut-(quarterpi*3)

  case 5

    OStartHeight=PixelHeights(0,1)

    OEndHeight=PixelHeights(0,2)

    ORad=Azimut-(quarterpi*4)

  case 6

    OStartHeight=PixelHeights(0,2)

    OEndHeight=PixelHeights(1,2)

    ORad=Azimut-(quarterpi*5)

  case 7

    OStartHeight=PixelHeights(1,2)

    OEndHeight=PixelHeights(2,2)

    ORad=Azimut-(quarterpi*6)

  case 8

    OStartHeight=PixelHeights(2,2)

    OEndHeight=PixelHeights(2,1)

    ORad=Azimut-(quarterpi*7)

  end select



  'function=QStartHeight + (sin(QRad*4-halfpi)+1)/2*(QEndHeight-QStartHeight) - PixelHeights(1,1)

  function=OStartHeight + (OEndHeight-OStartHeight)  *   ORad/quarterpi  - PixelHeights(1,1)

end function