2D shadows

[Westbeam]

Good morning coders :)

I made realtime shadows for 2D games today:


Here is the code:

Code: Select all

ScreenRes 800,600,32

Dim As Integer mx,my
Const Rad2Deg=45.0/Atn(1)
CONST PI AS DOUBLE = ACOS(0)*2
Randomize

Dim As Integer cubex(4),cubey(4),cubexscale(4),cubeyscale(4),cubecolor(4,3),switch
Dim As Double cubeangle1(4),cubeangle2(4),cubeangle3(4),cubeangle4(4)
For i As Integer=1 To 4
   cubex(i)=Rnd()*700+50
   cubey(i)=Rnd()*500+50
   cubexscale(i)=Rnd()*50+50
   cubeyscale(i)=Rnd()*50+50
   For i2 As Integer=1 To 3
      cubecolor(i,i2)=128
   Next
Next

Dim As Any Ptr floor=ImageCreate(800,600)
Line floor,(0,0)-(800,600),RGB(8,0,7),BF

For x As Integer=0 To 80
   For y As Integer=0 To 60
      If (x \ 4 + y \ 4) Mod 2 > 0 Then
           switch=1
       Else
           switch=0
       End If
       If switch=1 Then Line floor,(x*10,y*10)-(x*10+10,y*10+10),RGB(255,255,255),BF
       If switch=0 Then Line floor,(x*10,y*10)-(x*10+10,y*10+10),RGB(8,0,7),BF
   Next
Next

Do
   Getmouse mx,my
   Sleep 1,1
   ScreenLock
      Cls
      For i As Integer=1 To 4
         cubeangle1(i)=ATan2(mx-cubex(i),my-cubey(i))*Rad2Deg
         cubeangle2(i)=ATan2(mx-cubex(i)-cubexscale(i),my-cubey(i))*Rad2Deg
         cubeangle3(i)=ATan2(mx-cubex(i)-cubexscale(i),my-cubey(i)-50)*Rad2Deg
         cubeangle4(i)=ATan2(mx-cubex(i),my-cubey(i)-50)*Rad2Deg
         Line (cubex(i),cubey(i))-(mx-Sin(cubeangle1(i)* PI / 180)*1000,my-Cos(cubeangle1(i)* PI / 180)*1000),RGB(0,0,255)
         Line (cubex(i)+cubexscale(i),cubey(i))-(mx-Sin(cubeangle2(i)* PI / 180)*1000,my-Cos(cubeangle2(i)* PI / 180)*1000),RGB(0,0,255)
         Line (cubex(i)+cubexscale(i),cubey(i)+cubeyscale(i))-(mx-Sin(cubeangle3(i)* PI / 180)*1000,my-Cos(cubeangle3(i)* PI / 180)*1000),RGB(0,0,255)
         Line (cubex(i),cubey(i)+cubeyscale(i))-(mx-Sin(cubeangle4(i)* PI / 180)*1000,my-Cos(cubeangle4(i)* PI / 180)*1000),RGB(0,0,255)
      Next
      For i As Integer=1 To 4
         Line (cubex(i),cubey(i))-(cubex(i)+cubexscale(i),cubey(i)+cubeyscale(i)),RGB(0,0,255),B
      Next
      Paint (mx,my),RGB(255,240,203),RGBA(0,0,255,255)
      For i As Integer=1 To 4
         Line (cubex(i),cubey(i))-(mx-Sin(cubeangle1(i)* PI / 180)*1000,my-Cos(cubeangle1(i)* PI / 180)*1000),RGB(8,0,7)
         Line (cubex(i)+cubexscale(i),cubey(i))-(mx-Sin(cubeangle2(i)* PI / 180)*1000,my-Cos(cubeangle2(i)* PI / 180)*1000),RGB(8,0,7)
         Line (cubex(i)+cubexscale(i),cubey(i)+cubeyscale(i))-(mx-Sin(cubeangle3(i)* PI / 180)*1000,my-Cos(cubeangle3(i)* PI / 180)*1000),RGB(8,0,7)
         Line (cubex(i),cubey(i)+cubeyscale(i))-(mx-Sin(cubeangle4(i)* PI / 180)*1000,my-Cos(cubeangle4(i)* PI / 180)*1000),RGB(8,0,7)
      Next
      Put (0,0),floor,Alpha,20
      For i As Integer=1 To 4
         Line (cubex(i)+1,cubey(i)+1)-(cubex(i)+cubexscale(i)-1,cubey(i)+cubeyscale(i)-1),RGB(cubecolor(i,1),cubecolor(i,2),cubecolor(i,3)),BF
      Next
   ScreenUnlock
Loop Until Inkey=Chr(27)
End

You can move the light with the mouse. Have fun :)

[MrSwiss]

Nice effect.

However:
you went straight away into a Beginners Trap: Array definition (using C-style) is resulting
in 1 more Element than is wanted! Use BASIC style to have better Control: Array(1 to 4),
because: Array(4) gives 5 Elements (it implicitly does: 0 to 4 - C is always ZERO based).

Tip for improvement:
use a UDT for the Cube ... :

Code: Select all

Type aCube
   As Integer x, y, xscale, yscale, colr(1 To 3)    ' you can't use 'color' here
   As Double  angle1, angle2, angle3, angle4
End Type
'
Dim As aCube Cube(1 To 4)       ' 4 Elements (BASE: 1)

Accessing the Type:

Code: Select all

Cube(index).x
Cube(index).colr(i2)

this will shorten your Code and improve readability ...

[Westbeam]

I know, my code-style is horrible. Normally I use UDTs. But in this quick concept I have left it out. It is nothing I want to use in my bigger projects. ;)

[badidea]

Similar topic here: http://www.freebasic.net/forum/viewtopic.php?f=7&t=19845, unfortunately the download is broken. I saved it locally once, I will look for it.

Edit: found my local backup, but I can't get the code to compile and/or it crashes. Anyway, it is here: http://nr100.home.xs4all.nl/badidea/Shadow%20Test/

[angros47]

First hint: remove all the occurrences of Rad2Deg, and of "* PI / 180": in fact, you are converting the angle from radians to degrees... and immediately convert them back to radians: there is no need to do that, just leave them in radians.

Also, have you noticed that you never use the angle directly, you always use sine and cosine of an angle? You could just store these values in memory once (sine and cosine are expensive to compute); even better, since you get the angle with an Atan2 operation, you could get rid of it, too: the sine of the angle CubeAngle1, in fact, is just "mx-cubex", you just need to normalize it. You could get rid of all trigonometric functions, in theory.

A similar algorithm is used to manage 3d shadows in OpenB3D.

[Zamaster]

Yo @badidea, I think this is what you're looking for:

https://www.dropbox.com/s/dgxth9osypwd9 ... t.zip?dl=0

Incidentally I updated that code many years later to use it for something! To anyone who doesn't know, this is a pixel based 2D light casting routine, so ideal for all ur baz needs. It needs some asm in the inner loops if you want to squeeze some more fps out of it, would be super easy too.

[badidea]

Thanks, that is the one!

[h4tt3n]

This is really nice, and it runs fast even though there is room for much improvement as angros47 mentions. Here is a quick update on your code with nothing done except removing rad2deg and pi/180 and adding a num_cubes variable instead of the hard-coded 4. As mentioned, the real inmprovement would be to get rid of the atan2 and cos/sin functions, and instead work entirely with vectors. This would make the code several times faster.

Code: Select all

ScreenRes 800,600,32

Dim As Integer mx,my
Dim As Integer num_cubes = 16
Randomize Timer

Dim As Integer cubex(num_cubes),cubey(num_cubes),cubexscale(num_cubes),cubeyscale(num_cubes),cubecolor(num_cubes,3),switch
Dim As Double cubeangle1(num_cubes),cubeangle2(num_cubes),cubeangle3(num_cubes),cubeangle4(num_cubes)
For i As Integer=1 To num_cubes
   cubex(i)=Rnd()*700+50
   cubey(i)=Rnd()*500+50
   cubexscale(i)=Rnd()*50+50
   cubeyscale(i)=Rnd()*50+50
   For i2 As Integer=1 To 3
      cubecolor(i,i2)=128
   Next
Next

Dim As Any Ptr floor=ImageCreate(800,600)
Line floor,(0,0)-(800,600),RGB(8,0,7),BF

For x As Integer=0 To 80
   For y As Integer=0 To 60
      If (x \ 4 + y \ 4) Mod 2 > 0 Then
           switch=1
       Else
           switch=0
       End If
       If switch=1 Then Line floor,(x*10,y*10)-(x*10+10,y*10+10),RGB(255,255,255),BF
       If switch=0 Then Line floor,(x*10,y*10)-(x*10+10,y*10+10),RGB(8,0,7),BF
   Next
