## 2D shadows

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
Westbeam
Posts: 239
Joined: Dec 22, 2009 9:24
Contact:

### 2D shadows

Good morning coders :)

I made realtime shadows for 2D games today:

Here is the code:

Code: Select all

`ScreenRes 800,600,32Dim As Integer mx,myConst Rad2Deg=45.0/Atn(1)CONST PI AS DOUBLE = ACOS(0)*2RandomizeDim As Integer cubex(4),cubey(4),cubexscale(4),cubeyscale(4),cubecolor(4,3),switchDim 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   NextNextDim As Any Ptr floor=ImageCreate(800,600)Line floor,(0,0)-(800,600),RGB(8,0,7),BFFor 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   NextNextDo   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   ScreenUnlockLoop Until Inkey=Chr(27)End`

You can move the light with the mouse. Have fun :)
MrSwiss
Posts: 3657
Joined: Jun 02, 2013 9:27
Location: Switzerland

### Re: 2D shadows

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, angle4End Type'Dim As aCube Cube(1 To 4)       ' 4 Elements (BASE: 1)`
Accessing the Type:

Code: Select all

`Cube(index).xCube(index).colr(i2)`
this will shorten your Code and improve readability ...
Westbeam
Posts: 239
Joined: Dec 22, 2009 9:24
Contact:

### Re: 2D shadows

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
Posts: 2176
Joined: May 24, 2007 22:10
Location: The Netherlands

### Re: 2D shadows

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
Posts: 1785
Joined: Jun 21, 2005 19:04

### Re: 2D shadows

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
Posts: 1025
Joined: Jun 20, 2005 21:40
Contact:

### Re: 2D shadows

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
Posts: 2176
Joined: May 24, 2007 22:10
Location: The Netherlands

### Re: 2D shadows

Thanks, that is the one!
h4tt3n
Posts: 694
Joined: Oct 22, 2005 21:12
Location: Denmark

### Re: 2D shadows

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,32Dim As Integer mx,myDim As Integer num_cubes = 16Randomize TimerDim As Integer cubex(num_cubes),cubey(num_cubes),cubexscale(num_cubes),cubeyscale(num_cubes),cubecolor(num_cubes,3),switchDim 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   NextNextDim As Any Ptr floor=ImageCreate(800,600)Line floor,(0,0)-(800,600),RGB(8,0,7),BFFor 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   NextNextDo   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   ScreenUnlockLoop 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)^-1Const PI as double = ATN(1)*4Const TWOPI as double = PI*2Const Antumbra as double = 0.349065850398865Sub 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 Subscreenres 640,480,32,2screenset 1,0setmouse ,,0Dim as integer ptr ImgDim as integer mx, myImg = ImageCreate(640,480)Bload "ShadowTest.bmp", ImgDo      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)    flipLoop until inkey\$ <> ""ImageDestroy Imgsleepend`

Cheers, Mike
D.J.Peters
Posts: 8203
Joined: May 28, 2005 3:28
Contact:

### Re: 2D shadows

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
Last edited by D.J.Peters on Sep 25, 2017 21:51, edited 1 time in total.
Lost Zergling
Posts: 369
Joined: Dec 02, 2011 22:51
Location: France

### Re: 2D shadows

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
Posts: 694
Joined: Oct 22, 2005 21:12
Location: Denmark

### Re: 2D shadows

Lost Zergling wrote: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
Posts: 239
Joined: Dec 22, 2009 9:24
Contact:

### Re: 2D shadows

Thank you for all the help :)

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

Code: Select all

