Isometric shadow casting light.

Game development specific discussions.
Post Reply
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Isometric shadow casting light.

Post by BasicCoder2 »

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.
.
Boromir
Posts: 463
Joined: Apr 30, 2015 19:28
Location: Oklahoma,U.S., Earth,Solar System
Contact:

Re: Isometric shadow casting light.

Post by Boromir »

The only thing that doesn't use the constants is the grid filler, but setting the constants to 640,480 still works.
dodicat
Posts: 7976
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Isometric shadow casting light.

Post by dodicat »

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.
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Isometric shadow casting light.

Post by BasicCoder2 »

Boromir wrote:The only thing that doesn't use the constants is the grid filler, but setting the constants to 640,480 still works.
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.

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
Although you have 9x10 cubes the 640,480 window can only display 7x4 of them and the graphic routines clip them without crashing the system.

When I changed this,

Code: Select all

for y as integer=0 to 3'9
   For x As Integer=0 To 6 '10
The light was no longer visible. I guess I need to study your code :)

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?

.
Boromir
Posts: 463
Joined: Apr 30, 2015 19:28
Location: Oklahoma,U.S., Earth,Solar System
Contact:

Re: Isometric shadow casting light.

Post by Boromir »

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?
Can fb compile on android? or were you talking about some other mobile language and graphics library.

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
BasicCoder2
Posts: 3906
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Isometric shadow casting light.

Post by BasicCoder2 »

Boromir wrote:Can fb compile on android? or were you talking about some other mobile language and graphics library.
Just talking in general about the platforms that most people now use.
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.
Here is two light sources.
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.
.
leopardpm
Posts: 1795
Joined: Feb 28, 2009 20:58

Re: Isometric shadow casting light.

Post by leopardpm »

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...

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
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.
Boromir
Posts: 463
Joined: Apr 30, 2015 19:28
Location: Oklahoma,U.S., Earth,Solar System
Contact:

Re: Isometric shadow casting light.

Post by Boromir »

leopardpm wrote:without currently psetting the points!
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.
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.
leopardpm
Posts: 1795
Joined: Feb 28, 2009 20:58

Re: Isometric shadow casting light.

Post by leopardpm »

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

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.
leopardpm
Posts: 1795
Joined: Feb 28, 2009 20:58

Re: Isometric shadow casting light.

Post by leopardpm »

Boromir wrote:
leopardpm wrote:without currently psetting the points!
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.
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...

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!
leopardpm
Posts: 1795
Joined: Feb 28, 2009 20:58

Re: Isometric shadow casting light.

Post by leopardpm »

here is my Fast graphics library (not completed at all):

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 */
'}  
and here is a sample useage:

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
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)
Boromir
Posts: 463
Joined: Apr 30, 2015 19:28
Location: Oklahoma,U.S., Earth,Solar System
Contact:

Re: Isometric shadow casting light.

Post by Boromir »

I'll have to look into you library and see if I can get it going.
leopardpm
Posts: 1795
Joined: Feb 28, 2009 20:58

Re: Isometric shadow casting light.

Post by leopardpm »

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....
I'll have to look into you library and see if I can get it going.
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....

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!
Boromir
Posts: 463
Joined: Apr 30, 2015 19:28
Location: Oklahoma,U.S., Earth,Solar System
Contact:

Re: Isometric shadow casting light.

Post by Boromir »

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
Yes, I got that one implemented.
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
Boromir
Posts: 463
Joined: Apr 30, 2015 19:28
Location: Oklahoma,U.S., Earth,Solar System
Contact:

Re: Isometric shadow casting light.

Post by Boromir »

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....
I'll have to look into you library and see if I can get it going.
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....

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!
Removed edge vars and made it only calculate 4 times.

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
Post Reply