Next

Do
   Getmouse mx,my
   Sleep 0,1
   ScreenLock
      Cls
      For i As Integer=1 To num_cubes
         cubeangle1(i)=ATan2(mx-cubex(i),my-cubey(i))
         cubeangle2(i)=ATan2(mx-cubex(i)-cubexscale(i),my-cubey(i))
         cubeangle3(i)=ATan2(mx-cubex(i)-cubexscale(i),my-cubey(i)-50)
         cubeangle4(i)=ATan2(mx-cubex(i),my-cubey(i)-50)
         Line (cubex(i),cubey(i))-(mx-Sin(cubeangle1(i))*1000,my-Cos(cubeangle1(i))*1000),RGB(0,0,255)
         Line (cubex(i)+cubexscale(i),cubey(i))-(mx-Sin(cubeangle2(i))*1000,my-Cos(cubeangle2(i))*1000),RGB(0,0,255)
         Line (cubex(i)+cubexscale(i),cubey(i)+cubeyscale(i))-(mx-Sin(cubeangle3(i))*1000,my-Cos(cubeangle3(i))*1000),RGB(0,0,255)
         Line (cubex(i),cubey(i)+cubeyscale(i))-(mx-Sin(cubeangle4(i))*1000,my-Cos(cubeangle4(i))*1000),RGB(0,0,255)
      Next
      For i As Integer=1 To num_cubes
         Line (cubex(i),cubey(i))-(cubex(i)+cubexscale(i),cubey(i)+cubeyscale(i)),RGB(0,0,255),B
      Next
      Paint (mx,my),RGB(255,240,203),RGBA(0,0,255,255)
      For i As Integer=1 To num_cubes
         Line (cubex(i),cubey(i))-(mx-Sin(cubeangle1(i))*1000,my-Cos(cubeangle1(i))*1000),RGB(8,0,7)
         Line (cubex(i)+cubexscale(i),cubey(i))-(mx-Sin(cubeangle2(i))*1000,my-Cos(cubeangle2(i))*1000),RGB(8,0,7)
         Line (cubex(i)+cubexscale(i),cubey(i)+cubeyscale(i))-(mx-Sin(cubeangle3(i))*1000,my-Cos(cubeangle3(i))*1000),RGB(8,0,7)
         Line (cubex(i),cubey(i)+cubeyscale(i))-(mx-Sin(cubeangle4(i))*1000,my-Cos(cubeangle4(i))*1000),RGB(8,0,7)
      Next
      Put (0,0),floor,Alpha,20
      For i As Integer=1 To num_cubes
         Line (cubex(i)+1,cubey(i)+1)-(cubex(i)+cubexscale(i)-1,cubey(i)+cubeyscale(i)-1),RGB(cubecolor(i,1),cubecolor(i,2),cubecolor(i,3)),BF
      Next
   ScreenUnlock
Loop Until Inkey=Chr(27)
End

Here is an old piece of code that does something similar. I found it in my fb v. 0.23 folder, so it's a few years old, and I don't know who wrote it:

Code: Select all


Const RR2 as double = SQR(2)^-1
Const PI as double = ATN(1)*4
Const TWOPI as double = PI*2
Const Antumbra as double = 0.349065850398865

