fb:porticula NoPaste

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

Uploader:	Muttonhead
Datum/Zeit:	23.02.2014 12:19:08
'******************************************************************************

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, w as integer, h as integer)

declare sub SmoothIt(source as any ptr, w as integer, h as integer, 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, w as integer, h as integer)

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



Screen 19,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,imgw,imgh)

put(0,imgh),bumpmask,pset

SmoothIt(bumpmask,imgw,imgh,3)

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

LightHeightRad=halfpi * .5

do

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

  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, w as integer, h as integer)

  for y as integer=0 to h-1

    for x as integer=0 to w-1

      if (point(x,y,source) and &HFFFFFF)=excludeColor then pset dest,(x,y),&H000000 else pset dest,(x,y),&HFFFFFF

    next x

  next y

end sub







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

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

  dim as ColorDefinition center,oppositecenter,east,north,west,south

  dim as integer runner,oppositerunner

  for r as integer=1 to repeat

  for y as integer=0 to h-1

    runner=0

    oppositerunner=w-1

    do

      center.SetRGB(point(runner,y,dest))

      oppositecenter.SetRGB(point(oppositerunner,y,dest))



      'l->r

      if center.GetValue>0 then

        if (runner>0) then west.SetRGB(point(runner-1,y,dest) and &HFFFFFF) else west.SetRGB(&H0)

        if center.GetValue>west.GetValue then

          center.SetValue((center.GetValue + west.GetValue)/2)

          pset dest,(runner,y),center.GetRGB

        end if

      end if

      'r->l

      if oppositecenter.GetValue>0 then

        if (oppositerunner<w-1) then east.SetRGB(point(oppositerunner+1,y,dest) and &HFFFFFF) else east.SetRGB(&H0)

        if oppositecenter.GetValue>east.GetValue then

          oppositecenter.SetValue((oppositecenter.GetValue + east.GetValue)/2)

          pset dest,(oppositerunner,y),oppositecenter.GetRGB

        end if

      end if

      runner +=1

      oppositerunner -=1

    loop until runner=w

  next y





  for x as integer=0 to w-1

    runner=0

    oppositerunner=h-1

    do

      center.SetRGB(point(x,runner,dest))

      oppositecenter.SetRGB(point(x,oppositerunner,dest))



      'o->u

      if center.GetValue>0 then

        if (runner>0)   then north.SetRGB(point(x,runner-1,dest) and &HFFFFFF) else north.SetRGB(&H0)

        if center.GetValue>north.GetValue then

          center.SetValue((center.GetValue + north.GetValue)/2)

          pset dest,(x,runner),center.GetRGB

        end if

      end if

      'u->o

      if oppositecenter.GetValue>0 then

        if (oppositerunner<h-1) then south.SetRGB(point(x,oppositerunner+1,dest) and &HFFFFFF) else south.SetRGB(&H0)

        if oppositecenter.GetValue>south.GetValue then

          oppositecenter.SetValue((oppositecenter.GetValue + south.GetValue)/2)

          pset dest,(x,oppositerunner),oppositecenter.GetRGB

        end if

      end if

      runner +=1

      oppositerunner -=1

    loop until runner=w

  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, w as integer, h as integer)

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

  'das zu untersuchende Pixel

  dim as integer PixelPosZ'Position desPixels

  'Höhe der Nachbarpixel

  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=50'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

            bm.SetRGB(point(xx,yy,bump))

            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=pi-LightEnvRad

        if LightEnvRad<0 then LightEnvRad=0



        '4. Farbe berechnen

        cs.SetRGB(point(x,y,source))

        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

        pset dest,(x,y),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