Isometric shadow casting light.
-
- Posts: 3906
- Joined: Jan 01, 2009 7:03
- Location: Australia
Re: Isometric shadow casting light.
Your window size is too big for my computer screen which is 1366x768 maximum. I find 1280x600 is the biggest that still comes up ok as a window.
I also notice you use numbers instead of the labels scrw and scrh in the code which means the display will not adapt to changing these constant values.
.
I also notice you use numbers instead of the labels scrw and scrh in the code which means the display will not adapt to changing these constant values.
.
Re: Isometric shadow casting light.
The only thing that doesn't use the constants is the grid filler, but setting the constants to 640,480 still works.
Re: Isometric shadow casting light.
It looks good Boromir.
I get 33 fps here with the mouse amongst the cubes.(1280 by 1024)
If I set 1024,768 or 640,480 it double the fps.
Looks very professional.
Good luck with your game programming.
I get 33 fps here with the mouse amongst the cubes.(1280 by 1024)
If I set 1024,768 or 640,480 it double the fps.
Looks very professional.
Good luck with your game programming.
-
- Posts: 3906
- Joined: Jan 01, 2009 7:03
- Location: Australia
Re: Isometric shadow casting light.
You are right it does work. When I saw the 1024 value I thought I would have to change other parts of your code to fit a 640x480 window and that resulted in a crash.Boromir wrote:The only thing that doesn't use the constants is the grid filler, but setting the constants to 640,480 still works.
Code: Select all
For i As Integer=-700 To 1024 Step 20
Line back,(0,i)-(scrw,i+scrw/2),RGB(150,0,100)
Next
When I changed this,
Code: Select all
for y as integer=0 to 3'9
For x As Integer=0 To 6 '10
I wonder if the alpha thingy is applicable to all modern computers such as android tablets. I surmised that most simple games would now be played on tablets or mobile phones.
Now what about two or more light sources?
.
Re: Isometric shadow casting light.
Can fb compile on android? or were you talking about some other mobile language and graphics library.BasicCoder2 wrote: I wonder if the alpha thingy is applicable to all modern computers such as android tablets. I surmised that most simple games would now be played on tablets or mobile phones.
Now what about two or more light sources?
Here is two light sources.
Code: Select all
'2d Quad-Shadow caster
'by Ezekiel Gutierrez and Leopardpm
'
'requires light.bmpx 800x400 for the glow
'
const scrw=1280
const scrh=1024
Dim Shared As Integer lw=800,lh=400
const pi = 4 * atn(1)
dim shared as double DtoR = pi / 180 ' degrees * DtoR = radians
type point2d
x as integer
y as integer
end type
type box
p1 as point2d
p2 as point2d
p3 as point2d
p4 as point2d
p5 as point2d
declare sub draw(img as any ptr)
end type
Public Sub Lined(p1 as point2d,p2 as point2d,xs as integer,ys as integer,sw as integer,sh as integer,byref p3 as point2d,byref edge as integer)
dim as Single xnew,ynew
Dim As Single dx,dy,x3,y3,x2,y2,ynum,den,num,numadd,xinc1,xinc2,yinc1,yinc2
x3=p1.x:y3=p1.y
x2=p2.x:y2=p2.y
dx = abs(x2 - x3):dy = abs(y2 - y3):xnew = x3:ynew = y3
if x2 >= x3 Then xinc1 = 1:xinc2 = 1 else xinc1 = -1:xinc2 = -1
if y2 >= y3 Then yinc1 = 1:yinc2 = 1 else yinc1 = -1:yinc2 = -1
if dx >= dy Then _
xinc1 = 0:yinc2 = 0:den = dx:num = dx / 2:numadd = dy Else _
xinc2 = 0:yinc1 = 0:den = dy:num = dy / 2:numadd = dx
While 1
if xnew>xs+sw orelse xnew>scrw then edge=3:p3.x=xnew:p3.y=ynew:exit sub
if xnew<xs orelse xnew<0 then edge=2:p3.x=xnew:p3.y=ynew:exit sub
if ynew>ys+sh orelse ynew>scrh then edge=4:p3.x=xnew:p3.y=ynew:exit sub
if ynew<ys orelse ynew<0 then edge=1:p3.x=xnew:p3.y=ynew:exit sub
num += numadd
if num >= den Then num -= den:xnew += xinc1:ynew += yinc1
xnew += xinc2:ynew += yinc2
Wend
End Sub
public function getslope(p1 as point2d, _
p2 as point2d) as integer
dim as integer xdif,ydif
xdif = p2.x - p1.x
ydif = p2.y - p1.y
return atan2(ydif, xdif)*(180 / pi)
end function
public sub makepoint(angle as integer,plight as point2d, _
p1 as point2d, _
byref p2 as point2d,byref edge as integer)
p2.x=p1.x-(cos(angle*DtoR)*(200))
p2.y=p1.y-(sin(angle*DtoR)*(200))
lined(p1,p2,plight.x-(lw\2),plight.y-(lh\2),lw,lh,p2,edge)
end sub
declare sub shadowcast(box1 as box,plight as point2d,img as any ptr,col as integer)
screenres scrw,scrh,32
dim as box boxes(99)
Dim as point2d plight1,plight2
dim as integer slope1,slope2,slope3,slope4
for y as integer=0 to 9
For x As Integer=0 To 10
with boxes(x+(y*10))
.p1.x=100+(x*80) 'box
.p1.y=90 +(y*80)' co-ordinate 1
.p2.x=80+(x*80)'box
.p2.y=100+(y*80)' co-ordinate 2
.p3.x=120+(x*80)'box
.p3.y=100+(y*80)' co-ordinate 3
.p4.x=100+(x*80)'box
.p4.y=110+(y*80)' co-ordinate 4
.p5.x=100+(x*80)'(.p1.x+.p2.x+.p3.x+.p4.x)/4
.p5.y=100+(y*80)'(.p1.y+.p2.y+.p3.y+.p4.y)/4
end With
Next x
next y
'create light glow from 32 bit bitmap
dim as any ptr light1,light2,light
light=imagecreate(lw,lh)
light1=imagecreate(lw,lh)
light2=imagecreate(lw,lh)
bload "light.bmpx",light
'====================================
color rgb(255,255,255),rgb(0,0,0)
dim as any ptr back
back=imagecreate(scrw,scrh,rgb(0,0,0))
For i As Integer=0 To 1700 Step 20
Line back,(0,i)-(scrw,i-scrw/2),RGB(150,0,50)
Next
For i As Integer=-700 To 1024 Step 20
Line back,(0,i)-(scrw,i+scrw/2),RGB(150,0,100)
Next
dim as integer fps,frames
dim as double prevtime
prevtime=timer
plight2.x=200
plight2.y=200
Do
GetMouse plight1.x,plight1.y'put light.x and y at mouse
screenlock
Cls
Put (0,0),back,pset
Put light1,(0,0),light,PSet
Put light2,(0,0),light,pset
For i as integer=0 to UBound(boxes)
shadowcast(boxes(i),plight1,light1,i)'cast shadow
next i
for i as integer=0 to UBound(boxes)
shadowcast(boxes(i),plight2,light2,i)'cast shadow
next i
put (plight1.x-(lw\2),plight1.y-(lh\2)),light1,alpha
put (plight2.x-(lw\2),plight2.y-(lh\2)),light2,alpha
For i as Integer=0 To UBound(boxes)
boxes(i).draw(0)
next i
print "fps "+str(fps)
screenunlock
sleep 1
frames+=1
if timer-1>prevtime then fps=frames:frames=0:prevtime=timer
loop until multikey(1)
sub box.draw(img as any ptr)
'line img,(p1.x,p1.y)-(p2.x,p2.y),rgb(0,0,0)
'line img,(p2.x,p2.y)-(p4.x,p4.y),rgb(0,0,0)
'line img,(p3.x,p3.y)-(p4.x,p4.y),rgb(0,0,0)
'line img,(p3.x,p3.y)-(p1.x,p1.y),rgb(0,0,0)
line img,(p1.x,p1.y-20)-(p2.x,p2.y-20),rgb(255,0,0)
line img,(p2.x,p2.y-20)-(p2.x,p2.y),rgb(255,0,0)
line img,(p2.x,p2.y)-(p4.x,p4.y),rgb(255,0,0)
line img,(p3.x,p3.y)-(p4.x,p4.y),rgb(255,0,0)
line img,(p3.x,p3.y)-(p3.x,p3.y-20),rgb(255,0,0)
line img,(p3.x,p3.y-20)-(p1.x,p1.y-20),rgb(255,0,0)
line img,(p4.x,p4.y)-(p4.x,p4.y-20),rgb(255,0,0)
line img,(p2.x,p2.y-20)-(p4.x,p4.y-20),rgb(255,0,0)
line img,(p3.x,p3.y-20)-(p4.x,p4.y-20),rgb(255,0,0)
paint img,(p1.x+1,p1.y+3),rgb(50,0,0),rgb(255,0,0)
paint img,(p1.x-1,p1.y+3),rgb(100,0,0),rgb(255,0,0)
paint img,(p1.x,p1.y-1),rgb(255,0,0),rgb(255,0,0)
end sub
sub shadowcast(box1 as box,plight as point2d,img as any ptr,col as integer)
dim as point2d shad1,shad2
dim as integer slope1,slope2,slope3,slope4
dim as point2d ch1,ch2
dim as integer testval=-200
'calculate differences for each point
with box1
slope1=getslope(.p2,plight)'+180
slope2=getslope(.p4,plight)'+180
slope3=getslope(.p1,plight)'+180
slope4=getslope(.p3,plight)'+180
dim as integer k,k1,k2,k3,k4
if slope1>0 then k+=1:k1=1
if slope2>0 then k+=1:k2=1
if slope3>0 then k+=1:k3=1
if slope4>0 then k+=1:k4=1
if k>0 andalso k<4 andalso plight.x<(box1.p2.x+box1.p3.x)/2 then
if k1=1 then slope1-=360
if k2=1 then slope2-=360
if k3=1 then slope3-=360
if k4=1 then slope4-=360
end if
'===================================================
if slope1>testval then testval=slope1:ch1.x=.p2.x:ch1.y=.p2.y ':chx2=x:chy2=y2
if slope2>testval then testval=slope2:ch1.x=.p4.x:ch1.y=.p4.y ':chx2=x:chy2=y
if slope3>testval then testval=slope3:ch1.x=.p1.x:ch1.y=.p1.y ':chx2=x2:chy2=y2
if slope4>testval then testval=slope4:ch1.x=.p3.x:ch1.y=.p3.y ':chx2=x2:chy2=y
'testval=-1
if slope1<testval then testval=slope1:ch2.x=.p2.x:ch2.y=.p2.y
if slope2<testval then testval=slope2:ch2.x=.p4.x:ch2.y=.p4.y
if slope3<testval then testval=slope3:ch2.x=.p1.x:ch2.y=.p1.y
if slope4<testval then testval=slope4:ch2.x=.p3.x:ch2.y=.p3.y
'===================================================
end with
'use selected points
dim as integer s,edge1,edge2
s=getslope(ch1,plight)'get slope difference for one edge of the shadow
makepoint(s,plight,ch1,shad1,edge1)'create first point
s=getslope(ch2,plight)'get slope difference for the other edge
makepoint(s,plight,ch2,shad2,edge2)'create second point
dim as point2d p1=shad1,p2=ch1,p3=ch2,p4=shad2,p5=box1.p5
'draw shadow outline
p1.x-=plight.x-(lw/2):p1.y-=plight.y-(lh/2):p2.x-=plight.x-(lw/2):p2.y-=plight.y-(lh/2):p3.x-=plight.x-(lw/2):p3.y-=plight.y-(lh/2):p4.x-=plight.x-(lw/2):p4.y-=plight.y-(lh/2)
line img,(p1.x,p1.y)-(p2.x,p2.y),rgba(col,0,0,0)
line img,(p2.x,p2.y)-(p3.x,p3.y),rgba(col,0,0,0)
line img,(p4.x,p4.y)-(p3.x,p3.y),rgba(col,0,0,0)
if (edge2=1 AndAlso edge1=2) orelse (edge1=1 AndAlso edge2=2) orelse (edge1=4 andalso edge2=3) orelse (edge2=4 AndAlso edge1=3) then
line img,(p1.x,p1.y)-(p4.x,p1.y),rgba(col,0,0,0)
line img,(p4.x,p4.y)-(p4.x,p1.y),rgba(col,0,0,0)
elseif (edge2=1 andalso edge1=3) orelse (edge2=4 AndAlso edge1=2) orelse (edge1=1 andalso edge2=3) orelse (edge1=4 AndAlso edge2=2) then
line img,(p1.x,p1.y)-(p1.x,p4.y),rgba(col,0,0,0)
line img,(p4.x,p4.y)-(p1.x,p4.y),rgba(col,0,0,0)
else
line img,(p4.x,p4.y)-(p1.x,p1.y),rgba(col,0,0,0)
end if
'fill shadow outline
paint img,((p1.x+p2.x+p3.x+p4.x)/4, _
(p1.y+p2.y+p3.y+p4.y)/4),rgba(col,0,0,0),rgba(col,0,0,0)
'draw box
end sub
-
- Posts: 3906
- Joined: Jan 01, 2009 7:03
- Location: Australia
Re: Isometric shadow casting light.
Just talking in general about the platforms that most people now use.Boromir wrote:Can fb compile on android? or were you talking about some other mobile language and graphics library.
I nearly purchased a book showing how to use an android library to program android in Java. After flipping through the pages I thought no I am not going to find time or motivation to learn all that even though I had spent some time years ago with some simpler Java coding.
Looks like you have nailed it. Maybe less yellow? Real light brightens the colors already there. I did write a fading color algorithm for my raycasting dungeon code but can't find it. I think it ran a bit slow although using fast pixel reading and setting and trig tables it might have worked better. I remember in the early days fog was used to reduce the need to render distant scenes in a 3d engine.Here is two light sources.
.
Re: Isometric shadow casting light.
LOL! great job... but you missed the point... the purpose of the line drawing routine was not only to find the shadow point at the edge of the light box, BUT, to also draw the line itself...
I don't have a clue as to what all this stuff is doing... but I think it will become unnecessary if your 'lined' routine draws the shadow edge to the edge of the light box. You only need THREE total lines to define the pain area: the line formed between the two point on the object, then a line from each of those points to the edge of the light box rectangle (which 'lined' routine is doing, without currently psetting the points!). Once those three lines are drawn, then the paint command will automagically fill to the outer edge of the light box quickly without us having to do more calcs.
Code: Select all
'draw shadow outline
p1.x-=plight.x-(lw/2):p1.y-=plight.y-(lh/2):p2.x-=plight.x-(lw/2):p2.y-=plight.y-(lh/2):p3.x-=plight.x-(lw/2):p3.y-=plight.y-(lh/2):p4.x-=plight.x-(lw/2):p4.y-=plight.y-(lh/2)
line img,(p1.x,p1.y)-(p2.x,p2.y),rgba(col,0,0,0)
line img,(p2.x,p2.y)-(p3.x,p3.y),rgba(col,0,0,0)
line img,(p4.x,p4.y)-(p3.x,p3.y),rgba(col,0,0,0)
if (edge2=1 AndAlso edge1=2) orelse (edge1=1 AndAlso edge2=2) orelse (edge1=4 andalso edge2=3) orelse (edge2=4 AndAlso edge1=3) then
line img,(p1.x,p1.y)-(p4.x,p1.y),rgba(col,0,0,0)
line img,(p4.x,p4.y)-(p4.x,p1.y),rgba(col,0,0,0)
elseif (edge2=1 andalso edge1=3) orelse (edge2=4 AndAlso edge1=2) orelse (edge1=1 andalso edge2=3) orelse (edge1=4 AndAlso edge2=2) then
line img,(p1.x,p1.y)-(p1.x,p4.y),rgba(col,0,0,0)
line img,(p4.x,p4.y)-(p1.x,p4.y),rgba(col,0,0,0)
else
line img,(p4.x,p4.y)-(p1.x,p1.y),rgba(col,0,0,0)
end if
Re: Isometric shadow casting light.
Using freebasic's built in line function is much faster then pset-ing the points. I return the edge point from lined and use it with freebasic's line.leopardpm wrote:without currently psetting the points!
That other code is some leftovers I forgot to remove. ;)
Last edited by Boromir on Apr 02, 2017 1:23, edited 1 time in total.
Re: Isometric shadow casting light.
the basic optimizing I did in the previous program was:
(1) remove the CLS in the main loop as it was unnessary because you are 'putting' the whole screen each time anyways. (small improvement, maybe 2-3%)
(2) to replace the box drawing routine with putting an image! (major improvement here!)
BUT, when I did these things to your latest program, I only see about a 10% improvement... I think it is due to all that stuff in the shadowcast routine I talked about in previous post...
Other potential improvements are:
(1) ONLY call shadowcast routine for the boxes which are in the lightbox rectangle! This should be a major improvement when having alot of boxes around like in this example
(2) Instead of putting each box on top individually, make ANOTHER screen buffer and initialize it with all the boxes, then overlay that image to the screen... one BIG put is MUCH faster then 100 little puts.... this should also be incorporated into the final game: all the 'static' objects should have a separate buffer which is put once into the final scene.... this buffer 'can' be modified also with semi-dynamic objects, the only time this is not faster is when an object is ALWAYS moving. ONLY draw things if they have moved, if no movement then what is in this buffer is all ready to go!
Trying to unravel your code to look for other major optimizations.... your indentation scheme drives me a bit crazy - lol! each to their own!
Here is your code so far, with my optimizations and indenting changes... you need to rename your light box "light big.bmpx" as I kept your previous small one as well. Also, I made a BMP out of a screenshot of your boxes, so you need a file called "box.bmpx", tried to put it here (like you did) in google drive... don't know if this works:
https://drive.google.com/open?id=0BzzH8 ... Ww2dU1Zb2c
(1) remove the CLS in the main loop as it was unnessary because you are 'putting' the whole screen each time anyways. (small improvement, maybe 2-3%)
(2) to replace the box drawing routine with putting an image! (major improvement here!)
BUT, when I did these things to your latest program, I only see about a 10% improvement... I think it is due to all that stuff in the shadowcast routine I talked about in previous post...
Other potential improvements are:
(1) ONLY call shadowcast routine for the boxes which are in the lightbox rectangle! This should be a major improvement when having alot of boxes around like in this example
(2) Instead of putting each box on top individually, make ANOTHER screen buffer and initialize it with all the boxes, then overlay that image to the screen... one BIG put is MUCH faster then 100 little puts.... this should also be incorporated into the final game: all the 'static' objects should have a separate buffer which is put once into the final scene.... this buffer 'can' be modified also with semi-dynamic objects, the only time this is not faster is when an object is ALWAYS moving. ONLY draw things if they have moved, if no movement then what is in this buffer is all ready to go!
Trying to unravel your code to look for other major optimizations.... your indentation scheme drives me a bit crazy - lol! each to their own!
Here is your code so far, with my optimizations and indenting changes... you need to rename your light box "light big.bmpx" as I kept your previous small one as well. Also, I made a BMP out of a screenshot of your boxes, so you need a file called "box.bmpx", tried to put it here (like you did) in google drive... don't know if this works:
https://drive.google.com/open?id=0BzzH8 ... Ww2dU1Zb2c
Code: Select all
'2d Quad-Shadow caster
'by Ezekiel Gutierrez and Leopardpm
'
'requires light.bmpx 800x400 for the glow
'
const scrw=1280
const scrh=1024
Dim Shared As Integer lw=800,lh=400
const pi = 4 * atn(1)
dim shared as double DtoR = pi / 180 ' degrees * DtoR = radians
type point2d
x as integer
y as integer
end type
type box
p1 as point2d
p2 as point2d
p3 as point2d
p4 as point2d
p5 as point2d
declare sub draw(img as any ptr)
end type
Public Sub Lined(p1 as point2d,p2 as point2d,xs as integer,ys as integer,sw as integer,sh as integer,byref p3 as point2d,byref edge as integer)
dim as Single xnew,ynew
Dim As Single dx,dy,x3,y3,x2,y2,ynum,den,num,numadd,xinc1,xinc2,yinc1,yinc2
x3=p1.x:y3=p1.y
x2=p2.x:y2=p2.y
dx = abs(x2 - x3):dy = abs(y2 - y3):xnew = x3:ynew = y3
if x2 >= x3 Then xinc1 = 1:xinc2 = 1 else xinc1 = -1:xinc2 = -1
if y2 >= y3 Then yinc1 = 1:yinc2 = 1 else yinc1 = -1:yinc2 = -1
if dx >= dy Then _
xinc1 = 0:yinc2 = 0:den = dx:num = dx / 2:numadd = dy Else _
xinc2 = 0:yinc1 = 0:den = dy:num = dy / 2:numadd = dx
While 1
if xnew>xs+sw orelse xnew>scrw then edge=3:p3.x=xnew:p3.y=ynew:exit sub
if xnew<xs orelse xnew<0 then edge=2:p3.x=xnew:p3.y=ynew:exit sub
if ynew>ys+sh orelse ynew>scrh then edge=4:p3.x=xnew:p3.y=ynew:exit sub
if ynew<ys orelse ynew<0 then edge=1:p3.x=xnew:p3.y=ynew:exit sub
num += numadd
if num >= den Then num -= den:xnew += xinc1:ynew += yinc1
xnew += xinc2:ynew += yinc2
Wend
End Sub
public function getslope(p1 as point2d, _
p2 as point2d) as integer
dim as integer xdif,ydif
xdif = p2.x - p1.x
ydif = p2.y - p1.y
return atan2(ydif, xdif)*(180 / pi)
end function
public sub makepoint(angle as integer,plight as point2d, _
p1 as point2d, _
byref p2 as point2d,byref edge as integer)
p2.x=p1.x-(cos(angle*DtoR)*(200))
p2.y=p1.y-(sin(angle*DtoR)*(200))
lined(p1,p2,plight.x-(lw\2),plight.y-(lh\2),lw,lh,p2,edge)
end sub
declare sub shadowcast(box1 as box,plight as point2d,img as any ptr,col as integer)
screenres scrw,scrh,32
dim as box boxes(99)
Dim as point2d plight1,plight2
dim as integer slope1,slope2,slope3,slope4
for y as integer=0 to 9
For x As Integer=0 To 10
with boxes(x+(y*10))
.p1.x=100+(x*80) 'box
.p1.y=90 +(y*80)' co-ordinate 1
.p2.x=80+(x*80)'box
.p2.y=100+(y*80)' co-ordinate 2
.p3.x=120+(x*80)'box
.p3.y=100+(y*80)' co-ordinate 3
.p4.x=100+(x*80)'box
.p4.y=110+(y*80)' co-ordinate 4
.p5.x=100+(x*80)'(.p1.x+.p2.x+.p3.x+.p4.x)/4
.p5.y=100+(y*80)'(.p1.y+.p2.y+.p3.y+.p4.y)/4
end With
Next x
next y
'create light glow from 32 bit bitmap
dim as any ptr light1,light2,light
light=imagecreate(lw,lh)
light1=imagecreate(lw,lh)
light2=imagecreate(lw,lh)
bload "light big.bmpx",light
' load box image
dim as any ptr boxer
boxer=imagecreate(41,41)
bload "box.bmpx",boxer
'====================================
color rgb(255,255,255),rgb(0,0,0)
dim as any ptr back
back=imagecreate(scrw,scrh,rgb(0,0,0))
For i As Integer=0 To 1700 Step 20
Line back,(0,i)-(scrw,i-scrw/2),RGB(150,0,50)
Next
For i As Integer=-700 To 1024 Step 20
Line back,(0,i)-(scrw,i+scrw/2),RGB(150,0,100)
Next
dim as integer fps,frames
dim as double prevtime
prevtime=timer
plight2.x=200
plight2.y=200
Do
GetMouse plight1.x,plight1.y'put light.x and y at mouse
screenlock
'Cls
Put (0,0),back,pset
Put light1,(0,0),light,PSet
Put light2,(0,0),light,Pset
For i as integer=0 to UBound(boxes)
shadowcast(boxes(i),plight1,light1,i)'cast shadow
next i
for i as integer=0 to UBound(boxes)
shadowcast(boxes(i),plight2,light2,i)'cast shadow
next i
put (plight1.x-(lw\2),plight1.y-(lh\2)),light1,alpha
put (plight2.x-(lw\2),plight2.y-(lh\2)),light2,alpha
dim as integer maxboxes = UBound(boxes)
dim as integer maxy = int(maxboxes/10)
dim as integer maxx = maxboxes - (maxy*10)
for y as integer = 0 to maxy
for x as integer = 0 to maxx
put (80+(x*80),70+(y*80)), boxer, alpha
next x
next y
For i as Integer=0 To UBound(boxes)
'dim as integer y = int(i/10)
'dim as integer x = i - (y*10)
'put (80+(x*80),70+(y*80)), boxer, alpha
'(x+(y*10))
'boxes(i).draw(0)
next i
locate 1,1:print "fps ";fps
screenunlock
sleep 1
frames+=1
if timer-1>prevtime then fps=frames:frames=0:prevtime=timer
loop until multikey(1)
sub box.draw(img as any ptr)
line img,(p1.x,p1.y-20)-(p2.x,p2.y-20),rgb(255,0,0)
line img,(p2.x,p2.y-20)-(p2.x,p2.y),rgb(255,0,0)
line img,(p2.x,p2.y)-(p4.x,p4.y),rgb(255,0,0)
line img,(p3.x,p3.y)-(p4.x,p4.y),rgb(255,0,0)
line img,(p3.x,p3.y)-(p3.x,p3.y-20),rgb(255,0,0)
line img,(p3.x,p3.y-20)-(p1.x,p1.y-20),rgb(255,0,0)
line img,(p4.x,p4.y)-(p4.x,p4.y-20),rgb(255,0,0)
line img,(p2.x,p2.y-20)-(p4.x,p4.y-20),rgb(255,0,0)
line img,(p3.x,p3.y-20)-(p4.x,p4.y-20),rgb(255,0,0)
paint img,(p1.x+1,p1.y+3),rgb(50,0,0),rgb(255,0,0)
paint img,(p1.x-1,p1.y+3),rgb(100,0,0),rgb(255,0,0)
paint img,(p1.x,p1.y-1),rgb(255,0,0),rgb(255,0,0)
end sub
sub shadowcast(box1 as box,plight as point2d,img as any ptr,col as integer)
dim as point2d shad1,shad2
dim as integer slope1,slope2,slope3,slope4
dim as point2d ch1,ch2
dim as integer testval=-200
'calculate differences for each point
with box1
slope1=getslope(.p2,plight)'+180
slope2=getslope(.p4,plight)'+180
slope3=getslope(.p1,plight)'+180
slope4=getslope(.p3,plight)'+180
dim as integer k,k1,k2,k3,k4
if slope1>0 then k+=1:k1=1
if slope2>0 then k+=1:k2=1
if slope3>0 then k+=1:k3=1
if slope4>0 then k+=1:k4=1
if k>0 andalso k<4 andalso plight.x<(box1.p2.x+box1.p3.x)/2 then
if k1=1 then slope1-=360
if k2=1 then slope2-=360
if k3=1 then slope3-=360
if k4=1 then slope4-=360
end if
'===================================================
if slope1>testval then testval=slope1:ch1.x=.p2.x:ch1.y=.p2.y ':chx2=x:chy2=y2
if slope2>testval then testval=slope2:ch1.x=.p4.x:ch1.y=.p4.y ':chx2=x:chy2=y
if slope3>testval then testval=slope3:ch1.x=.p1.x:ch1.y=.p1.y ':chx2=x2:chy2=y2
if slope4>testval then testval=slope4:ch1.x=.p3.x:ch1.y=.p3.y ':chx2=x2:chy2=y
'testval=-1
if slope1<testval then testval=slope1:ch2.x=.p2.x:ch2.y=.p2.y
if slope2<testval then testval=slope2:ch2.x=.p4.x:ch2.y=.p4.y
if slope3<testval then testval=slope3:ch2.x=.p1.x:ch2.y=.p1.y
if slope4<testval then testval=slope4:ch2.x=.p3.x:ch2.y=.p3.y
'===================================================
end with
'use selected points
dim as integer s,edge1,edge2
s=getslope(ch1,plight)'get slope difference for one edge of the shadow
makepoint(s,plight,ch1,shad1,edge1)'create first point
s=getslope(ch2,plight)'get slope difference for the other edge
makepoint(s,plight,ch2,shad2,edge2)'create second point
dim as point2d p1=shad1,p2=ch1,p3=ch2,p4=shad2,p5=box1.p5
'draw shadow outline
p1.x-=plight.x-(lw/2):p1.y-=plight.y-(lh/2):p2.x-=plight.x-(lw/2):p2.y-=plight.y-(lh/2):p3.x-=plight.x-(lw/2):p3.y-=plight.y-(lh/2):p4.x-=plight.x-(lw/2):p4.y-=plight.y-(lh/2)
line img,(p1.x,p1.y)-(p2.x,p2.y),rgba(col,0,0,0)
line img,(p2.x,p2.y)-(p3.x,p3.y),rgba(col,0,0,0)
line img,(p4.x,p4.y)-(p3.x,p3.y),rgba(col,0,0,0)
if (edge2=1 AndAlso edge1=2) orelse (edge1=1 AndAlso edge2=2) orelse (edge1=4 andalso edge2=3) orelse (edge2=4 AndAlso edge1=3) then
line img,(p1.x,p1.y)-(p4.x,p1.y),rgba(col,0,0,0)
line img,(p4.x,p4.y)-(p4.x,p1.y),rgba(col,0,0,0)
elseif (edge2=1 andalso edge1=3) orelse (edge2=4 AndAlso edge1=2) orelse (edge1=1 andalso edge2=3) orelse (edge1=4 AndAlso edge2=2) then
line img,(p1.x,p1.y)-(p1.x,p4.y),rgba(col,0,0,0)
line img,(p4.x,p4.y)-(p1.x,p4.y),rgba(col,0,0,0)
else
line img,(p4.x,p4.y)-(p1.x,p1.y),rgba(col,0,0,0)
end if
'fill shadow outline
paint img,((p1.x+p2.x+p3.x+p4.x)/4, _
(p1.y+p2.y+p3.y+p4.y)/4),rgba(col,0,0,0),rgba(col,0,0,0)
end sub
Last edited by leopardpm on Apr 02, 2017 1:15, edited 1 time in total.
Re: Isometric shadow casting light.
faster than psetting, yes... but it is slower than directly manipulating memory.... you have seen the fast pset and point functions around, right? if not, i will upload...Boromir wrote:Using freebasic's built in line function is much faster then pset-ing the points. I return the edge point from lined and use it with freebasic's line.leopardpm wrote:without currently psetting the points!
seriously, you are drawing the line twice right now: once in your lined routine then again with the line command - that is surely slower than just you doing it from the start!
Re: Isometric shadow casting light.
here is my Fast graphics library (not completed at all):
FastGraphicRoutines.bas
and here is a sample useage:
using just the fast PSET routine will not be a good optimization... if you read under future optimizations of the Fast Line Routine, it describes how to make Fast Pset faster when used repeatedly (like consecutive ponts in a line)
FastGraphicRoutines.bas
Code: Select all
'
' Fast Graphics Routines
'
' some adapted from: http://members.chello.at/~easyfilter/bresenham.html
'
' These routines use direct drawing to the image buffer (or screen)
' - They ALWAYS assume 32bbp images/screen
' - Color is always assumed as a ULONG for 32/64 bit compatability
' - Boundry Checking is OPTIONAL! Ignore it at your own peril!
'
' all these routines expect a few global variables set:
'
' targetBuffer = ptr to the correct buffer, either image or screen
' (note: this is NOT the address of the first scanline!)
' targetWidth = width of image
' targetHeight = height of image
' targetPitch = # of bytes in each scanline(row) of buffer
' targetAddress = ptr to the start of the first scanline of image
' BoundryCheck = either 0(off) or 1(on) - default is OFF!)
'
'
' routines marked:
' (X) are completed - might need more optimizing...
' (O) are partially - not all the parameter options working yet...
'
' Basic Routines:
'
' (X) CLS
' = f_Cls(color)
' (X) PSET(x,y),color
' = f_Pset(x,y,color)
'
' (X) POINT(x,y)
' = f_Point(x,y)
' note: this is a function, it return a ulong color value
'
' (O) LINE(x,y)-(x1,y1),color,[BF]
' = f_Line(x,y,x1,y1,color,B,F,AA,thickness)
' note: B (box) and F (fill) are either 0 or 1
' AA = 1 to turn on Anti-Aliasing, default is OFF (No FB Equivalent)
' Supports Line Thickness (No FB Equivalent)
' don't know what to do with 'even' line thicknesses
'
' (O) CIRCLE(x,y),radius,color,,,,[F]
' = f_Circle(x,y,radius,color,F)
'
' ( ) CIRCLE(x,y),radius,color,,,aspect,[F]
' = f_Oval(x,y,x1,y1,color,F)
' note: draws an oval in bounding rectangle
'
' ( ) BEZIER - No FB equivalent
' = f_Bezier(x,y,x1,y1,x2,y2,AA)
'
'
'
' These are special Sprite Routines: (No FB Equivalent)
' They require special loading and initializing routines before use
'
' CUSTOM SPRITE ROUTINES:
' Load Sprite (from TileSheet File, either 32bit PNG or 32bit BMP)
' = f_Sprite_Load(filename)
' note: this is a function, it returns the Sprite #
'
' Sprite Info (from a previously loaded sprite, or converted IsoVox Sprite)
' = f_Sprite_Info(sprite#)
' note: this is a function, it returns a special UDT in the form below
'
' Draw Sprite with Layered Depth
' = f_Draw(sprite#, x, y, depth, animation#, frame#, facing)
' note: This draws using BOTH the ALPHA Channel & MAGIC PINK, use either or both
' Depth variable is from 0-255 (255=foreground, 0=background), will overdraw anything behind it
' The Depth variable is stored in the screen Alpha byte of each pixel of the sprite
' Since the alpha byte is unused, we use it to store the depth layers for sprites and Terrain
'
'
' CUSTOM ISOVOX SPRITE ROUTINES:
' Load IsoVoxSprite (from .IVS file)
' = f_IsoVox_Load(filename)
' note: this is a function, it returns the IsoVoxSprite #
'
' IsoVox Sprite Info (from loaded IsoVox Sprite)
' = f_IsoVox_Info(IsoVoxSprite#)
' note: this is a function, it returns a special UDT in the form below
'
' Pre-Calc Facings for an IsoVoxSprite
' = f_IsoVox_Facing(IsoVoxSprite#, facings)
' note: this pre-generate the 'rotation flags' for each facing, speeds up drawing
' facings are usually (4, 6, 8, 16, 24, 32)
'
' Convert IsoVoxSprite to Regular Sprite
' = f_IsoVox_Convert(IsoVoxSprite#, facings)
' note: this is a function, it returns the Sprite #
' This is done to obtain maximum speed(at expense of memory),
' drawing an IsoVoxSprite is much slower than a regular one
' # of facings is how many directions are desired, usually (4, 6, 8, 16, 24, 32)
' # of facings greatly affects memory usage
' ALSO: This actually creates a Sprite TileSheet which can then be saved...
'
' Draw IsoVox Sprite
' = f_IsoVox_Draw(IsoVoxSprite#, x, y, depth, animation#, frame#, facing)
' note: IsoVox Sprites are naturally 'Alpha masked'
' The x,y origin is determined in the sprite itelf,
' usually in center of the lowest voxel level
' This means it draws vastly differently from the
' typical upper-left hand corner of regular Sprites
'
'
' UDT for Sprite Information:
'
' type SPRITEINFO
' as ubyte spritetype 'either standard (0) or IsoVox (1)
' as ushort width ' x
' as ushort height ' y
' as ushort depth ' z (for IsoVox, otherwise set to 0)
' as ubyte NumOfAnimatione
' as ubyte NumOfFacings
' as ubyte NumOfFrames ' # of frames in each animation
' end type
'
'
'
' COMING: special map and terrain routines for: 2D, 2.5D(iso), and IsoVox terrain
'
'
'==============================================================================
function BCheck(x as integer, y as integer) as integer
if x<0 then return 1
if y<0 then return 2
if x>(targetWidth-1) then return 3
if y>(targetHeight-1) then return 4
return 0
end function
sub f_cls(Col as ulong= &h00000000)
' In graphics modes, if you want to clear the entire screen to color 0,
' it can be faster using Clear to write zeroes to the screen memory than calling Cls.
'
' targetBuffer = ptr to the correct buffer, either image or screen
' (note: this is NOT the address of the first scanline!)
' targetWidth = width of image
' targetHeight = height of image
' targetPitch = # of bytes in each scanline(row) of buffer
' targetAddress = ptr to the start of the first scanline of image
' BoundryCheck = either 0(off) or 1(on) - default is OFF!)
Dim scrbuf As Byte Ptr
Dim As Integer scrhei, scrpitch, scrsize
scrbuf = ScreenPtr: Assert( scrbuf <> 0 )
ScreenInfo( , scrhei, , , scrpitch )
' currently just clears screen to black, not a color....
'
scrsize = scrhei * scrpitch
screenlock
Clear *scrbuf, 0, scrsize
screenunlock
end sub
sub memsetCLS(Col as ulong= &h00000000)
screenlock
memset targetAddress, 0, targetWidth * targetHeight * SizeOf(UInteger)
screenunlock
end sub
SUB ClS32()
' Dim As Integer scrhei, scrpitch, scrsize
' ScreenInfo( , scrhei, , , scrpitch )
' scrsize = scrhei * scrpitch
' 480000 = screen size of 800 x 600 ONLY!
' this routine doesn't want to work....
' at least needs the setup like the below ClsSSE routine...
' SCREENLOCK
' ASM
' CLD
' MOV EDI , [VideoPtr]
' Mov ECX, 480000
' Mov EAX,0
' rep stosd
' END ASM
' SCREENUNLOCK
END SUB
Sub SSEcls Naked()
Asm
call _fb_GfxScreenPtr@0
push eax
mov eax, [___fb_gfx]
mov edx, [eax+&h1C] ' height of screen
mov eax, [eax+&h28] ' pitch of screen (bytes per row)
mul edx
mov ecx, eax
pop eax
mov edx, ecx
xorps xmm0, xmm0 ' we ignore the background color here because otherwise the code would be too complex for this example
and ecx, &hFFFFFF00
jz ClearSmall
ClearLargeLoop: ' clear 256 bytes at once
movdqa [eax], xmm0
movdqa [eax+&h10], xmm0
movdqa [eax+&h20], xmm0
movdqa [eax+&h30], xmm0
movdqa [eax+&h40], xmm0
movdqa [eax+&h50], xmm0
movdqa [eax+&h60], xmm0
movdqa [eax+&h70], xmm0
movdqa [eax+&h80], xmm0
movdqa [eax+&h90], xmm0
movdqa [eax+&hA0], xmm0
movdqa [eax+&hB0], xmm0
movdqa [eax+&hC0], xmm0
movdqa [eax+&hD0], xmm0
movdqa [eax+&hE0], xmm0
movdqa [eax+&hF0], xmm0
add eax, &h100
sub ecx, &h100
jnz ClearLargeLoop
ClearSmall:
shr dl, 4 ' using al means we don't need to use edx and execute "and edx, &hFF" - shr-ing it allows us to use "dec" later because FB image scanlines are always 16-byte aligned
jz Finished
ClearSmallLoop:
movdqa [eax], xmm0
add eax, 16
dec dl
jnz ClearSmallLoop
Finished:
ret
End Asm
End Sub
#macro f_Pset(x , y , c)
if BoundaryCheck=1 then
if BCheck(x,y)=0 then
dim as ulong ptr pixel = targetAddress + (targetPitch * y)
pixel[x] = c
end if
else
dim as ulong ptr pixel = targetAddress + (targetPitch * y)
pixel[x] = c
end if
#endmacro
function f_Point(x as integer, y as integer) as ulong
if BoundaryCheck=1 then
if BCheck(x,y)<>0 then return 0
end if
dim as ulong ptr pixel = targetAddress + (targetPitch * y)
return *(pixel+x)
end function
sub f_Line( x1 as integer, y1 as integer,_
x2 as integer, y2 as integer,_
Col as ulong,_
B as integer = 0,_
F as integer = 0,_
AA as integer = 0,_
thickness as integer = 1)
'
' Haven't incorporated B, F, AA, or thickness yet...
'
' ALSO, to optimize, need to convert it to pointers instead of x,y values
' ie: to inc the y, instead add the TargetPitch to the pointer
' to inc the x, just inc the pointer
' then plot point from here instead of f_Pset routine/macro
'
' I can't decypher this block of C code...
' looks really compact and efficient Bresenham's line....
'
' dim as integer dx, dy, sx, sy, er1, er2
'void plotLine(int x0, int y0, int x1, int y1)
'{
' int dx = abs(x1-x0), sx = x0<x1 ? 1 : -1;
' int dy = -abs(y1-y0), sy = y0<y1 ? 1 : -1;
' int err = dx+dy, e2; /* error value e_xy */
'
' for(;;){ /* loop */
' setPixel(x0,y0);
' if (x0==x1 && y0==y1) break;
' e2 = 2*err;
' if (e2 >= dy) { err += dy; x0 += sx; } /* e_xy+e_x > 0 */
' if (e2 <= dx) { err += dx; y0 += sy; } /* e_xy+e_y < 0 */
' }
'}
'
dim As integer x,y,deltax, deltay, xinc1, xinc2, yinc1, yinc2
dim As integer den, num, numadd, numpixels, curpixel
'================================== Bresenham's Setup
deltax = abs(x2 - x1) ' // The difference between the x's
deltay = abs(y2 - y1) ' // The difference between the y's
x = x1 : y = y1 ' // Start x,y Off at the first pixel
If (x2 >= x1) Then ' // The x-values are increasing
xinc1 = 1 : xinc2 = 1
Else ' // The x-values are decreasing
xinc1 = -1 : xinc2 = -1
End If
If (y2 >= y1) Then ' // The y-values are increasing
yinc1 = 1 : yinc2 = 1
Else ' // The y-values are decreasing
yinc1 = -1 : yinc2 = -1
End If
If (deltax >= deltay) Then ' // There is at least one x-VALUE For every y-VALUE
xinc1 = 0 : yinc2 = 0 ' // Don't change the x when numerator >= denominator, Don't change the y for every iteration
den = deltax : num = deltax / 2 : numadd = deltay
numpixels = deltax ' // There are more x-values than y-values
Else ' // There is at least one y-VALUE For every x-VALUE
xinc2 = 0 : yinc1 = 0 ' // Don't change the x for every iteration, Don't change the y when numerator >= denominator
den = deltay : num = deltay / 2 : numadd = deltax
numpixels = deltay ' // There are more y-values than x-values
End If
'================================== make the line
For curpixel = 0 to numpixels
f_pset(x, y, Col) ' // draw the current pixel
num += numadd ' // Increase the numerator by the top of the fraction
If (num >= den) Then ' // Check If numerator >= denominator
num -= den ' // Calculate the new numerator VALUE
x += xinc1 ' // Change the x As appropriate
y += yinc1 ' // Change the y As appropriate
EndIf
x += xinc2 ' // Change the x As appropriate
y += yinc2 ' // Change the y As appropriate
Next
end sub
Sub f_Circle(x0 As Integer, y0 As Integer , radius As Integer, Col As ulong, fill as integer = 0)
' 8 Quadrant Midpoint Circle Algorithm, version 06-07-2015
' from Wikipedia page: Midpoint circle algorithm
' modified with FILL routine by LeopardPM
'
' compile with: fbc -s console OR compile with: fbc -s gui
Dim As Integer x = abs(radius), y = 0 , e = 1 - x , Total = 0
dim as integer xf1, xf2, yf1, yf2
' do a big rectangle boundary check first, if boundary checking is enabled
' and if no problem, then turn off Boundary Checking until end of routine
'
' Oops! Boundary checking currently doesn't work because plotting directly....
' only checks big rectangle....
'
if BoundaryCheck = 1 then
Total = BCheck(x0-radius,y0-radius) + BCheck(x0+radius,y0+radius)
if Total = 0 then
BoundaryCheck = 0 : Total = 999
else ' failed rect boiunds check..
return
end if
end if
if fill = 0 then
dim as ulong ptr pixel1, pixel2
While(x >= y)
' f_Pset((x0 + x), (y0 + y), col) ' this section might also be optimized
' f_Pset((x0 - x), (y0 + y), col) ' by directly using pointers, instead of creating them 8 times
' f_Pset((x0 + x), (y0 - y), col)
' f_Pset((x0 - x), (y0 - y), col)
'
' f_Pset((x0 + y), (y0 + x), col)
' f_Pset((x0 - y), (y0 + x), col)
' f_Pset((x0 + y), (y0 - x), col)
' f_Pset((x0 - y), (y0 - x), col)
'
xf1 = x0 + x
xf2 = x0 - x
yf1 = y0 + y
yf2 = y0 - y
pixel1 = targetAddress + (targetPitch * yf1)
pixel2 = targetAddress + (targetPitch * yf2)
pixel1[xf1] = col
pixel1[xf2] = col
pixel2[xf1] = col
pixel2[xf2] = col
xf1 = x0 + y
xf2 = x0 - y
yf1 = y0 + x
yf2 = y0 - x
pixel1 = targetAddress + (targetPitch * yf1)
pixel2 = targetAddress + (targetPitch * yf2)
pixel1[xf1] = col
pixel1[xf2] = col
pixel2[xf1] = col
pixel2[xf2] = col
y += 1
If e <= 0 Then
e += (y shl 1) + 1
Else
x -= 1 : e += ((y - x) shl 1) + 1
End If
Wend
else
dim as ulong ptr pixel1, pixel2
dim as integer xChanged = 1
While(x >= y)
' this portion draws horizontal lines between the 8 points on the circle
' don't know why it is so slow????
'
' I think it is repeatedly drawing lines when the y value(x value?) doesn't
' change on the point on the circle (ie: near the top and bottom)
' fixed that, saved about 12% time, but STILL slow!!!!
xf1 = x0 + x : xf2 = x0 - x
pixel1 = targetAddress + (targetPitch * (y0 + y))
pixel2 = targetAddress + (targetPitch * (y0 - y))
for xpnt as integer = xf2 to xf1
pixel1[xpnt] = col
pixel2[xpnt] = col
next xpnt
if xChanged = 1 then
xf1 = x0 + y : xf2 = x0 - y
pixel1 = targetAddress + (targetPitch * (y0 + x))
pixel2 = targetAddress + (targetPitch * (y0 - x))
for xpnt as integer = xf2 to xf1
pixel1[xpnt] = col
pixel2[xpnt] = col
next xpnt
end if
y += 1
If e <= 0 Then
xChanged = 0
e += (y shl 1) + 1
Else
x -= 1 : e += ((y - x) shl 1) + 1
xChanged = 1
End If
Wend
end if
if Total = 999 then BoundaryCheck = 1' turn BoundaryCheck back on...
End Sub
'void plotQuadBezierSeg(int x0, int y0, int x1, int y1, int x2, int y2)
'{
' int sx = x2-x1, sy = y2-y1;
' long xx = x0-x1, yy = y0-y1, xy; /* relative values for checks */
' double dx, dy, err, cur = xx*sy-yy*sx; /* curvature */
'
' assert(xx*sx <= 0 && yy*sy <= 0); /* sign of gradient must not change */
'
' if (sx*(long)sx+sy*(long)sy > xx*xx+yy*yy) { /* begin with longer part */
' x2 = x0; x0 = sx+x1; y2 = y0; y0 = sy+y1; cur = -cur; /* swap P0 P2 */
' }
' if (cur != 0) { /* no straight line */
' xx += sx; xx *= sx = x0 < x2 ? 1 : -1; /* x step direction */
' yy += sy; yy *= sy = y0 < y2 ? 1 : -1; /* y step direction */
' xy = 2*xx*yy; xx *= xx; yy *= yy; /* differences 2nd degree */
' if (cur*sx*sy < 0) { /* negated curvature? */
' xx = -xx; yy = -yy; xy = -xy; cur = -cur;
' }
' dx = 4.0*sy*cur*(x1-x0)+xx-xy; /* differences 1st degree */
' dy = 4.0*sx*cur*(y0-y1)+yy-xy;
' xx += xx; yy += yy; err = dx+dy+xy; /* error 1st step */
' do {
' setPixel(x0,y0); /* plot curve */
' if (x0 == x2 && y0 == y2) return; /* last pixel -> curve finished */
' y1 = 2*err < dx; /* save value for test of y step */
' if (2*err > dy) { x0 += sx; dx -= xy; err += dy += yy; } /* x step */
' if ( y1 ) { y0 += sy; dy -= xy; err += dx += xx; } /* y step */
' } while (dy < dx ); /* gradient negates -> algorithm fails */
' }
' plotLine(x0,y0, x2,y2); /* plot remaining part to end */
'}
Code: Select all
'==============================================================================
'============================= HEADER =======================================
'==============================================================================
const SCR_Width = 800, SCR_Height = 600
screenres SCR_Width, SCR_Height, 32
' targetBuffer = ptr to the correct buffer, either image or screen
' (note: this is NOT the address of the first scanline!)
' targetWidth = width of image
' targetHeight = height of image
' targetPitch = # of bytes in each scanline(row) of buffer
' targetAddress = ptr to the start of the first scanline of image
' BoundryCheck = either 0(off) or 1(on) - default is OFF!)
dim shared as any ptr targetBuffer
dim shared as any ptr targetAddress
dim shared as integer targetWidth, targetHeight, targetPitch, BoundaryCheck=0
screeninfo targetWidth,targetHeight,,,targetPitch
targetAddress = screenPtr
' including CRT.bi for memory functions...
#Include "crt.bi"
#include once "FastGraphicRoutines.bas"
#define RGBA_R( c ) ( cuint( c ) Shr 16 And 255 )
#define RGBA_G( c ) ( cuint( c ) Shr 8 And 255 )
#define RGBA_B( c ) ( cuint( c ) And 255 )
#define RGBA_A( c ) ( cuint( c ) Shr 24 )
' all set to write directly to screen
'
'f_Line( 50,50, 200,100,rgb(255,0,0))
''
BoundaryCheck = 0
f_Circle(400,300,100,rgb(0,255,0),0)
sleep
'f_cls(0)
'locate 0,10 : ? "Cleared"
'sleep
cls
locate 12,50 : print "Hit a key to Start performing Tests"
sleep
'
' Comparison and example of CLS
'
dim as double t1, t2, reg, FastNB, FastB, direct
cls
locate 2,2 : print "Testing regular CLS: ";
t1 = timer
for r as integer = 1 to 1000
screenlock
cls
screenunlock
next r
t2 = timer
reg = t2-t1
cls
locate 2,2 : print "Testing f_Cls:"
t1 = timer
for r as integer = 1 to 1000
screenlock
f_cls(0)
screenunlock
next r
t2 = timer
fastB = t2-t1
cls
locate 2,2 : print "Testing sseCls:"
t1 = timer
for r as integer = 1 to 1000
screenlock
'ClS32 not work
SSEcls
screenunlock
next r
t2 = timer
fastNB = t2-t1
cls
locate 2,2 : print "Testing memsetCls:"
t1 = timer
for r as integer = 1 to 1000
screenlock
memsetCLS
screenunlock
next r
t2 = timer
direct = t2-t1
cls
locate 3,2 : print "RESULTS: CLS"
locate 4,2 : print using " CLS ##.###";reg
locate 5,2 : print using " fCLS ##.###";FastB
locate 6,2 : print using " sseCLS ##.###";FastNB
locate 7,2 : print using " memsetCLS ##.###";direct
locate 9,2 : print "HIT A KEY TO CONTINUE"
sleep
'
' Comparison and example of PSET, no boundry check
'
cls
locate 2,2 : print "Testing regular PSET: ";
dim as ulong col = rgb(255,0,0)
dim as ulong col1,col2,col3
t1 = timer
for r as integer = 1 to 100
screenlock
for y as integer = 50 to 550
for x as integer = 50 to 750
pset(x,y),col
next x
next y
screenunlock
next r
t2 = timer
reg = t2-t1
cls
locate 2,2 : print "Testing macro f_Pset(B):"
BoundaryCheck = 1
col = rgb(0,0,255)
t1 = timer
for r as integer = 1 to 100
screenlock
for y as integer = 50 to 550
for x as integer = 50 to 750
f_pset(x,y,col)
next x
next y
screenunlock
next r
t2 = timer
fastB = t2-t1
cls
locate 2,2 : print "Testing macro f_Pset(NB):"
BoundaryCheck = 0
col = rgb(0,255,255)
t1 = timer
for r as integer = 1 to 100
screenlock
for y as integer = 50 to 550
for x as integer = 50 to 750
f_pset(x,y,col)
next x
next y
screenunlock
next r
t2 = timer
fastNB = t2-t1
cls
locate 2,2 : print "Testing direct(NB):"
BoundaryCheck = 0
col = rgb(0,255,0)
t1 = timer
for r as integer = 1 to 100
screenlock
for y as integer = 50 to 550
for x as integer = 50 to 750
dim as ulong ptr pixel = targetAddress + (targetPitch * y)
pixel[x] = (col)
next x
next y
screenunlock
next r
t2 = timer
direct = t2-t1
cls
locate 3,2 : print "RESULTS: Pset"
locate 4,2 : print using " PSET ##.###";reg
locate 5,2 : print using " fPset-B ##.###";FastB
locate 6,2 : print using " fPset-NB ##.###";FastNB
locate 7,2 : print using " Direct ##.###";direct
locate 9,2 : print "HIT A KEY TO CONTINUE"
sleep
cls
locate 2,2 : print "Testing regular POINT:"
pset (400,300), rgb(255,255,255)
t1 = timer
for r as integer = 1 to 100
screenlock
for y as integer = 50 to 550
for x as integer = 50 to 750
col = point(400,300)
next x
next y
screenunlock
next r
t2 = timer
reg = t2-t1
cls
locate 2,2 : print "Testing f_Point(B):"
BoundaryCheck = 1
pset (400,300), rgb(0,255,0)
t1 = timer
for r as integer = 1 to 100
screenlock
for y as integer = 50 to 550
for x as integer = 50 to 750
col1 = f_Point(400,300)
next x
next y
screenunlock
next r
t2 = timer
fastB = t2-t1
cls
locate 2,2 : print "Testing f_Point(NB):"
BoundaryCheck = 0
pset (400,300), rgb(255,0,0)
t1 = timer
for r as integer = 1 to 100
screenlock
for y as integer = 50 to 550
for x as integer = 50 to 750
col2 = f_Point(400,300)
next x
next y
screenunlock
next r
t2 = timer
fastNB = t2-t1
cls
locate 2,2 : print "Testing Direct:"
BoundaryCheck = 0
pset (400,300), rgb(255,255,0)
t1 = timer
for r as integer = 1 to 100
screenlock
for y as integer = 50 to 550
for x as integer = 50 to 750
dim as ulong ptr pixel = targetAddress + (targetPitch * 300)
col3 = *(pixel+400)
next x
next y
screenunlock
next r
t2 = timer
direct = t2-t1
cls
locate 3,2 : print "RESULTS: Point"
locate 4,2 : print using " POINT took ##.### and the color was: &";reg;hex(col,8)
locate 5,2 : print using " fPoint-B took ##.### and the color was: &";fastB;hex(col1,8)
locate 6,2 : print using " fPoint-NB took ##.### and the color was: &";fastNB;hex(col2,8)
locate 7,2 : print using " Direct took ##.### and the color was: &";direct;hex(col3,8)
locate 9,2 : print "HIT A KEY TO CONTINUE"
sleep
cls
locate 2,2 : print "Testing regular CIRCLE, no fill:"
col = rgb(255,0,0)
t1 = timer
for t as integer = 1 to 1000
screenlock
for r as integer = 50 to 250
circle(400,300),r,col
next r
screenunlock
next t
t2 = timer
reg = t2-t1
cls
locate 2,2 : print "Testing f_Circle(B), no fill:"
BoundaryCheck = 1
col = rgb(0,0,255)
t1 = timer
for t as integer = 1 to 1000
screenlock
for r as integer = 50 to 250
f_Circle(400,300,r,col,0)
next r
screenunlock
next t
t2 = timer
fastB = t2-t1
cls
locate 2,2 : print "Testing f_Circle(NB), no fill:"
BoundaryCheck = 0
col = rgb(0,255,0)
t1 = timer
for t as integer = 1 to 1000
screenlock
for r as integer = 50 to 250
f_Circle(400,300,r,col,0)
next r
screenunlock
next t
t2 = timer
fastNB = t2-t1
cls
locate 3,2 : print "RESULTS: Circles, not filled"
locate 4,2 : print using " CIRCLE took ##.###";reg
locate 5,2 : print using " fCircle-B took ##.###";fastB
locate 6,2 : print using " fCircle-NB took ##.###";fastNB
locate 9,2 : print "HIT A KEY TO CONTINUE"
sleep
cls
locate 2,2 : print "Testing regular CIRCLE, fill:"
col = rgb(255,0,0)
t1 = timer
for t as integer = 1 to 100
screenlock
for r as integer = 50 to 250
circle(400,300),r,col,,,,F
next r
screenunlock
next t
t2 = timer
reg = t2-t1
cls
locate 2,2 : print "Testing f_Circle(B), fill:"
BoundaryCheck = 1
col = rgb(0,0,255)
t1 = timer
for t as integer = 1 to 100
screenlock
for r as integer = 50 to 250
f_Circle(400,300,r,col,1)
next r
screenunlock
next t
t2 = timer
fastB = t2-t1
cls
locate 2,2 : print "Testing f_Circle(NB), fill:"
BoundaryCheck = 0
col = rgb(0,255,0)
t1 = timer
for t as integer = 1 to 100
screenlock
for r as integer = 50 to 250
f_Circle(400,300,r,col,1)
next r
screenunlock
next t
t2 = timer
fastNB = t2-t1
cls
locate 3,2 : print "RESULTS: Circles, filled"
locate 4,2 : print using "FILLED: CIRCLE took ##.###";reg
locate 5,2 : print using " fCircle-B took ##.###";fastB
locate 6,2 : print using " fCircle-NB took ##.###";fastNB
locate 9,2 : print "HIT A KEY TO CONTINUE"
sleep
end
Re: Isometric shadow casting light.
I'll have to look into you library and see if I can get it going.
Re: Isometric shadow casting light.
question:
in the shadowcast routine, you calculate the slopes to all 4 corners of the object to figure out which two corner points to use for the shadow polygon. Then you re-calculate these same to points again before your makepoint routine... why not just save/retrieve the slopes already calc'd... the getslope routine is a slow one with the whole "atan2(ydif, xdif)*(180 / pi)" going on (I hate the slowness of the higher order maths...)
I am confused as to what the vars 'edge1' and 'edge2' are for....
Having trouble understanding what your edge variables are doing in the 'lined' routine.... - it's messin' with my mo-jo man! Just trying to stick in a pset into the lined routine but can't figure out where/how.... blowin' ma lil mind!
in the shadowcast routine, you calculate the slopes to all 4 corners of the object to figure out which two corner points to use for the shadow polygon. Then you re-calculate these same to points again before your makepoint routine... why not just save/retrieve the slopes already calc'd... the getslope routine is a slow one with the whole "atan2(ydif, xdif)*(180 / pi)" going on (I hate the slowness of the higher order maths...)
I am confused as to what the vars 'edge1' and 'edge2' are for....
don't spend alot of time on it, is far from completed.... was just compiling from alot of different sources to get one library going....I'll have to look into you library and see if I can get it going.
Having trouble understanding what your edge variables are doing in the 'lined' routine.... - it's messin' with my mo-jo man! Just trying to stick in a pset into the lined routine but can't figure out where/how.... blowin' ma lil mind!
Re: Isometric shadow casting light.
Yes, I got that one implemented.leopardpm wrote: (1) ONLY call shadowcast routine for the boxes which are in the lightbox rectangle! This should be a major improvement when having alot of boxes around like in this example
The image loading for the boxes isn't really speeding up the shadow caster. That would be part of the game or whatever you end up using this for. I'm going to put this in my RTS. :)
Code: Select all
'2d Quad-Shadow caster
'by Ezekiel Gutierrez and Leopardpm
'
'requires light.bmpx 800x400 for the glow
'
const scrw=1280
const scrh=1024
const pi = 4 * atn(1)
dim shared as double DtoR = pi / 180 ' degrees * DtoR = radians
type point2d
x as integer
y as integer
end type
type box
p1 as point2d
p2 as point2d
p3 as point2d
p4 as point2d
p5 as point2d
declare sub draw(img as any ptr)
end type
Public Sub Lined(p1 as point2d,p2 as point2d,xs as integer,ys as integer,sw as integer,sh as integer,byref p3 as point2d,byref edge as integer)
dim as Single xnew,ynew
Dim As Single dx,dy,x3,y3,x2,y2,ynum,den,num,numadd,xinc1,xinc2,yinc1,yinc2
x3=p1.x:y3=p1.y
x2=p2.x:y2=p2.y
dx = abs(x2 - x3):dy = abs(y2 - y3):xnew = x3:ynew = y3
if x2 >= x3 Then xinc1 = 1:xinc2 = 1 else xinc1 = -1:xinc2 = -1
if y2 >= y3 Then yinc1 = 1:yinc2 = 1 else yinc1 = -1:yinc2 = -1
if dx >= dy Then _
xinc1 = 0:yinc2 = 0:den = dx:num = dx / 2:numadd = dy Else _
xinc2 = 0:yinc1 = 0:den = dy:num = dy / 2:numadd = dx
While 1
if xnew>xs+sw then edge=3:p3.x=xnew:p3.y=ynew:exit sub
if xnew<xs then edge=2:p3.x=xnew:p3.y=ynew:exit sub
if ynew>ys+sh then edge=4:p3.x=xnew:p3.y=ynew:exit sub
if ynew<ys then edge=1:p3.x=xnew:p3.y=ynew:exit sub
num += numadd
if num >= den Then num -= den:xnew += xinc1:ynew += yinc1
xnew += xinc2:ynew += yinc2
Wend
End Sub
public function getslope(p1 as point2d, _
p2 as point2d) as integer
dim as integer xdif,ydif
xdif = p2.x - p1.x
ydif = p2.y - p1.y
return atan2(ydif, xdif)*(180 / pi)
end function
public sub makepoint(angle as integer,plight as point2d, _
p1 as point2d, _
byref p2 as point2d,byref edge as Integer,lw As Integer,lh As Integer)
p2.x=p1.x-(Cos(angle*DtoR)*(200))
p2.y=p1.y-(Sin(angle*DtoR)*(200))
lined(p1,p2,plight.x-(lw\2),plight.y-(lh\2),lw,lh,p2,edge)
end sub
declare sub shadowcast(box1 as box,plight as point2d,img as any ptr,col as Integer,lw As Integer,lh As Integer)
screenres scrw,scrh,32
dim as box boxes(99)
Dim as point2d plight1,plight2
Dim As Integer lw=800,lh=400,lwh=400,lhh=200
for y as integer=0 to 9
For x As Integer=0 To 10
with boxes(x+(y*10))
.p1.x=100+(x*80) 'box
.p1.y=90 +(y*80)' co-ordinate 1
.p2.x=80+(x*80)'box
.p2.y=100+(y*80)' co-ordinate 2
.p3.x=120+(x*80)'box
.p3.y=100+(y*80)' co-ordinate 3
.p4.x=100+(x*80)'box
.p4.y=110+(y*80)' co-ordinate 4
.p5.x=100+(x*80)'(.p1.x+.p2.x+.p3.x+.p4.x)/4
.p5.y=100+(y*80)'(.p1.y+.p2.y+.p3.y+.p4.y)/4
end With
Next x
next y
'create light glow from 32 bit bitmap
dim as any ptr light1,light2,light
light=imagecreate(lw,lh)
light1=imagecreate(lw,lh)
light2=imagecreate(lw,lh)
bload "light.bmpx",light
'====================================
color rgb(255,255,255),rgb(0,0,0)
dim as any ptr back
back=imagecreate(scrw,scrh,rgb(0,0,0))
For i As Integer=0 To 1700 Step 20
Line back,(0,i)-(scrw,i-scrw/2),RGB(150,0,50)
Next
For i As Integer=-700 To 1024 Step 20
Line back,(0,i)-(scrw,i+scrw/2),RGB(150,0,100)
Next
dim as integer fps,frames
dim as double prevtime
prevtime=timer
plight2.x=200
plight2.y=200
Do
GetMouse plight1.x,plight1.y'put light.x and y at mouse
screenlock
Put (0,0),back,pset
Put light1,(0,0),light,PSet
Put light2,(0,0),light,pset
For i as integer=0 to UBound(boxes)
If boxes(i).p5.x > plight1.x-lwh Andalso boxes(i).p5.x < plight1.x+lwh Andalso boxes(i).p5.y > plight1.y-lhh Andalso boxes(i).p5.y < plight1.y+lhh Then
shadowcast(boxes(i),plight1,light1,i,lw,lh)'cast shadow
End If
next i
for i as integer=0 to UBound(boxes)
If boxes(i).p5.x > plight2.x-lwh Andalso boxes(i).p5.x < plight2.x+lwh Andalso boxes(i).p5.y > plight2.y-lhh Andalso boxes(i).p5.y < plight2.y+lhh Then
shadowcast(boxes(i),plight2,light2,i,lw,lh)'cast shadow
End if
next i
put (plight1.x-lwh,plight1.y-lhh),light1,alpha
put (plight2.x-lwh,plight2.y-lhh),light2,alpha
For i as Integer=0 To UBound(boxes)
boxes(i).draw(0)
next i
Locate 1,1
print "fps "+str(fps)
screenunlock
sleep 1
frames+=1
if timer-1>prevtime then fps=frames:frames=0:prevtime=timer
loop until multikey(1)
sub box.draw(img as any ptr)
'line img,(p1.x,p1.y)-(p2.x,p2.y),rgb(0,0,0)
'line img,(p2.x,p2.y)-(p4.x,p4.y),rgb(0,0,0)
'line img,(p3.x,p3.y)-(p4.x,p4.y),rgb(0,0,0)
'line img,(p3.x,p3.y)-(p1.x,p1.y),rgb(0,0,0)
line img,(p1.x,p1.y-20)-(p2.x,p2.y-20),rgb(255,0,0)
line img,(p2.x,p2.y-20)-(p2.x,p2.y),rgb(255,0,0)
line img,(p2.x,p2.y)-(p4.x,p4.y),rgb(255,0,0)
line img,(p3.x,p3.y)-(p4.x,p4.y),rgb(255,0,0)
line img,(p3.x,p3.y)-(p3.x,p3.y-20),rgb(255,0,0)
line img,(p3.x,p3.y-20)-(p1.x,p1.y-20),rgb(255,0,0)
line img,(p4.x,p4.y)-(p4.x,p4.y-20),rgb(255,0,0)
line img,(p2.x,p2.y-20)-(p4.x,p4.y-20),rgb(255,0,0)
line img,(p3.x,p3.y-20)-(p4.x,p4.y-20),rgb(255,0,0)
paint img,(p1.x+1,p1.y+3),rgb(50,0,0),rgb(255,0,0)
paint img,(p1.x-1,p1.y+3),rgb(100,0,0),rgb(255,0,0)
paint img,(p1.x,p1.y-1),rgb(255,0,0),rgb(255,0,0)
end sub
sub shadowcast(box1 as box,plight as point2d,img as any ptr,col as Integer,lw As Integer,lh As integer)
dim as point2d shad1,shad2
dim as integer slope1,slope2,slope3,slope4
dim as point2d ch1,ch2
dim as integer testval=-200
'calculate differences for each point
with box1
slope1=getslope(.p2,plight)'+180
slope2=getslope(.p4,plight)'+180
slope3=getslope(.p1,plight)'+180
slope4=getslope(.p3,plight)'+180
dim as integer k,k1,k2,k3,k4
if slope1>0 then k+=1:k1=1
if slope2>0 then k+=1:k2=1
if slope3>0 then k+=1:k3=1
if slope4>0 then k+=1:k4=1
if k>0 andalso k<4 andalso plight.x<(box1.p2.x+box1.p3.x)/2 then
if k1=1 then slope1-=360
if k2=1 then slope2-=360
if k3=1 then slope3-=360
if k4=1 then slope4-=360
end if
'===================================================
if slope1>testval then testval=slope1:ch1.x=.p2.x:ch1.y=.p2.y ':chx2=x:chy2=y2
if slope2>testval then testval=slope2:ch1.x=.p4.x:ch1.y=.p4.y ':chx2=x:chy2=y
if slope3>testval then testval=slope3:ch1.x=.p1.x:ch1.y=.p1.y ':chx2=x2:chy2=y2
if slope4>testval then testval=slope4:ch1.x=.p3.x:ch1.y=.p3.y ':chx2=x2:chy2=y
'testval=-1
if slope1<testval then testval=slope1:ch2.x=.p2.x:ch2.y=.p2.y
if slope2<testval then testval=slope2:ch2.x=.p4.x:ch2.y=.p4.y
if slope3<testval then testval=slope3:ch2.x=.p1.x:ch2.y=.p1.y
if slope4<testval then testval=slope4:ch2.x=.p3.x:ch2.y=.p3.y
'===================================================
end with
'use selected points
dim as integer s,edge1,edge2
s=getslope(ch1,plight)'get slope difference for one edge of the shadow
makepoint(s,plight,ch1,shad1,edge1,lw,lh)'create first point
s=getslope(ch2,plight)'get slope difference for the other edge
makepoint(s,plight,ch2,shad2,edge2,lw,lh)'create second point
dim as point2d p1=shad1,p2=ch1,p3=ch2,p4=shad2,p5=box1.p5
'draw shadow outline
p1.x-=plight.x-(lw/2):p1.y-=plight.y-(lh/2):p2.x-=plight.x-(lw/2):p2.y-=plight.y-(lh/2):p3.x-=plight.x-(lw/2):p3.y-=plight.y-(lh/2):p4.x-=plight.x-(lw/2):p4.y-=plight.y-(lh/2)
Line img,(p1.x,p1.y)-(p2.x,p2.y),rgba(col,0,0,0)
Line img,(p2.x,p2.y)-(p3.x,p3.y),rgba(col,0,0,0)
Line img,(p4.x,p4.y)-(p3.x,p3.y),rgba(col,0,0,0)
'fill shadow outline
paint img,((p1.x+p2.x+p3.x+p4.x)/4, _
(p1.y+p2.y+p3.y+p4.y)/4),rgba(col,0,0,0),rgba(col,0,0,0)
'draw box
end sub
Re: Isometric shadow casting light.
Removed edge vars and made it only calculate 4 times.leopardpm wrote:question:
in the shadowcast routine, you calculate the slopes to all 4 corners of the object to figure out which two corner points to use for the shadow polygon. Then you re-calculate these same to points again before your makepoint routine... why not just save/retrieve the slopes already calc'd... the getslope routine is a slow one with the whole "atan2(ydif, xdif)*(180 / pi)" going on (I hate the slowness of the higher order maths...)
I am confused as to what the vars 'edge1' and 'edge2' are for....
don't spend alot of time on it, is far from completed.... was just compiling from alot of different sources to get one library going....I'll have to look into you library and see if I can get it going.
Having trouble understanding what your edge variables are doing in the 'lined' routine.... - it's messin' with my mo-jo man! Just trying to stick in a pset into the lined routine but can't figure out where/how.... blowin' ma lil mind!
Code: Select all
'2d Quad-Shadow caster
'by Ezekiel Gutierrez and Leopardpm
'
'requires light.bmpx 800x400 for the glow
'
const scrw=1280
const scrh=1024
const pi = 4 * atn(1)
dim shared as double DtoR = pi / 180 ' degrees * DtoR = radians
type point2d
x as integer
y as integer
end type
type box
p1 as point2d
p2 as point2d
p3 as point2d
p4 as point2d
p5 as point2d
declare sub draw(img as any ptr)
end type
Public Sub Lined(p1 as point2d,p2 as point2d,xs as integer,ys as integer,sw as integer,sh as integer,byref p3 as point2d)
dim as Single xnew,ynew
Dim As Single dx,dy,x3,y3,x2,y2,ynum,den,num,numadd,xinc1,xinc2,yinc1,yinc2
x3=p1.x:y3=p1.y
x2=p2.x:y2=p2.y
dx = abs(x2 - x3):dy = abs(y2 - y3):xnew = x3:ynew = y3
if x2 >= x3 Then xinc1 = 1:xinc2 = 1 else xinc1 = -1:xinc2 = -1
if y2 >= y3 Then yinc1 = 1:yinc2 = 1 else yinc1 = -1:yinc2 = -1
if dx >= dy Then _
xinc1 = 0:yinc2 = 0:den = dx:num = dx / 2:numadd = dy Else _
xinc2 = 0:yinc1 = 0:den = dy:num = dy / 2:numadd = dx
While 1
if xnew>xs+sw then p3.x=xnew:p3.y=ynew:exit sub
if xnew<xs then p3.x=xnew:p3.y=ynew:exit sub
if ynew>ys+sh then p3.x=xnew:p3.y=ynew:exit sub
if ynew<ys then p3.x=xnew:p3.y=ynew:exit sub
num += numadd
if num >= den Then num -= den:xnew += xinc1:ynew += yinc1
xnew += xinc2:ynew += yinc2
Wend
End Sub
public function getslope(p1 as point2d, _
p2 as point2d) as integer
dim as integer xdif,ydif
xdif = p2.x - p1.x
ydif = p2.y - p1.y
return atan2(ydif, xdif)*(180 / pi)
end function
public sub makepoint(angle as integer,plight as point2d, _
p1 as point2d, _
byref p2 as point2d,lw As Integer,lh As Integer)
p2.x=p1.x-(Cos(angle*DtoR)*(200))
p2.y=p1.y-(Sin(angle*DtoR)*(200))
lined(p1,p2,plight.x-(lw\2),plight.y-(lh\2),lw,lh,p2)
end sub
declare sub shadowcast(box1 as box,plight as point2d,img as any ptr,col as Integer,lw As Integer,lh As Integer)
screenres scrw,scrh,32
dim as box boxes(99)
Dim as point2d plight1,plight2
Dim As Integer lw=800,lh=400,lwh=400,lhh=200
for y as integer=0 to 9
For x As Integer=0 To 10
with boxes(x+(y*10))
.p1.x=100+(x*80) 'box
.p1.y=90 +(y*80)' co-ordinate 1
.p2.x=80+(x*80)'box
.p2.y=100+(y*80)' co-ordinate 2
.p3.x=120+(x*80)'box
.p3.y=100+(y*80)' co-ordinate 3
.p4.x=100+(x*80)'box
.p4.y=110+(y*80)' co-ordinate 4
.p5.x=100+(x*80)'(.p1.x+.p2.x+.p3.x+.p4.x)/4
.p5.y=100+(y*80)'(.p1.y+.p2.y+.p3.y+.p4.y)/4
end With
Next x
next y
'create light glow from 32 bit bitmap
dim as any ptr light1,light2,light
light=imagecreate(lw,lh)
light1=imagecreate(lw,lh)
light2=imagecreate(lw,lh)
bload "light.bmpx",light
'====================================
color rgb(255,255,255),rgb(0,0,0)
dim as any ptr back
back=imagecreate(scrw,scrh,rgb(0,0,0))
For i As Integer=0 To 1700 Step 20
Line back,(0,i)-(scrw,i-scrw/2),RGB(150,0,50)
Next
For i As Integer=-700 To 1024 Step 20
Line back,(0,i)-(scrw,i+scrw/2),RGB(150,0,100)
Next
dim as integer fps,frames
dim as double prevtime
prevtime=timer
plight2.x=200
plight2.y=200
Do
GetMouse plight1.x,plight1.y'put light.x and y at mouse
screenlock
Put (0,0),back,pset
Put light1,(0,0),light,PSet
Put light2,(0,0),light,pset
For i as integer=0 to UBound(boxes)
If boxes(i).p5.x > plight1.x-lwh Andalso boxes(i).p5.x < plight1.x+lwh Andalso boxes(i).p5.y > plight1.y-lhh Andalso boxes(i).p5.y < plight1.y+lhh Then
shadowcast(boxes(i),plight1,light1,i,lw,lh)'cast shadow
End If
next i
for i as integer=0 to UBound(boxes)
If boxes(i).p5.x > plight2.x-lwh Andalso boxes(i).p5.x < plight2.x+lwh Andalso boxes(i).p5.y > plight2.y-lhh Andalso boxes(i).p5.y < plight2.y+lhh Then
shadowcast(boxes(i),plight2,light2,i,lw,lh)'cast shadow
End if
next i
put (plight1.x-lwh,plight1.y-lhh),light1,alpha
put (plight2.x-lwh,plight2.y-lhh),light2,alpha
For i as Integer=0 To UBound(boxes)
boxes(i).draw(0)
next i
Locate 1,1
print "fps "+str(fps)
screenunlock
sleep 1
frames+=1
if timer-1>prevtime then fps=frames:frames=0:prevtime=timer
loop until multikey(1)
sub box.draw(img as any ptr)
'line img,(p1.x,p1.y)-(p2.x,p2.y),rgb(0,0,0)
'line img,(p2.x,p2.y)-(p4.x,p4.y),rgb(0,0,0)
'line img,(p3.x,p3.y)-(p4.x,p4.y),rgb(0,0,0)
'line img,(p3.x,p3.y)-(p1.x,p1.y),rgb(0,0,0)
line img,(p1.x,p1.y-20)-(p2.x,p2.y-20),rgb(255,0,0)
line img,(p2.x,p2.y-20)-(p2.x,p2.y),rgb(255,0,0)
line img,(p2.x,p2.y)-(p4.x,p4.y),rgb(255,0,0)
line img,(p3.x,p3.y)-(p4.x,p4.y),rgb(255,0,0)
line img,(p3.x,p3.y)-(p3.x,p3.y-20),rgb(255,0,0)
line img,(p3.x,p3.y-20)-(p1.x,p1.y-20),rgb(255,0,0)
line img,(p4.x,p4.y)-(p4.x,p4.y-20),rgb(255,0,0)
line img,(p2.x,p2.y-20)-(p4.x,p4.y-20),rgb(255,0,0)
line img,(p3.x,p3.y-20)-(p4.x,p4.y-20),rgb(255,0,0)
paint img,(p1.x+1,p1.y+3),rgb(50,0,0),rgb(255,0,0)
paint img,(p1.x-1,p1.y+3),rgb(100,0,0),rgb(255,0,0)
paint img,(p1.x,p1.y-1),rgb(255,0,0),rgb(255,0,0)
end sub
sub shadowcast(box1 as box,plight as point2d,img as any ptr,col as Integer,lw As Integer,lh As integer)
dim as point2d shad1,shad2
dim as integer slope1,slope2,slope3,slope4
dim as point2d ch1,ch2
dim as integer testval=-200,testval2
'calculate differences for each point
with box1
slope1=getslope(.p2,plight)'+180
slope2=getslope(.p4,plight)'+180
slope3=getslope(.p1,plight)'+180
slope4=getslope(.p3,plight)'+180
dim as integer k,k1,k2,k3,k4
if slope1>0 then k+=1:k1=1
if slope2>0 then k+=1:k2=1
if slope3>0 then k+=1:k3=1
if slope4>0 then k+=1:k4=1
if k>0 andalso k<4 andalso plight.x<(box1.p2.x+box1.p3.x)/2 then
if k1=1 then slope1-=360
if k2=1 then slope2-=360
if k3=1 then slope3-=360
if k4=1 then slope4-=360
end if
'===================================================
if slope1>testval then testval=slope1:ch1=.p2 ':chx2=x:chy2=y2
if slope2>testval then testval=slope2:ch1=.p4 ':chx2=x:chy2=y
if slope3>testval then testval=slope3:ch1=.p1 ':chx2=x2:chy2=y2
if slope4>testval then testval=slope4:ch1=.p3 ':chx2=x2:chy2=y
testval2=testval
if slope1<testval2 then testval2=slope1:ch2=.p2
if slope2<testval2 then testval2=slope2:ch2=.p4
if slope3<testval2 then testval2=slope3:ch2=.p1
if slope4<testval2 then testval2=slope4:ch2=.p3
'===================================================
end with
'use selected points
makepoint(testval,plight,ch1,shad1,lw,lh)'create first point
makepoint(testval2,plight,ch2,shad2,lw,lh)'create second point
dim as point2d p1=shad1,p2=ch1,p3=ch2,p4=shad2,p5=box1.p5
'draw shadow outline
p1.x-=plight.x-(lw/2):p1.y-=plight.y-(lh/2):p2.x-=plight.x-(lw/2):p2.y-=plight.y-(lh/2):p3.x-=plight.x-(lw/2):p3.y-=plight.y-(lh/2):p4.x-=plight.x-(lw/2):p4.y-=plight.y-(lh/2)
Line img,(p1.x,p1.y)-(p2.x,p2.y),rgba(col,0,0,0)
Line img,(p2.x,p2.y)-(p3.x,p3.y),rgba(col,0,0,0)
Line img,(p4.x,p4.y)-(p3.x,p3.y),rgba(col,0,0,0)
'fill shadow outline
paint img,((p1.x+p2.x+p3.x+p4.x)/4, _
(p1.y+p2.y+p3.y+p4.y)/4),rgba(col,0,0,0),rgba(col,0,0,0)
'draw box
end sub