Sub CastLight(source as integer ptr, xp as integer, yp as integer,_
              rad as double, col as integer = &HFFFFFF00, tcol as Integer = &HFF000000)
             
    #macro _setaddr(dest, src)
        asm mov eax, offset src
        asm mov [dest], eax
    #endmacro
    #define _gosub(addr) asm Call [addr]
    #define _return asm ret

    #define _Ek 1
    #define _Dn 2
    #define _Dp 3
    #define _Xd 4
    #define _Ub 5
    #define _Xx 6

    #macro _addelement(a)
        _N += 1
        Redim Preserve as integer ShadowsB(1 to _N, 1 to 6)
        ShadowsB(_N,_Xx) = a: ShadowsB(_N,_Xd) = SGN(dx)
        dx = abs(dx): dy = abs(dy)
        ShadowsB(_N,_Ek) = 2 * dx - dy
        ShadowsB(_N,_Dn) = ShadowsB(_N,_Ek) + dy
        ShadowsB(_N,_Dp) = ShadowsB(_N,_Ek) - dy
        ShadowsB(_N,_Ub) = 1
    #endmacro
   
    #macro _copyelement(x)
        _N += 1
        Redim Preserve as integer ShadowsB(1 to _N, 1 to 6)
        ShadowsB(_N,_Ek) = ShadowsA(x,_Ek)
        ShadowsB(_N,_Dn) = ShadowsA(x,_Dn)
        ShadowsB(_N,_Dp) = ShadowsA(x,_Dp)
        ShadowsB(_N,_Xx) = ShadowsA(x,_Xx)
        ShadowsB(_N,_Xd) = ShadowsA(x,_Xd)
        ShadowsB(_N,_Ub) = ShadowsA(x,_Ub)
    #endmacro
   
    #macro _copylist()
        For i = 1 to _N
            ShadowsA(i,1)=ShadowsB(i,1)
            ShadowsA(i,2)=ShadowsB(i,2)
            ShadowsA(i,3)=ShadowsB(i,3)
            ShadowsA(i,4)=ShadowsB(i,4)
            ShadowsA(i,5)=ShadowsB(i,5)
            ShadowsA(i,6)=ShadowsB(i,6)
        Next i
    #endmacro
   
   
   
   
    Redim as integer ShadowsA(1 to 2, 1 to 6), ShadowsB(1 to 1, 1 to 6)
    Dim as integer inc, scan, xs, xe, yend = rad*RR2, rs = rad*rad, xcirc, dx, dy
    Dim as integer xpos, ypos, segs, i, _N, ccol, LeftBnd, RightBnd, Offset
    Dim as any Ptr FillLoop, SearchLoop, Proc
    Dim as integer QuadBnd(1 to 8, 1 to 5)

    QuadBnd(1,_Ek) = 1: QuadBnd(1,_Dn) = 2: QuadBnd(1,_Dp) = 0: QuadBnd(1,_Xd) = -1: QuadBnd(1,_Ub) = 0
    QuadBnd(2,_Ek) = 1: QuadBnd(2,_Dn) = 2: QuadBnd(2,_Dp) = 0: QuadBnd(2,_Xd) =  1: QuadBnd(2,_Ub) = 0
    QuadBnd(3,_Ek) = 1: QuadBnd(3,_Dn) = 2: QuadBnd(3,_Dp) = 0: QuadBnd(3,_Xd) = -1: QuadBnd(3,_Ub) = 0
    QuadBnd(4,_Ek) = 1: QuadBnd(4,_Dn) = 2: QuadBnd(4,_Dp) = 0: QuadBnd(4,_Xd) =  1: QuadBnd(4,_Ub) = 0
    QuadBnd(5,_Ek) = 1: QuadBnd(5,_Dn) = 2: QuadBnd(5,_Dp) = 0: QuadBnd(5,_Xd) =  1: QuadBnd(5,_Ub) = 0
    QuadBnd(6,_Ek) = 1: QuadBnd(6,_Dn) = 2: QuadBnd(6,_Dp) = 0: QuadBnd(6,_Xd) = -1: QuadBnd(6,_Ub) = 0
    QuadBnd(7,_Ek) = 1: QuadBnd(7,_Dn) = 2: QuadBnd(7,_Dp) = 0: QuadBnd(7,_Xd) =  1: QuadBnd(7,_Ub) = 0
    QuadBnd(8,_Ek) = 1: QuadBnd(8,_Dn) = 2: QuadBnd(8,_Dp) = 0: QuadBnd(8,_Xd) = -1: QuadBnd(8,_Ub) = 0
   

   
    '-------------------------------------------------QUAD 1---------------------------------------
   
        _setaddr(FillLoop, FillQ1)
        _setaddr(SearchLoop, SearchQ1)
   
        ShadowsA(1,_Ek) = QuadBnd(1,_Ek): ShadowsA(1,_Dn) = QuadBnd(1,_Dn): ShadowsA(1,_Dp) = QuadBnd(1,_Dp)
        ShadowsA(1,_Xx) = xp: ShadowsA(1,_Xd) = QuadBnd(1,_Xd): ShadowsA(1,_Ub) = QuadBnd(1,_Ub)
        ShadowsA(2,_Ek) = QuadBnd(2,_Ek): ShadowsA(2,_Dn) = QuadBnd(2,_Dn): ShadowsA(2,_Dp) = QuadBnd(2,_Dp)
        ShadowsA(2,_Xx) = xp: ShadowsA(2,_Xd) = QuadBnd(2,_Xd): ShadowsA(2,_Ub) = QuadBnd(2,_Ub)
   
        For inc = 1 to rad
            If inc > yend Then
                xcirc = SQR(rs - inc*inc)
                RightBnd = xp + xcirc
                LeftBnd  = xp - xcirc
            Else
                RightBnd = xp + inc - 1
                LeftBnd  = xp - inc
            Endif
            ypos = yp - inc
            segs = Ubound(ShadowsA)
            _N = 0
            For i As Integer = 1 to segs step 2
                Dim As Integer s1 = i
                If ShadowsA(s1,_Ek) < 0 Then
                    ShadowsA(s1,_Ek) += ShadowsA(s1,_Dn)
                Else
                    ShadowsA(s1,_Ek) += ShadowsA(s1,_Dp)
                    ShadowsA(s1,_Xx) += ShadowsA(s1,_Xd)
                End If
                Dim As Integer s2 = i + 1
                If ShadowsA(s2,_Ek) < 0 Then
                    ShadowsA(s2,_Ek) += ShadowsA(s2,_Dn)
                Else
                    ShadowsA(s2,_Ek) += ShadowsA(s2,_Dp)
                    ShadowsA(s2,_Xx) += ShadowsA(s2,_Xd)
                End If
                xs = ShadowsA(s1,_Xx): xe = ShadowsA(s2,_Xx)
                If xe < LeftBnd Then
                    Goto SkipScanQ1
                Elseif xs > RightBnd Then
                    Goto SkipScanQ1
                Elseif xs < LeftBnd Then
                    xs = LeftBnd
                Endif
                If xe > RightBnd Then xe = RightBnd
                xpos = xs
                If point(xpos, ypos) <> tcol Then
                    Do
                        xpos += 1
                        ccol = point(xpos,ypos,source)
                        If ccol = tcol or ccol = -1 Then
                            If xpos < xe Then
                                dx = xpos-xp: dy = inc
                                _addelement(xpos)
                            Else
                                Pset(xpos,ypos),col
                            Endif
                            Exit Do
                        Endif
                        If xpos >= xe Then Goto SkipScanQ1
                    Loop
                Else
                    _copyelement(s1)
                Endif
                Pset (xpos, ypos), col
                Proc = FillLoop
                Do
                    xpos += 1
                    If xpos > xe Then Exit Do
                    _gosub(Proc)
                Loop
                If _N mod 2 = 1 Then
                    _copyelement(s2)
                Endif
                SkipScanQ1:
            Next i
            If _N = 0 Then Exit For
            Redim Preserve as integer ShadowsA(1 to _N, 1 to 6)
            _copylist()
            Redim as integer ShadowsB(1 to 1, 1 to 6)
        Next inc
       
   
    '----------------------------------------------------QUAD 2------------------------------------
   
        Redim as integer ShadowsA(1 to 2, 1 to 6), ShadowsB(1 to 1, 1 to 6)
   
        _setaddr(FillLoop, FillQ2)
        _setaddr(SearchLoop, SearchQ2)
   
        ShadowsA(1,_Ek) = QuadBnd(3,_Ek): ShadowsA(1,_Dn) = QuadBnd(3,_Dn): ShadowsA(1,_Dp) = QuadBnd(3,_Dp)
        ShadowsA(1,_Xx) = yp: ShadowsA(1,_Xd) = QuadBnd(3,_Xd): ShadowsA(1,_Ub) = QuadBnd(3,_Ub)
        ShadowsA(2,_Ek) = QuadBnd(4,_Ek): ShadowsA(2,_Dn) = QuadBnd(4,_Dn): ShadowsA(2,_Dp) = QuadBnd(4,_Dp)
        ShadowsA(2,_Xx) = yp: ShadowsA(2,_Xd) = QuadBnd(4,_Xd): ShadowsA(2,_Ub) = QuadBnd(4,_Ub)
       
       
        For inc = 1 to rad
            If inc > yend Then
                xcirc = SQR(rs - inc*inc)
                RightBnd = yp + xcirc
                LeftBnd  = yp - xcirc
            Else
                RightBnd = yp + inc - 1
                LeftBnd  = yp - inc
            Endif
            xpos = xp + inc
            segs = Ubound(ShadowsA)
            _N = 0
            For i As Integer = 1 to segs step 2
                Dim As Integer s1 = i
                If ShadowsA(s1,_Ek) < 0 Then
                    ShadowsA(s1,_Ek) += ShadowsA(s1,_Dn)
                Else
                    ShadowsA(s1,_Ek) += ShadowsA(s1,_Dp)
                    ShadowsA(s1,_Xx) += ShadowsA(s1,_Xd)
                End If
                Dim As Integer s2 = i + 1
                If ShadowsA(s2,_Ek) < 0 Then
                    ShadowsA(s2,_Ek) += ShadowsA(s2,_Dn)
                Else
                    ShadowsA(s2,_Ek) += ShadowsA(s2,_Dp)
                    ShadowsA(s2,_Xx) += ShadowsA(s2,_Xd)
                End If
                xs = ShadowsA(s1,_Xx): xe = ShadowsA(s2,_Xx)
                If xe < LeftBnd Then
                    Goto SkipScanQ2
                Elseif xs > RightBnd Then
                    Goto SkipScanQ2
                Elseif xs < LeftBnd Then
                    xs = LeftBnd
                Endif
                If xe > RightBnd Then xe = RightBnd
                ypos = xs
                If point(xpos, ypos) <> tcol Then
                    Do
                        ypos += 1
                        ccol = point(xpos,ypos,source)
                        If ccol = tcol or ccol = -1 Then
                            If ypos < xe Then
                                dx = ypos-yp: dy = inc
                                _addelement(ypos)
                            Else
                                Pset(xpos,ypos),col
                            Endif
                            Exit Do
                        Endif
                        If ypos >= xe Then Goto SkipScanQ2
                    Loop
                Else
                    _copyelement(s1)
                Endif
                Pset (xpos, ypos), col
                Proc = FillLoop
                Do
                    ypos += 1
                    If ypos > xe Then Exit Do
                    _gosub(Proc)
                Loop
                If _N mod 2 = 1 Then
                    _copyelement(s2)
                Endif
                SkipScanQ2:
            Next i
            If _N = 0 Then Exit For
            Redim Preserve as integer ShadowsA(1 to _N, 1 to 6)
            _copylist()
            Redim as integer ShadowsB(1 to 1, 1 to 6)
        Next inc


    '------------------------------------------------QUAD 3---------------------------------------
   
 
        Redim as integer ShadowsA(1 to 2, 1 to 6), ShadowsB(1 to 1, 1 to 6)
     
        _setaddr(FillLoop, FillQ3)
        _setaddr(SearchLoop, SearchQ3)

        ShadowsA(1,_Ek) = QuadBnd(5,_Ek): ShadowsA(1,_Dn) = QuadBnd(5,_Dn): ShadowsA(1,_Dp) = QuadBnd(5,_Dp)
        ShadowsA(1,_Xx) = xp: ShadowsA(1,_Xd) = QuadBnd(5,_Xd): ShadowsA(1,_Ub) = QuadBnd(5,_Ub)
        ShadowsA(2,_Ek) = QuadBnd(6,_Ek): ShadowsA(2,_Dn) = QuadBnd(6,_Dn): ShadowsA(2,_Dp) = QuadBnd(6,_Dp)
        ShadowsA(2,_Xx) = xp: ShadowsA(2,_Xd) = QuadBnd(6,_Xd): ShadowsA(2,_Ub) = QuadBnd(6,_Ub)
   
        For inc = 1 to rad
            If inc > yend Then
                xcirc = SQR(rs - inc*inc)
                RightBnd = xp + xcirc
                LeftBnd  = xp - xcirc
            Else
                RightBnd = xp + inc
                LeftBnd  = xp - inc + 1
            Endif
            ypos = yp + inc
            segs = Ubound(ShadowsA)
            _N = 0
            For i = 1 to segs step 2
                Dim As Integer s1 = i
                If ShadowsA(s1,_Ek) < 0 Then
                    ShadowsA(s1,_Ek) += ShadowsA(s1,_Dn)
                Else
                    ShadowsA(s1,_Ek) += ShadowsA(s1,_Dp)
                    ShadowsA(s1,_Xx) += ShadowsA(s1,_Xd)
                End If
                Dim As Integer s2 = i + 1
                If ShadowsA(s2,_Ek) < 0 Then
                    ShadowsA(s2,_Ek) += ShadowsA(s2,_Dn)
                Else
                    ShadowsA(s2,_Ek) += ShadowsA(s2,_Dp)
                    ShadowsA(s2,_Xx) += ShadowsA(s2,_Xd)
                End If
                xs = ShadowsA(s1,_Xx): xe = ShadowsA(s2,_Xx)
                If xe > RightBnd Then
                    Goto SkipScanQ3
                Elseif xs < LeftBnd Then
                    Goto SkipScanQ3
                Elseif xs > RightBnd Then
                    xs = RightBnd
                Endif
                If xe < LeftBnd Then xe = LeftBnd
                xpos = xs
                If point(xpos, ypos) <> tcol Then
                    Do
                        xpos -= 1
                        ccol = point(xpos,ypos,source)
                        If ccol = tcol or ccol = -1 Then
                            If xpos > xe Then
                                dx = xpos-xp: dy = inc
                                _addelement(xpos)
                            Else
                                Pset(xpos,ypos),col
                            Endif
                            Exit Do
                        Endif
                        If xpos <= xe Then Goto SkipScanQ3
                    Loop
                Else
                    _copyelement(s1)
                Endif
                Pset (xpos, ypos), col
                Proc = FillLoop
                Do
                    xpos -= 1
                    If xpos < xe Then Exit Do
                    _gosub(Proc)
                Loop
                If _N mod 2 = 1 Then
                    _copyelement(s2)
                Endif
                SkipScanQ3:
            Next i
            If _N = 0 Then Exit For
            Redim Preserve as integer ShadowsA(1 to _N, 1 to 6)
            _copylist()
            Redim as integer ShadowsB(1 to 1, 1 to 6)
        Next inc


    '------------------------------------------------QUAD 4---------------------------------------


        Redim as integer ShadowsA(1 to 2, 1 to 6), ShadowsB(1 to 1, 1 to 6)
       
        _setaddr(FillLoop, FillQ4)
        _setaddr(SearchLoop, SearchQ4)
       
        ShadowsA(1,_Ek) = QuadBnd(7,_Ek): ShadowsA(1,_Dn) = QuadBnd(7,_Dn): ShadowsA(1,_Dp) = QuadBnd(7,_Dp)
        ShadowsA(1,_Xx) = yp: ShadowsA(1,_Xd) = QuadBnd(7,_Xd): ShadowsA(1,_Ub) = QuadBnd(7,_Ub)
        ShadowsA(2,_Ek) = QuadBnd(8,_Ek): ShadowsA(2,_Dn) = QuadBnd(8,_Dn): ShadowsA(2,_Dp) = QuadBnd(8,_Dp)
        ShadowsA(2,_Xx) = yp: ShadowsA(2,_Xd) = QuadBnd(8,_Xd): ShadowsA(2,_Ub) = QuadBnd(8,_Ub)
       
        For inc = 1 to rad
            If inc > yend Then
                xcirc = SQR(rs - inc*inc)
                RightBnd = yp + xcirc
                LeftBnd  = yp - xcirc
            Else
                RightBnd = yp + inc
                LeftBnd  = yp - inc + 1
            Endif
            xpos = xp - inc
            segs = Ubound(ShadowsA)
            _N = 0
            For i As Integer = 1 to segs step 2
                Dim As Integer s1 = i
                If ShadowsA(s1,_Ek) < 0 Then
                    ShadowsA(s1,_Ek) += ShadowsA(s1,_Dn)
                Else
                    ShadowsA(s1,_Ek) += ShadowsA(s1,_Dp)
                    ShadowsA(s1,_Xx) += ShadowsA(s1,_Xd)
                End If
                Dim As Integer s2 = i + 1
                If ShadowsA(s2,_Ek) < 0 Then
                    ShadowsA(s2,_Ek) += ShadowsA(s2,_Dn)
                Else
                    ShadowsA(s2,_Ek) += ShadowsA(s2,_Dp)
                    ShadowsA(s2,_Xx) += ShadowsA(s2,_Xd)
                End If
                xs = ShadowsA(s1,_Xx): xe = ShadowsA(s2,_Xx)
                If xe > RightBnd Then
                    Goto SkipScanQ4
                Elseif xs < LeftBnd Then
                    Goto SkipScanQ4
                Elseif xs > RightBnd Then
                    xs = RightBnd
                Endif
                If xe < LeftBnd Then xe = LeftBnd
                ypos = xs
                If point(xpos, ypos) <> tcol Then
                    Do
                        ypos -= 1
                        ccol = point(xpos,ypos,source)
                        If ccol = tcol or ccol = -1 Then
                            If ypos > xe Then
                                dx = ypos-yp: dy = inc
                                _addelement(ypos)
                            Else
                                Pset(xpos,ypos),col
                            Endif
                            Exit Do
                        Endif
                        If ypos <= xe Then Goto SkipScanQ4
                    Loop
                Else
                    _copyelement(s1)
                Endif
                Pset (xpos, ypos), col
                Proc = FillLoop
                Do
                    ypos -= 1
                    If ypos < xe Then Exit Do
                    _gosub(Proc)
                Loop
                If _N mod 2 = 1 Then
                    _copyelement(s2)
                Endif
                SkipScanQ4:
            Next i
            If _N = 0 Then Exit For
            Redim Preserve as integer ShadowsA(1 to _N, 1 to 6)
            _copylist()
            Redim as integer ShadowsB(1 to 1, 1 to 6)
        Next inc
   
    Exit Sub
   
    '======================================FILLING LOOPS======================================
   
    asm FillQ1:
        If point(xpos,ypos,source) <> tcol Then
            dx = xpos-xp-1: dy = inc
            _addelement(xpos-1)
            Proc = SearchLoop
        Else
            Pset(xpos,ypos), col
        Endif
    _return
   
    asm SearchQ1:
        If point(xpos,ypos,source) = tcol Then
            dx = xpos-xp: dy = inc
            _addelement(xpos)
            Proc = FillLoop
            Pset(xpos,ypos), col
        Endif
    _return
   
    asm FillQ2:
        If point(xpos,ypos,source) <> tcol Then
            dx = ypos-yp-1: dy = inc
            _addelement(ypos-1)
            Proc = SearchLoop
        Else
            Pset(xpos,ypos), col
        Endif
    _return
   
    asm SearchQ2:
        If point(xpos,ypos,source) = tcol Then
            dx = ypos-yp: dy = inc
            _addelement(ypos)
            Proc = FillLoop
            Pset(xpos,ypos), col
        Endif
    _return
   
    asm FillQ3:
        If point(xpos,ypos,source) <> tcol Then
            dx = xpos-xp+1: dy = inc
            _addelement(xpos+1)
            Proc = SearchLoop
        Else
            Pset(xpos,ypos), col
        Endif
    _return
   
    asm SearchQ3:
        If point(xpos,ypos,source) = tcol Then
            dx = xpos-xp: dy = inc
            _addelement(xpos)
            Proc = FillLoop
            Pset(xpos,ypos), col
        Endif
    _return
   
    asm FillQ4:
        If point(xpos,ypos,source) <> tcol Then
            dx = ypos-yp+1: dy = inc
            _addelement(ypos+1)
            Proc = SearchLoop
        Else
            Pset(xpos,ypos), col
        Endif
    _return
   
    asm SearchQ4:
        If point(xpos,ypos,source) = tcol Then
            dx = ypos-yp: dy = inc
            _addelement(ypos)
            Proc = FillLoop
            Pset(xpos,ypos), col
        Endif
    _return
   
   
   
