Code: Select all
ScreenRes 800,600,32
Randomize
Const Light_Range=1000
Const cubes=5
#Include once "fbgfx.bi"
#Define Get_R(a) ((a shr 16) and 255)
#Define Get_G(a) ((a shr 8) and 255)
#Define Get_B(a) (a and 255)
#Define Get_Ptr_Size_X(a) cptr(FB.IMAGE Ptr,a)->width
#Define Get_Ptr_Size_Y(a) cptr(FB.IMAGE Ptr,a)->height
Sub Apply_Color_Filter(ByRef Img as any ptr, r As Integer, g As Integer, b As Integer)
Dim as Uinteger CurrentCol
Dim as integer _R,_G,_B
Dim as integer SizeX = Get_ptr_Size_X(Img)
Dim as integer SizeY = Get_ptr_Size_Y(Img)
Dim as single CurrentLum
For i as integer = 0 to SizeX - 1
For j as integer = 0 to SizeY - 1
CurrentCol = Point(i,j,Img)
_R = r
_G = g
_B = b
CurrentLum = (Get_R(Currentcol)+Get_g(Currentcol)+Get_b(Currentcol))/(255*3)
Pset Img,(i,j),rgb(CurrentLum*_r,CurrentLum*_g,CurrentLum*_b)
Next
Next
End Sub
Dim As Any Ptr Texture_Roof1=ImageCreate(100,100)
Line Texture_Roof1,(0,0)-(100,100),RGB(46,37,51),BF
Dim As Any Ptr Texture_Roof2=ImageCreate(100,100)
Line Texture_Roof2,(0,0)-(100,100),RGB(56,28,19),BF
Dim As Any Ptr Roof_Tile1=ImageCreate(11,6)
Line Roof_Tile1,(0,0)-(10,5),RGB(46,37,51),B
Line Roof_Tile1,(0,5)-(10,5),RGB(29,19,30)
Line Roof_Tile1,(1,1)-(9,2),RGB(114,107,126),BF
Line Roof_Tile1,(1,3)-(9,4),RGB(77,74,93),BF
Dim As Any Ptr Roof_Tile1R=ImageCreate(11,6)
Line Roof_Tile1R,(0,0)-(10,5),RGB(43,35,32),B
Line Roof_Tile1R,(0,5)-(10,5),RGB(23,19,18)
Line Roof_Tile1R,(1,1)-(9,2),RGB(124,101,93),BF
Line Roof_Tile1R,(1,3)-(9,4),RGB(84,68,63),BF
Dim As Any Ptr Roof_Tile2(5),Roof_Tile3(5)
For i As Integer=0 To 5
Roof_Tile2(i)=ImageCreate(8,4)
Line Roof_Tile2(i),(0,0)-(8,4),RGB(46,37,51),BF
Roof_Tile3(i)=ImageCreate(8,4)
Line Roof_Tile3(i),(0,0)-(8,4),RGB(46,37,51),BF
Next
Line Roof_Tile2(0),(0,0)-(7,2),RGB(77,74,93),BF
Line Roof_Tile2(0),(1,3)-(6,3),RGB(77,74,93)
Line Roof_Tile2(1),(0,0)-(7,2),RGB(114,107,126),BF
Line Roof_Tile2(1),(1,3)-(6,3),RGB(114,107,126)
Line Roof_Tile2(2),(0,0)-(7,2),RGB(61,55,72),BF
Line Roof_Tile2(2),(1,3)-(6,3),RGB(61,55,72)
Line Roof_Tile2(3),(0,0)-(7,2),RGB(77,74,93),BF
Line Roof_Tile2(3),(1,3)-(6,3),RGB(77,74,93)
Line Roof_Tile2(4),(0,0)-(7,2),RGB(77,74,93),BF
Line Roof_Tile2(4),(1,3)-(6,3),RGB(77,74,93)
Line Roof_Tile2(5),(0,0)-(7,2),RGB(61,55,72),BF
Line Roof_Tile2(5),(1,3)-(6,3),RGB(61,55,72)
Line Roof_Tile3(0),(0,2)-(7,3),RGB(77,74,93),BF
Line Roof_Tile3(0),(1,1)-(6,1),RGB(77,74,93)
Line Roof_Tile3(1),(0,2)-(7,3),RGB(114,107,126),BF
Line Roof_Tile3(1),(1,1)-(6,1),RGB(114,107,126)
Line Roof_Tile3(2),(0,2)-(7,3),RGB(61,55,72),BF
Line Roof_Tile3(2),(1,1)-(6,1),RGB(61,55,72)
Line Roof_Tile3(3),(0,2)-(7,3),RGB(77,74,93),BF
Line Roof_Tile3(3),(1,1)-(6,1),RGB(77,74,93)
Line Roof_Tile3(4),(0,2)-(7,3),RGB(77,74,93),BF
Line Roof_Tile3(4),(1,1)-(6,1),RGB(77,74,93)
Line Roof_Tile3(5),(0,2)-(7,3),RGB(61,55,72),BF
Line Roof_Tile3(5),(1,1)-(6,1),RGB(61,55,72)
Dim As Any Ptr Red_Filter=ImageCreate(100,100)
Line Red_Filter,(0,0)-(100,100),RGB(163,81,54),BF
For i As Integer=0 To 10
Put Texture_Roof1,(i*10,48),Roof_Tile1,Trans
Next
For x As Integer=0 To 12
For y As Integer=0 To 8
If y Mod 2=1 Then
Put Texture_Roof1,(x*9-5,y*5+54),Roof_Tile2(Rnd()*5),Trans
Else
Put Texture_Roof1,(x*9,y*5+54),Roof_Tile2(Rnd()*5),Trans
End If
Next
Next
For x As Integer=0 To 12
For y As Integer=0 To 9
If y Mod 2=1 Then
Put Texture_Roof1,(x*9-5,y*5-1),Roof_Tile3(Rnd()*5),Trans
Else
Put Texture_Roof1,(x*9,y*5-1),Roof_Tile3(Rnd()*5),Trans
End If
Next
Next
Put Texture_Roof2,(0,0),Texture_Roof1,Trans
Apply_Color_Filter(Texture_Roof2,163*2,81*2,54*2)
For i As Integer=0 To 10
Put Texture_Roof2,(i*10,48),Roof_Tile1R,Trans
Next
Dim As Integer mx,my
Type TCube
As Integer X,Y,XScale,YScale
As Integer Clr(3),Roof
As Double Angle1(8),Angle2(8),Angle3(8),Angle4(8)
As Any Ptr Shadow
End Type
Dim Shared As TCube Cube(cubes)
Dim As Integer ScrollX,ScrollY
Dim As Integer cubex(cubes),cubey(cubes),cubexscale(cubes),cubeyscale(cubes),cubecolor(cubes,3),switch
Dim As Double cubeangle1(cubes),cubeangle2(cubes),cubeangle3(cubes),cubeangle4(cubes)
For i As Integer=1 To cubes
With Cube(i)
.X=Rnd()*700+50
.Y=Rnd()*500+50
.XScale=100
.YScale=100
For i2 As Integer=1 To 3
.Clr(i2)=128
Next
.Roof=Rnd()*1
.Shadow=ImageCreate(.XScale,.YScale/2)
Line .Shadow,(0,0)-(.XScale,.YScale/2),RGB(8,0,7),BF
End With
Next
Dim As Any Ptr floor=ImageCreate(800,600)
Line floor,(0,0)-(800,600),RGB(8,0,7),BF
For x As Integer=0 To 80
For y As Integer=0 To 60
If (x \ 4 + y \ 4) Mod 2 > 0 Then
switch=1
Else
switch=0
End If
If switch=1 Then Line floor,(x*10,y*10)-(x*10+10,y*10+10),RGB(255,240,203),BF
If switch=0 Then Line floor,(x*10,y*10)-(x*10+10,y*10+10),RGB(8,0,7),BF
Next
Next
Do
Getmouse mx,my
Sleep 10,1
ScreenLock
Cls
For i As Integer=1 To cubes
With Cube(i)
.Angle1(1)=ATan2(mx-.X,my-.Y)
.Angle2(1)=ATan2(mx-.X-.XScale,my-.Y)
.Angle3(1)=ATan2(mx-.X-.XScale,my-.Y-.YScale)
.Angle4(1)=ATan2(mx-.X,my-.Y-.YScale)
Line (.X-ScrollX,.Y-ScrollY)-(mx-Sin(.Angle1(1))*Light_Range-ScrollX,my-Cos(.Angle1(1))*Light_Range-ScrollY),RGB(0,0,255)
Line (.X+.XScale-ScrollX,.Y-ScrollY)-(mx-Sin(.Angle2(1))*Light_Range-ScrollX,my-Cos(.Angle2(1))*Light_Range-ScrollY),RGB(0,0,255)
Line (.X+.XScale-ScrollX,.Y+.YScale-ScrollY)-(mx-Sin(.Angle3(1))*Light_Range-ScrollX,my-Cos(.Angle3(1))*Light_Range-ScrollY),RGB(0,0,255)
Line (.X-ScrollX,.Y+.YScale-ScrollY)-(mx-Sin(.Angle4(1))*Light_Range-ScrollX,my-Cos(.Angle4(1))*Light_Range-ScrollY),RGB(0,0,255)
'Line (mx-Sin(.Angle2(1))*Light_Range-ScrollX,my-Cos(.Angle2(1))*Light_Range-ScrollY)-(mx-Sin(.Angle1(1))*Light_Range-ScrollX,my-Cos(.Angle1(1))*Light_Range-ScrollY),RGB(0,0,255)
'Line (mx-Sin(.Angle3(1))*Light_Range-ScrollX,my-Cos(.Angle3(1))*Light_Range-ScrollY)-(mx-Sin(.Angle4(1))*Light_Range-ScrollX,my-Cos(.Angle4(1))*Light_Range-ScrollY),RGB(0,0,255)
'Line (mx-Sin(.Angle1(1))*Light_Range-ScrollX,my-Cos(.Angle1(1))*Light_Range-ScrollY)-(mx-Sin(.Angle4(1))*Light_Range-ScrollX,my-Cos(.Angle4(1))*Light_Range-ScrollY),RGB(0,0,255)
End With
Next
For i As Integer=1 To cubes
With Cube(i)
Line (.X-ScrollX,.Y-Scrolly)-(.X+.XScale-ScrollX,.Y+.YScale-ScrollY),RGB(0,0,255),B
End With
Next
Paint (mx,my),RGB(255,240,203),RGBA(0,0,255,255)
For i As Integer=1 To cubes
With Cube(i)
Line (.X-ScrollX,.Y-ScrollY)-(mx-Sin(.Angle1(1))*Light_Range-ScrollX,my-Cos(.Angle1(1))*Light_Range-ScrollY),RGB(8,0,7)
Line (.X+.XScale-ScrollX,.Y-ScrollY)-(mx-Sin(.Angle2(1))*Light_Range-ScrollX,my-Cos(.Angle2(1))*Light_Range-ScrollY),RGB(8,0,7)
Line (.X+.XScale-ScrollX,.Y+.YScale-ScrollY)-(mx-Sin(.Angle3(1))*Light_Range-ScrollX,my-Cos(.Angle3(1))*Light_Range-ScrollY),RGB(8,0,7)
Line (.X-ScrollX,.Y+.YScale-ScrollY)-(mx-Sin(.Angle4(1))*Light_Range-ScrollX,my-Cos(.Angle4(1))*Light_Range-ScrollY),RGB(8,0,7)
End With
Next
Put (0,0),floor,Alpha,150
For i As Integer=1 To cubes
With Cube(i)
If .Roof=0 Then
Put(.X-Scrollx,.Y-Scrolly),Texture_Roof2,Trans
Else
Put(.X-Scrollx,.Y-Scrolly),Texture_Roof1,Trans
End If
If my>.Y+.YScale/2-ScrollY Then
Put (.X-Scrollx,.Y-Scrolly),.Shadow,Alpha,128
Else
Put (.X-Scrollx,.Y+.YScale/2-Scrolly),.Shadow,Alpha,128
End If
End With
Next
ScreenUnlock
Loop Until Inkey=Chr(27)
End
I made the shadows more transparent and included some roof-textures and something like a fake-normalmap (?) for them: