Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
Emboss_10.bas
| Uploader: |  Muttonhead |
| Datum/Zeit: | 19.02.2014 14:47:41 |
'******************************************************************************
const as single pi =atn (1) * 4
const as single doublepi=pi*2
const as single halfpi=pi/2
'******************************************************************************
#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, LightAzimutRad as single, LightHeightRad as single, w as integer, h as integer)
declare function GetDiffHeight(Azimut as single, PixelCenterHeight as ubyte, PixelEastHeight as ubyte, PixelNorthHeight as ubyte, PixelWestHeight as ubyte, PixelSouthHeight as ubyte) as integer
Screen 19,32
dim as string filename
dim as integer imgw,imgh
dim as any ptr img,bumpmask
'Verortung Licht im Koordinatensystem
'Licht kommt für jedes Pixel aus einer Richtung und einer Höhe, parallele Lichtstrahlen ähnlich Sonne
dim as single LightAzimutRad,LightHeightRad
'*******************************************************************************
filename="image1.bmp"
'Sub öffnet Datei und holt nur Breite und Höhe heraus
GetImageSizes(filename,imgw,imgh)
img =imagecreate(imgw,imgh)
bumpmask =imagecreate(imgw,imgh)
bload filename,img
put(0,0),img,pset
sleep 1000
'erzeugt in bumpmask aus dem OriginalImage eine schwarz-weiss Maske
'der 3. Parameter ist die Ausschlußfarbe, diese wird in der bumpmask zu schwarz,
'alles andere weiss
CreateMask(img,bumpmask,&H0,imgw,imgh)
put(0,0),bumpmask,pset
sleep 1000
'ein einfacher Weichzeichner der über die bumpmask "gejagt" wird.
'nicht sehr schnell, aber er funzt.
'letzte Parameter ein Repeater, wie oft soll weichgerechnet werden
SmoothIt(bumpmask,imgw,imgh,2)
put(0,0),bumpmask,pset
'Nun ist bumpmask nicht mehr nur eine Maske sondern kann auch als Höhenfeld
'interpretiert werden, die Ränder zu schwarz sind schön rundgerechnet...
sleep 1000
'schnell noch Lichtquelle positionieren
'paralleles Licht, d.h. für jedes Pixel kommt der Lichtstrahl aus der gleichen
'globalen Richtung
LightAzimutRad=doublepi * .33
LightHeightRad=halfpi * .33
LightOn(img, bumpmask, LightAzimutRad, LightHeightRad, imgw, imgh)
put(0,0),img,pset
imagedestroy img
imagedestroy bumpmask
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,east,north,west,south
dim as integer rc,rsx,rex,rsy,rey,rstp
for r as integer=1 to repeat
rc=0
rsx=0
rsy=0
rex=w-1
rey=h-1
rstp=1
do
rc +=1
for y as integer=rsy to rey step rstp
for x as integer=rsx to rex step rstp
center.AllToZero
east.AllToZero
north.AllToZero
west.AllToZero
south.AllToZero
center.SetRGB(point(x,y,dest) and &HFFFFFF)
if center.GetValue>0 then
if x>0 then west.SetRGB(point(x-1,y,dest) and &HFFFFFF)
if x<w-1 then east.SetRGB(point(x+1,y,dest) and &HFFFFFF)
if y>0 then north.SetRGB(point(x,y-1,dest) and &HFFFFFF)
if y<h-1 then south.SetRGB(point(x,y+1,dest) and &HFFFFFF)
center.SetValue((east.GetValue + north.GetValue + west.GetValue + south.GetValue)/4)
pset dest,(x,y),center.GetRGB
end if
next x
next y
swap rsx,rex
swap rsy,rey
rstp *=-1
loop until rc=2
next r
end sub
'******************************************************************************
sub LightOn(source as any ptr, bump as any ptr, LightAzimutRad as single, LightHeightRad as single, w as integer, h as integer)
'das zu untersuchende Pixel
dim as integer PixelPosZ'Position desPixels
'Höhe der Nachbarpixel
dim as integer PixelEastPosZ,PixelNorthPosZ,PixelWestPosZ,PixelSouthPosZ
'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
'Berechnungshilfen
dim as integer EnvDist=50'künstlicher Wert, Entfernung unter der die benachbarten Pixel, interpolierten Höhen betrachtet werden
'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 vier anliegenden Pixel aus bump holen
bm.SetRGB(point(x,(h-1)-y,bump))
if int(bm.GetValue)>0 then
PixelPosZ=255 * bm.GetValue/100
PixelEastPosZ=PixelPosZ
PixelNorthPosZ=PixelPosZ
PixelWestPosZ=PixelPosZ
PixelSouthPosZ=PixelPosZ
if x>0 then
bm.SetRGB(point(x+1,(h-1)-y,bump))
PixelEastPosZ=255 * bm.GetValue/100
end if
if x<639 then
bm.SetRGB(point(x-1,(h-1)-y,bump))
PixelWestPosZ=255 * bm.GetValue/100
end if
if y>0 then
bm.SetRGB(point(x,(h-1)-y-1,bump))
PixelNorthPosZ=255 * bm.GetValue/100
end if
if y<479 then
bm.SetRGB(point(x,(h-1)-y+1,bump))
PixelSouthPosZ=255 * bm.GetValue/100
end if
'1. Höhendifferenz Gelände in Richtung Licht berechnen
EnvDiffHeight=GetDiffHeight(LightAzimutRad,PixelPosZ,PixelEastPosZ,PixelNorthPosZ,PixelWestPosZ,PixelSouthPosZ)
'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,(h-1)-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 + 66*((LightEnvRad-LightHeightRad)/LightenRange))
cs.SetSaturation(cs.GetSaturation - 100*((LightEnvRad-LightHeightRad)/LightenRange))'
else'anderenfalls abdunkeln
cs.SetValue(cs.GetValue -66*((LightHeightRad-LightEnvRad)/DarkenRange))'
end if
'5. Pixel setzen
pset source,(x,(h-1)-y),cs.GetRGB
end if
Next x
Next y
end sub
'*******************************************************************************
function GetDiffHeight(Azimut as single, PixelCenterHeight as ubyte, PixelEastHeight as ubyte, PixelNorthHeight as ubyte, PixelWestHeight as ubyte, PixelSouthHeight as ubyte) as integer
dim as integer Quadrant,QStartHeight,QEndHeight
dim as single QRad
Quadrant=int((Azimut/halfpi)+1)
select case Quadrant
case 1
QStartHeight=PixelEastHeight
QEndHeight=PixelNorthHeight
QRad=Azimut
case 2
QStartHeight=PixelNorthHeight
QEndHeight=PixelWestHeight
QRad=Azimut-halfpi
case 3
QStartHeight=PixelWestHeight
QEndHeight=PixelSouthHeight
QRad=Azimut-pi
case 4
QStartHeight=PixelSouthHeight
QEndHeight=PixelEastHeight
QRad=Azimut-(pi+halfpi)
end select
function=QStartHeight + (sin(QRad*2-halfpi)+1)/2*(QEndHeight-QStartHeight) - PixelCenterHeight
end function