End Sub


screenres 640,480,32,2
screenset 1,0
setmouse ,,0
Dim as integer ptr Img
Dim as integer mx, my
Img = ImageCreate(640,480)
Bload "ShadowTest.bmp", Img

Do 
    getmouse mx,my
    If mx = -1 Then
        mx = 320
        my = 240
    Endif
    Put (0,0), Img, PSET
    Locate 1,1: Print mx, my
    CastLight (Img,mx,my,150)

    flip
Loop until inkey$ <> ""
ImageDestroy Img
sleep
end


Cheers, Mike

[D.J.Peters]

Looks like the red lines are wrong.
In case of only one light source all lines must cross the center of the light position right ?

Joshy

[Lost Zergling]

Hello Peters. I'd really appreciate to get more info about TinyDialog licence terms if you please because I need to know wether I can use it or not (or restrictions) for an application that is bound to be used by my organisation. Thank you.

[h4tt3n]

Hello Peters. I'd really appreciate to get more info about TinyDialog licence terms if you please because I need to know wether I can use it or not (or restrictions) for an application that is bound to be used by my organisation. Thank you.

I don't get it. How could simple vector math like this possibly be patented / licenced? The effect is nice, but it contains no original thought or innovative ideas, and the involved math is very similar to what has already been used for two decades in collision detection and game physics.

Cheers, Mike

[Westbeam]

Thank you for all the help :)

@Peters:
You are right, here is a new code:

Code: Select all

ScreenRes 800,600,32

Randomize

Const Light_Range=1000
Const cubes=5

#Include once "fbgfx.bi"