`ScreenRes 800,600,32RandomizeConst Light_Range=1000Const 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)->heightSub 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    NextEnd SubDim As Any Ptr Texture_Roof1=ImageCreate(100,100)Line Texture_Roof1,(0,0)-(100,100),RGB(46,37,51),BFDim As Any Ptr Texture_Roof2=ImageCreate(100,100)Line Texture_Roof2,(0,0)-(100,100),RGB(56,28,19),BFDim As Any Ptr Roof_Tile1=ImageCreate(11,6)Line Roof_Tile1,(0,0)-(10,5),RGB(46,37,51),BLine Roof_Tile1,(0,5)-(10,5),RGB(29,19,30)Line Roof_Tile1,(1,1)-(9,2),RGB(114,107,126),BFLine Roof_Tile1,(1,3)-(9,4),RGB(77,74,93),BFDim As Any Ptr Roof_Tile1R=ImageCreate(11,6)Line Roof_Tile1R,(0,0)-(10,5),RGB(43,35,32),BLine Roof_Tile1R,(0,5)-(10,5),RGB(23,19,18)Line Roof_Tile1R,(1,1)-(9,2),RGB(124,101,93),BFLine Roof_Tile1R,(1,3)-(9,4),RGB(84,68,63),BFDim 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),BFNextLine Roof_Tile2(0),(0,0)-(7,2),RGB(77,74,93),BFLine Roof_Tile2(0),(1,3)-(6,3),RGB(77,74,93)Line Roof_Tile2(1),(0,0)-(7,2),RGB(114,107,126),BFLine Roof_Tile2(1),(1,3)-(6,3),RGB(114,107,126)Line Roof_Tile2(2),(0,0)-(7,2),RGB(61,55,72),BFLine Roof_Tile2(2),(1,3)-(6,3),RGB(61,55,72)Line Roof_Tile2(3),(0,0)-(7,2),RGB(77,74,93),BFLine Roof_Tile2(3),(1,3)-(6,3),RGB(77,74,93)Line Roof_Tile2(4),(0,0)-(7,2),RGB(77,74,93),BFLine Roof_Tile2(4),(1,3)-(6,3),RGB(77,74,93)Line Roof_Tile2(5),(0,0)-(7,2),RGB(61,55,72),BFLine Roof_Tile2(5),(1,3)-(6,3),RGB(61,55,72)Line Roof_Tile3(0),(0,2)-(7,3),RGB(77,74,93),BFLine Roof_Tile3(0),(1,1)-(6,1),RGB(77,74,93)Line Roof_Tile3(1),(0,2)-(7,3),RGB(114,107,126),BFLine Roof_Tile3(1),(1,1)-(6,1),RGB(114,107,126)Line Roof_Tile3(2),(0,2)-(7,3),RGB(61,55,72),BFLine Roof_Tile3(2),(1,1)-(6,1),RGB(61,55,72)Line Roof_Tile3(3),(0,2)-(7,3),RGB(77,74,93),BFLine Roof_Tile3(3),(1,1)-(6,1),RGB(77,74,93)Line Roof_Tile3(4),(0,2)-(7,3),RGB(77,74,93),BFLine Roof_Tile3(4),(1,1)-(6,1),RGB(77,74,93)Line Roof_Tile3(5),(0,2)-(7,3),RGB(61,55,72),BFLine 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),BFFor i As Integer=0 To 10   Put Texture_Roof1,(i*10,48),Roof_Tile1,TransNextFor 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   NextNextFor 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   NextNextPut Texture_Roof2,(0,0),Texture_Roof1,TransApply_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,TransNextDim As Integer mx,myType 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 ShadowEnd TypeDim Shared As TCube Cube(cubes)Dim As Integer ScrollX,ScrollYDim As Integer cubex(cubes),cubey(cubes),cubexscale(cubes),cubeyscale(cubes),cubecolor(cubes,3),switchDim 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 WithNextDim As Any Ptr floor=ImageCreate(800,600)Line floor,(0,0)-(800,600),RGB(8,0,7),BFFor 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   NextNextDo   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   ScreenUnlockLoop 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
Posts: 6755
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: 2D shadows

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,32Dim As Integer xres,yresScreeninfo xres,yresType 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 TypeConstructor box:End ConstructorConstructor box(p1 As pt,p3 As pt,c As Ulong)col=cp(1)=p1:p(3)=p3p(2).x=p(3).x:p(2).y=p(1).yp(4).x=p(1).x:p(4).y=p(1).y+p(3).y-p(2).y'p(0) is the box centroidp(0).x=(p(1).x+p(2).x)\2p(0).y=(p(2).y+p(3).y)\2End ConstructorFunction 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 FunctionFunction 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<a2End FunctionSub 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 SubSub 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 nEnd SubSub 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.colEnd SubSub 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 SubFunction 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).yEnd FunctionSub 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 yEnd SubFunction 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 -1End FunctionSub 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 nEnd 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,flagDo    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=mbLoop Until Len(Inkey)Imagedestroy floorSleep `
dodicat
Posts: 6755
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: 2D shadows

This one is more general:

Code: Select all

`Screen 20,32Dim As Integer xres,yresScreeninfo xres,yresType 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 TypeConstructor box:End ConstructorConstructor box(p1 As pt,p3 As pt,c As Ulong)col=cp(1)=p1:p(3)=p3p(2).x=p(3).x:p(2).y=p(1).yp(4).x=p(1).x:p(4).y=p(1).y+p(3).y-p(2).y'p(0) is the box centroidp(0).x=(p(1).x+p(2).x)\2p(0).y=(p(2).y+p(3).y)\2End ConstructorFunction 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 FunctionFunction 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<a2End FunctionSub 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 SubSub 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 IfEnd SubSub 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 SubFunction 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).yEnd FunctionSub 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 yEnd SubFunction 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 -1End FunctionSub 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 nEnd 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,flagDo    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=mbLoop Until Len(Inkey)Imagedestroy floorSleep `
dodicat
Posts: 6755
Joined: Jan 10, 2006 20:30
Location: Scotland

### Re: 2D shadows

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

Code: Select all

`Screen 20,32Dim As Integer xres,yresScreeninfo xres,yresType 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 TypeType Circle    As pt ctr    As Integer r    As Ulong col    As Integer incEnd TypeConstructor box:End ConstructorConstructor box(p1 As pt,p3 As pt,c As Ulong)col=cp(1)=p1:p(3)=p3p(2).x=p(3).x:p(2).y=p(1).yp(4).x=p(1).x:p(4).y=p(1).y+p(3).y-p(2).y'p(0) is the box centroidp(0).x=(p(1).x+p(2).x)\2p(0).y=(p(2).y+p(3).y)\2End ConstructorFunction 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 FunctionFunction 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<a2End FunctionSub 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 SubSub 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 IfEnd SubSub 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 IfEnd SubSub 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 SubSub 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 SubFunction 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+bhEnd FunctionFunction 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.rEnd FunctionSub 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 yEnd SubFunction 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 -1End FunctionSub 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 nEnd SubFunction 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 -1End FunctionSub 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 nEnd 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 blankcDim As box blankbDim As Integer mx,my,mb,flagDo    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=mbLoop Until Len(Inkey)Imagedestroy floorSleep `

Return to “Tips and Tricks”

### Who is online

Users browsing this forum: jj2007 and 8 guests