#Define Get_R(a) ((a shr 16) and 255)
#Define Get_G(a) ((a shr 8) and 255)
#Define Get_B(a) (a and 255)

#Define Get_Ptr_Size_X(a) cptr(FB.IMAGE Ptr,a)->width
#Define Get_Ptr_Size_Y(a) cptr(FB.IMAGE Ptr,a)->height

Sub Apply_Color_Filter(ByRef Img as any ptr, r As Integer, g As Integer, b As Integer)
   
    Dim as Uinteger CurrentCol
    Dim as integer _R,_G,_B
   
    Dim as integer SizeX = Get_ptr_Size_X(Img)
    Dim as integer SizeY = Get_ptr_Size_Y(Img)
    Dim as single CurrentLum
   
    For i as integer = 0 to SizeX - 1
        For j as integer = 0 to SizeY - 1
           
            CurrentCol = Point(i,j,Img)
           
            _R = r
            _G = g
            _B = b
           
            CurrentLum = (Get_R(Currentcol)+Get_g(Currentcol)+Get_b(Currentcol))/(255*3)
           
            Pset Img,(i,j),rgb(CurrentLum*_r,CurrentLum*_g,CurrentLum*_b)
        Next
    Next

End Sub

Dim As Any Ptr Texture_Roof1=ImageCreate(100,100)
Line Texture_Roof1,(0,0)-(100,100),RGB(46,37,51),BF

Dim As Any Ptr Texture_Roof2=ImageCreate(100,100)
Line Texture_Roof2,(0,0)-(100,100),RGB(56,28,19),BF

Dim As Any Ptr Roof_Tile1=ImageCreate(11,6)
Line Roof_Tile1,(0,0)-(10,5),RGB(46,37,51),B
Line Roof_Tile1,(0,5)-(10,5),RGB(29,19,30)
Line Roof_Tile1,(1,1)-(9,2),RGB(114,107,126),BF
Line Roof_Tile1,(1,3)-(9,4),RGB(77,74,93),BF

Dim As Any Ptr Roof_Tile1R=ImageCreate(11,6)
Line Roof_Tile1R,(0,0)-(10,5),RGB(43,35,32),B
Line Roof_Tile1R,(0,5)-(10,5),RGB(23,19,18)
Line Roof_Tile1R,(1,1)-(9,2),RGB(124,101,93),BF
Line Roof_Tile1R,(1,3)-(9,4),RGB(84,68,63),BF

Dim As Any Ptr Roof_Tile2(5),Roof_Tile3(5)
For i As Integer=0 To 5
   Roof_Tile2(i)=ImageCreate(8,4)
   Line Roof_Tile2(i),(0,0)-(8,4),RGB(46,37,51),BF
   Roof_Tile3(i)=ImageCreate(8,4)
   Line Roof_Tile3(i),(0,0)-(8,4),RGB(46,37,51),BF
Next
Line Roof_Tile2(0),(0,0)-(7,2),RGB(77,74,93),BF
Line Roof_Tile2(0),(1,3)-(6,3),RGB(77,74,93)

Line Roof_Tile2(1),(0,0)-(7,2),RGB(114,107,126),BF
Line Roof_Tile2(1),(1,3)-(6,3),RGB(114,107,126)

Line Roof_Tile2(2),(0,0)-(7,2),RGB(61,55,72),BF
Line Roof_Tile2(2),(1,3)-(6,3),RGB(61,55,72)

Line Roof_Tile2(3),(0,0)-(7,2),RGB(77,74,93),BF
Line Roof_Tile2(3),(1,3)-(6,3),RGB(77,74,93)

Line Roof_Tile2(4),(0,0)-(7,2),RGB(77,74,93),BF
Line Roof_Tile2(4),(1,3)-(6,3),RGB(77,74,93)

Line Roof_Tile2(5),(0,0)-(7,2),RGB(61,55,72),BF
Line Roof_Tile2(5),(1,3)-(6,3),RGB(61,55,72)

Line Roof_Tile3(0),(0,2)-(7,3),RGB(77,74,93),BF
Line Roof_Tile3(0),(1,1)-(6,1),RGB(77,74,93)

Line Roof_Tile3(1),(0,2)-(7,3),RGB(114,107,126),BF
Line Roof_Tile3(1),(1,1)-(6,1),RGB(114,107,126)

Line Roof_Tile3(2),(0,2)-(7,3),RGB(61,55,72),BF
Line Roof_Tile3(2),(1,1)-(6,1),RGB(61,55,72)

Line Roof_Tile3(3),(0,2)-(7,3),RGB(77,74,93),BF
Line Roof_Tile3(3),(1,1)-(6,1),RGB(77,74,93)

Line Roof_Tile3(4),(0,2)-(7,3),RGB(77,74,93),BF
Line Roof_Tile3(4),(1,1)-(6,1),RGB(77,74,93)

Line Roof_Tile3(5),(0,2)-(7,3),RGB(61,55,72),BF
Line Roof_Tile3(5),(1,1)-(6,1),RGB(61,55,72)

Dim As Any Ptr Red_Filter=ImageCreate(100,100)
Line Red_Filter,(0,0)-(100,100),RGB(163,81,54),BF

For i As Integer=0 To 10
   Put Texture_Roof1,(i*10,48),Roof_Tile1,Trans
Next

For x As Integer=0 To 12
   For y As Integer=0 To 8
      If y Mod 2=1 Then
         Put Texture_Roof1,(x*9-5,y*5+54),Roof_Tile2(Rnd()*5),Trans
      Else
         Put Texture_Roof1,(x*9,y*5+54),Roof_Tile2(Rnd()*5),Trans
      End If
   Next
Next

For x As Integer=0 To 12
   For y As Integer=0 To 9
      If y Mod 2=1 Then
         Put Texture_Roof1,(x*9-5,y*5-1),Roof_Tile3(Rnd()*5),Trans
      Else
         Put Texture_Roof1,(x*9,y*5-1),Roof_Tile3(Rnd()*5),Trans
      End If
   Next
Next

Put Texture_Roof2,(0,0),Texture_Roof1,Trans
Apply_Color_Filter(Texture_Roof2,163*2,81*2,54*2)
For i As Integer=0 To 10
   Put Texture_Roof2,(i*10,48),Roof_Tile1R,Trans
Next

Dim As Integer mx,my

Type TCube
   As Integer X,Y,XScale,YScale
   As Integer Clr(3),Roof
   As Double Angle1(8),Angle2(8),Angle3(8),Angle4(8)
   As Any Ptr Shadow
End Type

Dim Shared As TCube Cube(cubes)

Dim As Integer ScrollX,ScrollY
Dim As Integer cubex(cubes),cubey(cubes),cubexscale(cubes),cubeyscale(cubes),cubecolor(cubes,3),switch
Dim As Double cubeangle1(cubes),cubeangle2(cubes),cubeangle3(cubes),cubeangle4(cubes)
For i As Integer=1 To cubes
   With Cube(i)
      .X=Rnd()*700+50
      .Y=Rnd()*500+50
      .XScale=100
      .YScale=100
      For i2 As Integer=1 To 3
         .Clr(i2)=128
      Next
      .Roof=Rnd()*1
      .Shadow=ImageCreate(.XScale,.YScale/2)
      Line .Shadow,(0,0)-(.XScale,.YScale/2),RGB(8,0,7),BF
   End With
Next

Dim As Any Ptr floor=ImageCreate(800,600)
Line floor,(0,0)-(800,600),RGB(8,0,7),BF

For x As Integer=0 To 80
   For y As Integer=0 To 60
      If (x \ 4 + y \ 4) Mod 2 > 0 Then
           switch=1
       Else
           switch=0
       End If
       If switch=1 Then Line floor,(x*10,y*10)-(x*10+10,y*10+10),RGB(255,240,203),BF
       If switch=0 Then Line floor,(x*10,y*10)-(x*10+10,y*10+10),RGB(8,0,7),BF
   Next
Next

Do
   Getmouse mx,my
   Sleep 10,1
   ScreenLock
      Cls
      For i As Integer=1 To cubes
         With Cube(i)
            .Angle1(1)=ATan2(mx-.X,my-.Y)
            .Angle2(1)=ATan2(mx-.X-.XScale,my-.Y)
            .Angle3(1)=ATan2(mx-.X-.XScale,my-.Y-.YScale)
            .Angle4(1)=ATan2(mx-.X,my-.Y-.YScale)
            Line (.X-ScrollX,.Y-ScrollY)-(mx-Sin(.Angle1(1))*Light_Range-ScrollX,my-Cos(.Angle1(1))*Light_Range-ScrollY),RGB(0,0,255)
            Line (.X+.XScale-ScrollX,.Y-ScrollY)-(mx-Sin(.Angle2(1))*Light_Range-ScrollX,my-Cos(.Angle2(1))*Light_Range-ScrollY),RGB(0,0,255)
            Line (.X+.XScale-ScrollX,.Y+.YScale-ScrollY)-(mx-Sin(.Angle3(1))*Light_Range-ScrollX,my-Cos(.Angle3(1))*Light_Range-ScrollY),RGB(0,0,255)
            Line (.X-ScrollX,.Y+.YScale-ScrollY)-(mx-Sin(.Angle4(1))*Light_Range-ScrollX,my-Cos(.Angle4(1))*Light_Range-ScrollY),RGB(0,0,255)
            
            'Line (mx-Sin(.Angle2(1))*Light_Range-ScrollX,my-Cos(.Angle2(1))*Light_Range-ScrollY)-(mx-Sin(.Angle1(1))*Light_Range-ScrollX,my-Cos(.Angle1(1))*Light_Range-ScrollY),RGB(0,0,255)
            'Line (mx-Sin(.Angle3(1))*Light_Range-ScrollX,my-Cos(.Angle3(1))*Light_Range-ScrollY)-(mx-Sin(.Angle4(1))*Light_Range-ScrollX,my-Cos(.Angle4(1))*Light_Range-ScrollY),RGB(0,0,255)
            'Line (mx-Sin(.Angle1(1))*Light_Range-ScrollX,my-Cos(.Angle1(1))*Light_Range-ScrollY)-(mx-Sin(.Angle4(1))*Light_Range-ScrollX,my-Cos(.Angle4(1))*Light_Range-ScrollY),RGB(0,0,255)
         End With
      Next
      For i As Integer=1 To cubes
         With Cube(i)
            Line (.X-ScrollX,.Y-Scrolly)-(.X+.XScale-ScrollX,.Y+.YScale-ScrollY),RGB(0,0,255),B
         End With
      Next
      Paint (mx,my),RGB(255,240,203),RGBA(0,0,255,255)
      For i As Integer=1 To cubes
         With Cube(i)
            Line (.X-ScrollX,.Y-ScrollY)-(mx-Sin(.Angle1(1))*Light_Range-ScrollX,my-Cos(.Angle1(1))*Light_Range-ScrollY),RGB(8,0,7)
            Line (.X+.XScale-ScrollX,.Y-ScrollY)-(mx-Sin(.Angle2(1))*Light_Range-ScrollX,my-Cos(.Angle2(1))*Light_Range-ScrollY),RGB(8,0,7)
            Line (.X+.XScale-ScrollX,.Y+.YScale-ScrollY)-(mx-Sin(.Angle3(1))*Light_Range-ScrollX,my-Cos(.Angle3(1))*Light_Range-ScrollY),RGB(8,0,7)
            Line (.X-ScrollX,.Y+.YScale-ScrollY)-(mx-Sin(.Angle4(1))*Light_Range-ScrollX,my-Cos(.Angle4(1))*Light_Range-ScrollY),RGB(8,0,7)
         End With
      Next
      Put (0,0),floor,Alpha,150
      For i As Integer=1 To cubes
         With Cube(i)
            If .Roof=0 Then
               Put(.X-Scrollx,.Y-Scrolly),Texture_Roof2,Trans
            Else
               Put(.X-Scrollx,.Y-Scrolly),Texture_Roof1,Trans
            End If
            If my>.Y+.YScale/2-ScrollY Then
               Put (.X-Scrollx,.Y-Scrolly),.Shadow,Alpha,128
            Else
               Put (.X-Scrollx,.Y+.YScale/2-Scrolly),.Shadow,Alpha,128
            End If
         End With
      Next
   ScreenUnlock
Loop Until Inkey=Chr(27)
End

I made the shadows more transparent and included some roof-textures and something like a fake-normalmap (?) for them:

[dodicat]

I had a bash at this shadow thing.
A bit bare bones, not very general.
Most things have a separate sub or function.
Click the mouse button to refresh.

Code: Select all



Screen 20,32
Dim As Integer xres,yres
Screeninfo xres,yres
Type pt
    As Integer x,y
    Ca As Single 'angle to mouse(radians)
    #define v Type<pt>
End Type

#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define dist(a,b) sqr((a.x-b.x)*(a.x-b.x) + (a.y-b.y)*(a.y-b.y))

Type box
    As pt p(0 To 4)
    col As Ulong
    Declare Constructor
    Declare Constructor(As pt,As pt,As Ulong)
End Type

Constructor box:End Constructor

Constructor box(p1 As pt,p3 As pt,c As Ulong)
col=c
p(1)=p1:p(3)=p3
p(2).x=p(3).x:p(2).y=p(1).y
p(4).x=p(1).x:p(4).y=p(1).y+p(3).y-p(2).y
'p(0) is the box centroid
p(0).x=(p(1).x+p(2).x)\2
p(0).y=(p(2).y+p(3).y)\2
End Constructor

Function shortline(fp As pt,p As pt,length As Integer) As pt
    Dim As Single diffx=p.x-fp.x,diffy=p.y-fp.y
    Dim As Single L=Sqr(diffx*diffx+diffy*diffy)
    Return v(fp.x+length*diffx/L,fp.y+length*diffy/L)
End Function

Function compare (a1 As Single,a2 As Single)As Long
    Dim As Single pi=4*Atn(1)
    If Abs(a1)>pi/2 Or Abs(a2)>pi/2 Then
        If Sgn(a1)<>Sgn(a2) Then Return a2<a1
    End If
    Return a1<a2
End Function

Sub Circle_sort(p() As pt,c As pt)
    For p1 As Long  = 1 To 3
        For p2 As Long  = p1 + 1 To 4
            Var w= compare(p(p1).Ca,p(p2).Ca)
            If w Then Swap p(p1),p(p2)
        Next p2
    Next p1
   
End Sub

Sub barebox(bx1 As box,i As Any Ptr=0)
    For n As Integer=1 To 4
        Var k=n,p=1
        If n=4 Then k=4:p=-3
        Line i,(bx1.p(k).x,bx1.p(k).y)-(bx1.p(k+p).x,bx1.p(k+p).y),Rgb(0,0,0)
    Next n
End Sub

Sub fullbox(bx1 As box,i As Any Ptr=0)
    For n As Integer=1 To 4
        Var k=n,p=1
        If n=4 Then k=4:p=-3
        Line i,(bx1.p(k).x,bx1.p(k).y)-(bx1.p(k+p).x,bx1.p(k+p).y),bx1.col
    Next n
    Paint (bx1.p(0).x,bx1.p(0).y),bx1.col,bx1.col
End Sub

Sub GetShadow(Byval b1 As box,c As pt)
    Dim As box b=b1
    Dim As Single pi=4*Atn(1),z
    For n As Long=1 To 4
        z= (Atan2((c.y-b.p(n).y),(c.x-b.p(n).x)))
        b.p(n).ca=z
    Next n
   
    circle_sort(b.p(),c)
   
    Var S1=shortline(b.p(1),c,-1000)
    Line(s1.x,s1.y)-(b.p(1).x,b.p(1).y),Rgb(0,0,0)
    Var S2=shortline(b.p(4),c,-1000)
    Line(s2.x,s2.y)-(b.p(4).x,b.p(4).y),Rgb(0,0,0)
   
    Dim As pt ctr= v((s1.x+s2.x)\2,(s1.y+s2.y)\2)
    Var lngth=dist(b.p(0),b.p(1))
    Var s3=shortline(b.p(0),ctr,lngth*1.5)
    barebox(b1)
    Var lngth2=.4*dist(s1,s2)
    Var t2=shortline(s1,s2,lngth2)
    Var t1=shortline(s2,s1,lngth2)
    s1=shortline(b.p(1),t2,lngth*2)
    s2=shortline(b.p(4),t1,lngth*2)
    Paint(s1.x,s1.y),Rgb(0,0,0),Rgb(0,0,0)
    Paint(s2.x,s2.y),Rgb(0,0,0),Rgb(0,0,0)
    Paint(s3.x,s3.y),Rgb(0,0,0),Rgb(0,0,0)
End Sub


Function inbox(b As box,mx As Integer,my As Integer) As Long
    Return mx>=b.p(1).x And mx<=b.p(3).x And my>=b.p(1).y And my<=b.p(3).y
End Function

Sub setupfloor(xres As Integer,yres As Integer,floor As Any Ptr)
    Dim As Long counter
    Dim As Ulong col
    For y As Long=-10 To yres+10 Step 100
        For x As Long=-10 To xres+10 Step 100
            counter+=1
            If counter Mod 2 Then col=Rgb(255,255,255) Else col=Rgb(0,100,200)
            Line floor,(x,y)-(x+100,y+100),col,bf
        Next x
    Next y
End Sub

Function checkseperation(b() As box,tst As pt,n As Integer,dx As Integer,dy As Integer) As Integer
    For z As Integer=1 To n
        If dist(b(z).p(0),tst) < 2*(dx+dy) Then Return 0
    Next z
    Return -1
End Function

Sub setupboxes(b() As box,xres As Integer,yres As Integer)
    For n As Integer=1 To Ubound(b)
        Dim As Integer xx,yy,dx,dy
        Do
            dx=Intrange(30,50):dy=intrange(30,50)   
            xx=IntRange(xres/15,xres-xres/15-dx):yy=Intrange(yres/15,yres-yres/15-dy)
        Loop Until checkseperation(b(),v(xx,yy),n-1,dx,dy)
        b(n)=Type<box>(v(xx,yy),v(xx+dx,yy+dy),Rgb(Rnd*255,Rnd*255,Rnd*255))
    Next n
End Sub

'=====================================================
Dim As box b(1 To 20)
setupboxes(b(),xres,yres)

Dim As Any Ptr floor=Imagecreate(xres,yres)
setupfloor(xres,yres,floor)

Dim As Integer mx,my,mb,flag
Do
    Getmouse mx,my,,mb
    If mb=1 And flag=0 Then flag=1:setupboxes(b(),xres,yres)
    Screenlock
    Cls
    Put(0,0),floor,Alpha,255
    For n1 As Integer=Lbound(b) To Ubound(b)
        If inbox(b(n1),mx,my) =0 Then GetShadow(b(n1),v(mx,my))
    Next n1
    Put(0,0),floor,Alpha,100
    draw string (5,5),"Click Mouse",0
    For n As Integer=1 To Ubound(b)
        fullbox(b(n))
    Next n
    Screenunlock
    Sleep 1,1
    flag=mb
Loop Until Len(Inkey)
Imagedestroy floor
Sleep
 

[dodicat]

This one is more general:

Code: Select all


Screen 20,32
Dim As Integer xres,yres
Screeninfo xres,yres
Type pt
    As Integer x,y
    Ca As Single 'angle to mouse(radians)
    #define v Type<pt>
End Type

#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define dist(a,b) sqr((a.x-b.x)*(a.x-b.x) + (a.y-b.y)*(a.y-b.y))
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Type box
    As pt p(0 To 4)
    col As Ulong
    inc As Integer
    Declare Constructor
    Declare Constructor(As pt,As pt,As Ulong)
End Type

Constructor box:End Constructor

Constructor box(p1 As pt,p3 As pt,c As Ulong)
col=c
p(1)=p1:p(3)=p3
p(2).x=p(3).x:p(2).y=p(1).y
p(4).x=p(1).x:p(4).y=p(1).y+p(3).y-p(2).y
'p(0) is the box centroid
p(0).x=(p(1).x+p(2).x)\2
p(0).y=(p(2).y+p(3).y)\2
End Constructor

Function shortline(fp As pt,p As pt,length As Integer) As pt
    Dim As Single diffx=p.x-fp.x,diffy=p.y-fp.y
    Dim As Single L=Sqr(diffx*diffx+diffy*diffy)
    Return v(fp.x+length*diffx/L,fp.y+length*diffy/L)
End Function

Function compare (a1 As Single,a2 As Single)As Long
    Dim As Single pi=4*Atn(1)
    If Abs(a1)>pi/2 Or Abs(a2)>pi/2 Then
        If Sgn(a1)<>Sgn(a2) Then Return a2<a1
    End If
    Return a1<a2
End Function

Sub Circle_sort(p() As pt,c As pt)
    For p1 As Long  = 1 To 3
        For p2 As Long  = p1 + 1 To 4
            Var w= compare(p(p1).Ca,p(p2).Ca)
            If w Then Swap p(p1),p(p2)
        Next p2
    Next p1
   
End Sub

Sub barebox(bx1 As box,i As Integer=0,msg As Integer=0)
    If msg=0 Then
        Line (bx1.p(1).x,bx1.p(1).y)-(bx1.p(3).x,bx1.p(3).y),Rgb(0,0,i),b
    Else
        Line (bx1.p(1).x,bx1.p(1).y)-(bx1.p(3).x,bx1.p(3).y),bx1.col,bf
    End If
End Sub

Sub GetShadow(Byval b1 As box,c As pt)
    Dim As box b=b1
    Dim As Integer i=b.inc
    Dim As Single pi=4*Atn(1),z
    For n As Long=1 To 4
        z= (Atan2((c.y-b.p(n).y),(c.x-b.p(n).x)))
        b.p(n).ca=z
    Next n
   
    circle_sort(b.p(),c)
   
    Var S1=shortline(b.p(1),c,-1100)
    Line(s1.x,s1.y)-(b.p(1).x,b.p(1).y),Rgb(0,0,i)
    Var S2=shortline(b.p(4),c,-1100)
    Line(s2.x,s2.y)-(b.p(4).x,b.p(4).y),Rgb(0,0,i)
   
    Dim As pt ctr= v((s1.x+s2.x)\2,(s1.y+s2.y)\2)
    Var lngth=dist(b.p(0),b.p(1))
    Var s3=shortline(b.p(0),ctr,lngth*1.2)
    barebox(b1,i)
    Paint(s3.x,s3.y),Rgb(0,0,0),Rgb(0,0,i)
End Sub


Function inbox(b As box,mx As Integer,my As Integer) As Long
    Return mx>=b.p(1).x And mx<=b.p(3).x And my>=b.p(1).y And my<=b.p(3).y
End Function

Sub setupfloor(xres As Integer,yres As Integer,floor As Any Ptr)
    Dim As Long counter
    Dim As Ulong col
    For y As Long=-10 To yres+10 Step 100
        For x As Long=-10 To xres+10 Step 100
            counter+=1
            If counter Mod 2 Then col=Rgb(255,255,255) Else col=Rgb(0,100,200)
            Line floor,(x,y)-(x+100,y+100),col,bf
        Next x
    Next y
End Sub

Function checkseperation(b() As box,tst As pt,n As Integer,dx As Integer,dy As Integer) As Integer
    For z As Integer=1 To n
        If dist(b(z).p(0),tst) < (dx+dy) Then Return 0
    Next z
    Return -1
End Function

Sub setupboxes(b() As box,xres As Integer,yres As Integer)
    Redim b(0)
    Redim b(1 To IntRange(5,20))
    Var m=map(5,20,Ubound(b),150,30)'fewer boxes then make them bigger
    For n As Integer=1 To Ubound(b)
        Dim As Integer xx,yy,dx,dy
        Do
            dx=Intrange(30,m):dy=intrange(30,m)   
            xx=IntRange(xres/15,xres-xres/15-dx):yy=Intrange(yres/15,yres-yres/15-dy)
        Loop Until checkseperation(b(),v(xx,yy),n-1,dx,dy)
        b(n)=Type<box>(v(xx,yy),v(xx+dx,yy+dy),Rgb(Rnd*255,Rnd*255,Rnd*255))
        b(n).inc=n
    Next n
End Sub

'=====================================================
Redim As box b()
setupboxes(b(),xres,yres)

Dim As Any Ptr floor=Imagecreate(xres,yres)
setupfloor(xres,yres,floor)

Dim As Integer mx,my,mb,flag
Do
    Getmouse mx,my,,mb
    If mb=1 And flag=0 Then flag=1:setupboxes(b(),xres,yres)
    Screenlock
    Cls
    Put(0,0),floor,Alpha,255
   
    For n1 As Integer=Lbound(b) To Ubound(b)
        If inbox(b(n1),mx,my) =0 Then GetShadow(b(n1),v(mx,my))
    Next n1
   
    Put(0,0),floor,Alpha,100
    Draw String (5,5),"Click Mouse",0
    For n As Integer=1 To Ubound(b)
        barebox(b(n),,1)
    Next n
   
    Screenunlock
    Sleep 1,1
    flag=mb
Loop Until Len(Inkey)
Imagedestroy floor
Sleep
 

[dodicat]

Include circles, which are easy to do.
I shall try general polygons perhaps.

Code: Select all



Screen 20,32
Dim As Integer xres,yres
Screeninfo xres,yres
Type pt
    As Integer x,y
    Ca As Single 'angle to mouse(radians)
    #define v Type<pt>
End Type

#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define dist(a,b) sqr((a.x-b.x)*(a.x-b.x) + (a.y-b.y)*(a.y-b.y))
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Type box
    As pt p(0 To 4)
    col As Ulong
    inc As Integer
    Declare Constructor
    Declare Constructor(As pt,As pt,As Ulong)
End Type

Type Circle
    As pt ctr
    As Integer r
    As Ulong col
    As Integer inc
End Type


Constructor box:End Constructor

Constructor box(p1 As pt,p3 As pt,c As Ulong)
col=c
p(1)=p1:p(3)=p3
p(2).x=p(3).x:p(2).y=p(1).y
p(4).x=p(1).x:p(4).y=p(1).y+p(3).y-p(2).y
'p(0) is the box centroid
p(0).x=(p(1).x+p(2).x)\2
p(0).y=(p(2).y+p(3).y)\2
End Constructor

Function shortline(fp As pt,p As pt,length As Integer) As pt
    Dim As Single diffx=p.x-fp.x,diffy=p.y-fp.y
    Dim As Single L=Sqr(diffx*diffx+diffy*diffy)
    Return v(fp.x+length*diffx/L,fp.y+length*diffy/L)
End Function

Function compare (a1 As Single,a2 As Single)As Long
    Dim As Single pi=4*Atn(1)
    If Abs(a1)>pi/2 Or Abs(a2)>pi/2 Then
        If Sgn(a1)<>Sgn(a2) Then Return a2<a1
    End If
    Return a1<a2
End Function

Sub Circle_sort(p() As pt,c As pt)
    For p1 As Long  = 1 To 3
        For p2 As Long  = p1 + 1 To 4
            Var w= compare(p(p1).Ca,p(p2).Ca)
            If w Then Swap p(p1),p(p2)
        Next p2
    Next p1
   
End Sub

Sub barebox(bx1 As box,msg As Integer=0)
    If msg=0 Then
        Line (bx1.p(1).x,bx1.p(1).y)-(bx1.p(3).x,bx1.p(3).y),Rgb(0,0,Bx1.inc),b
    Else
        Line (bx1.p(1).x,bx1.p(1).y)-(bx1.p(3).x,bx1.p(3).y),bx1.col,bf
    End If
End Sub

Sub barecircle(C As Circle,msg As Integer=0)
    If msg=0 Then
        Circle(C.ctr.x,C.ctr.y),C.r,Rgb(0,C.inc,0)
    Else
        Circle(C.ctr.x,C.ctr.y),C.r,C.col,,,,f
    End If
End Sub

Sub GetBoxShadow(Byval b1 As box,c As pt)
    Dim As box b=b1
    Dim As Integer i=b.inc
    Dim As Single pi=4*Atn(1),z
    For n As Long=1 To 4
        z= (Atan2((c.y-b.p(n).y),(c.x-b.p(n).x)))
        b.p(n).ca=z
    Next n
   
    circle_sort(b.p(),c)
   
    Var S1=shortline(b.p(1),c,-1100)
    Line(s1.x,s1.y)-(b.p(1).x,b.p(1).y),Rgb(0,0,i)
    Var S2=shortline(b.p(4),c,-1100)
    Line(s2.x,s2.y)-(b.p(4).x,b.p(4).y),Rgb(0,0,i)
   
    Dim As pt ctr= v((s1.x+s2.x)\2,(s1.y+s2.y)\2)
    Var lngth=dist(b.p(0),b.p(1))
    Var s3=shortline(b.p(0),ctr,lngth*1.2)
    barebox(b1)
    Paint(s3.x,s3.y),Rgb(0,0,0),Rgb(0,0,i)
End Sub

Sub GetCircleShadow(C As Circle,p As pt)
    Var dx=(C.ctr.x-p.x),dy=(C.ctr.y-p.y)
    Swap dx,dy
    dx=-dx
    dx=C.ctr.x+dx:dy=C.ctr.y+dy
    Var s1=shortline(C.ctr,v(dx,dy),C.r)
    Var s2=shortline(s1,p,-1100)
    Var t1=s2
    Line(s1.x,s1.y)-(s2.x,s2.y),Rgb(0,C.inc,0)
    s1=shortline(C.ctr,v(dx,dy),-C.r)
    s2=shortline(s1,p,-1100)
    Var t2=s2
    Line(s1.x,s1.y)-(s2.x,s2.y),Rgb(0,C.inc,0)
    Var M=v((t1.x+t2.x)\2,(t1.y+t2.y)\2)
    Var p2=shortline(C.ctr,M,1.1*C.r)
    barecircle(C)
    Paint(p2.x,p2.y),Rgb(0,0,0),Rgb(0,C.inc,0)
End Sub

Function inbox(b As box,mx As Integer,my As Integer) As Long
    var bw=abs(b.p(1).x-b.p(2).x)/30
    var bh=abs(b.p(1).y-b.p(4).y)/30
    Return mx>=b.p(1).x-bw And mx<=b.p(3).x+bw And my>=b.p(1).y-bh And my<=b.p(3).y+bh
End Function

Function InCircle(b As Circle,mx As Integer,my As Integer) As Integer
    Return (b.ctr.x-mx)*(b.ctr.x-mx) +(b.ctr.y-my)*(b.ctr.y-my) < b.r*b.r
End Function

Sub setupfloor(xres As Integer,yres As Integer,floor As Any Ptr)
    Dim As Long counter
    Dim As Ulong col
    For y As Long=-10 To yres+10 Step 100
        For x As Long=-10 To xres+10 Step 100
            counter+=1
            If counter Mod 2 Then col=Rgb(255,255,255) Else col=Rgb(0,100,200)
            Line floor,(x,y)-(x+100,y+100),col,bf
        Next x
    Next y
End Sub

Function checkboxseperation(b() As box,tst As pt,n As Integer,dx As Integer,dy As Integer) As Integer
    For z As Integer=1 To n
        If dist(b(z).p(0),tst) < (dx+dy) Then Return 0
    Next z
    Return -1
End Function

Sub setupboxes(b() As box,xres As Integer,yres As Integer)
    Redim b(0)
    Redim b(1 To IntRange(5,20))
    Var m=map(5,20,Ubound(b),150,30)'fewer boxes then make them bigger
    For n As Integer=1 To Ubound(b)
        Dim As Integer xx,yy,dx,dy
        Do
            dx=Intrange(30,m):dy=intrange(30,m)   
            xx=IntRange(xres/15,xres-xres/15-dx):yy=Intrange(yres/15,yres-yres/15-dy)
        Loop Until checkboxseperation(b(),v(xx,yy),n-1,dx,dy)
        b(n)=Type<box>(v(xx,yy),v(xx+dx,yy+dy),Rgb(Rnd*255,Rnd*255,Rnd*255))
        b(n).inc=n
    Next n
End Sub

Function checkcircleseperation(b() As Circle,tst As pt,n As Integer,r As Integer) As Integer
    For z As Integer=1 To n
        If dist(b(z).ctr,tst) < (2*r) Then Return 0
    Next z
    Return -1
End Function

Sub setupCircles(b() As Circle,xres As Integer,yres As Integer)
    Redim b(0)
    Redim b(1 To IntRange(5,10))
    Var m=map(5,10,Ubound(b),50,20)'fewer circles then make them bigger
    For n As Integer=1 To Ubound(b)
        Dim As Integer xx,yy,dx,dy
        Dim As Integer rad
        Do
            rad=Intrange(30,m) 
            xx=IntRange(xres/15,xres-xres/15-dx):yy=Intrange(yres/15,yres-yres/15-dy)
        Loop Until checkcircleseperation(b(),v(xx,yy),n-1,rad)
        b(n)=Type<Circle>(v(xx,yy),rad,Rgb(Rnd*255,Rnd*255,Rnd*255))
        b(n).inc=n
    Next n
End Sub
'==========================================================
Redim As Circle circles()
setupCircles(circles(),xres,yres)

Redim As box b()
setupboxes(b(),xres,yres)

Dim As Any Ptr floor=Imagecreate(xres,yres)
setupfloor(xres,yres,floor)
Dim As Circle blankc
Dim As box blankb
Dim As Integer mx,my,mb,flag
Do
    Getmouse mx,my,,mb
    If mb=1 And flag=0 Then flag=1:setupboxes(b(),xres,yres):setupcircles(circles(),xres,yres)
    Screenlock
    Cls
    Put(0,0),floor,Alpha,255
   
    For n1 As Integer=Lbound(b) To Ubound(b)
        If inbox(b(n1),mx,my) =0 Then GetBoxShadow(b(n1),v(mx,my))
    Next n1
    For n1 As Integer=Lbound(circles) To Ubound(circles)
        If inCircle(circles(n1),mx,my) =0 Then GetCircleShadow(circles(n1),v(mx,my))
    Next n1
   
    Put(0,0),floor,Alpha,100
    Draw String (5,5),"Click Mouse",0
    For n As Integer=1 To Ubound(b)
        barebox(b(n),1)
    Next n
    For n As Integer=1 To Ubound(circles)
        barecircle(circles(n),1)
    Next n
   
    Screenunlock
    Sleep 1,1
    flag=mb
Loop Until Len(Inkey)
Imagedestroy floor
Sleep