Shadowing - Printable Version

Code: (Select All)
'picture$ = "eye.bmp" '<-------- enter an image or leave the field blank

picture$ = "earth.jpg" '<-------- enter an image or leave the field blank







'texture set alpha

If _FileExists(picture$) Then temp2 = _LoadImage(picture$, 32) Else temp2 = _NewImage(1, 1, 32): _Dest temp2: Cls , _RGB(255, 255, 255)

_Dest temp2: _SetAlpha 120: text = _CopyImage(temp2, 33): _FreeImage temp2



'window

monx = 800: mony = Int(monx / _DesktopWidth * _DesktopHeight): monm = monx * .008: mon = _NewImage(monx, mony, 32): Screen mon: _FullScreen: _DisplayOrder _Hardware , _Software



Const pip180 = 3.141592 / 180

Dim Shared me(9)



'cube locations, sizes

Randomize Timer

Dim Shared shdw_text: cube_res = 5: shdw_deep = 256

temp = _NewImage(cube_res - 1, shdw_deep - 1, 32): _Dest temp: For t = 0 To cube_res - 1: For t2 = 0 To shdw_deep - 1

PSet (t, t2), _RGBA32(0, 0, 0, Int(255 / (shdw_deep - 1) * t2) - 3): Next t2, t: shdw_text = _CopyImage(temp, 33): _FreeImage temp

Dim Shared shp(2): shp(0) = 1: shp(1) = cube_res / 2: shp(2) = cube_res - 2

Dim Shared shdw_m(15000): For t = 0 To 15000: shdw_m(t) = Interpolate(.99, .97, 1 / 15000 * t): Next t 'mask distance behind texture





mapdim = 1000: mtp_c = 10000: ord_c = 200000: Dim ord(ord_c - 1) As _Unsigned Long



'make cubes

size = mapdim

cube_c = 12

If cube_c Then

    Dim obj(cube_c - 1, 9): For t = 0 To cube_c - 1

        For t2 = 0 To 2: obj(t, t2) = mapdim * Rnd: obj(t, t2 + 3) = 20 + 50 * Rnd: obj(t, 6) = _Pi * Rnd * .2: obj(t, 7) = _Pi * Rnd * .2

    obj(t, 8) = 0.02 * (Rnd - .5): obj(t, 9) = 0.02 * (Rnd - .5): Next t2, t

End If



'make spheres

sph_c = 5

If sph_c Then

    Dim sp(sph_c, 10): For t = 0 To sph_c - 2: For t2 = 0 To 2

        sp(t, t2) = mapdim * Rnd: sp(t, t2 + 3) = 35 + 35 * Rnd: sp(t, 6) = _Pi * Rnd * .2: sp(t, 7) = _Pi * Rnd * .2

    sp(t, 8) = 0.02 * (Rnd - .5): sp(t, 9) = 0.02 * (Rnd - .5): Next t2, t

End If

For t = 0 To 2: sp(sph_c - 1, 3 + t) = mapdim * .8: sp(sph_c - 1, t) = mapdim / 2: Next t: sp(sph_c - 1, 10) = 1









Dim Shared pc(2999, 19), p_set(9)



'install spheres













For t = 0 To 2: me(t) = mapdim / 2: Next t: light = .2: ylook_limit = 80 * pip180 'radian

_Dest mon

Locate 1, 1: Print "moving:WASD       looking:mouse        light adjust : mousewheel"

Dim p(9, 2, mtp_c - 1), pi(3, mtp_c - 1), py(3, mtp_c - 1)

limit_comm = 1

Do: If limit_comm Then _Limit 30

    If InKey$ = "l" Then limit_comm = limit_comm Xor 1

    'control

    mouse_sens_xy = .01: mouse_sens_z = .01

    mousex = 0: mousey = 0: mousew = 0: While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mousew = mousew + _MouseWheel: Wend

    me(3) = me(3) - mousex * mouse_sens_xy: me(4) = me(4) + mousey * mouse_sens_z



    If ylook_limit < Abs(me(4)) Then me(4) = ylook_limit * Sgn(me(4))



    me(5) = (me(5) - mousex * .001 * Abs(Sin(me(4)))) * .9

    light = light - mousew * 0.002 + (_MouseButton(2) - _MouseButton(1)) * .008



    If light < 0 Then light = 0 Else If light > 1 Then light = 1

    Locate 2, 1: Print "light:"; Int(light * 100); "%   "

    position_speed = 10: kw = _KeyDown(119): ks = _KeyDown(115): ka = _KeyDown(97): kd = _KeyDown(100): new_direction = (Abs(ka Or kd Or kw) Or -Abs(ks)) * position_speed

    dirx = new_direction: diry = 0: dirz = 0: rotate_2d dirx, diry, -me(4): rotate_2d dirx, dirz, -(me(3) + ((kd - ka)) * _Pi / 2) - _Pi / 2

    me(0) = me(0) + dirx: me(1) = me(1) + diry: me(2) = me(2) + dirz: light2 = light ^ 1 '+ Sin(Timer*10) * .005



    mtc = 0



    'draw cubes

    If cube_c Then

        p_set(0) = shdw_deep - 3: c_dis = Interpolate(50, 2500, light2): p_set(1) = shdw_deep / c_dis

        For a_obj = 0 To cube_c - 1: For t = 0 To 7: For t2 = 0 To 2: pc(t, t2) = obj(a_obj, 3 + t2) * (Sgn(t And 2 ^ t2) * 2 - 1): Next t2

            rotate_2d pc(t, 0), pc(t, 1), obj(a_obj, 6): rotate_2d pc(t, 0), pc(t, 2), obj(a_obj, 7)

            For t2 = 0 To 2: pc(t, t2) = pc(t, t2) + (obj(a_obj, t2) - me(t2)): Next t2: point_set t: Next t

            For t = 0 To 5: For t2 = 0 To 3: side = Val(Mid$("024623673175105445670123", 1 + t * 4 + t2, 1))

                For t3 = 0 To 2: p(t2, t3, mtc) = pc(side, t3): p(t2 + 4, t3, mtc) = pc(side, t3 + 4): Next t3: py(t2, mtc) = pc(side, 7): Next t2

        pi(0, mtc) = 0: pi(1, mtc) = _Width(text) - 1:: pi(2, mtc) = 0: pi(3, mtc) = _Height(text) - 1: mtc = mtc + 1: Next t, a_obj

    End If



    'draw spheres

    If sph_c Then

        c_dis = Interpolate(20, 2500, light2): p_set(1) = shdw_deep / c_dis: sp_minres = 9: sp_maxres = 32

        For a_obj = 0 To sph_c - 1

            dis = Abs(Sqr((me(0) - sp(a_obj, 0)) ^ 2 + (me(1) - sp(a_obj, 1)) ^ 2 + (me(2) - sp(a_obj, 2)) ^ 2) - sp(a_obj, 3))

            da = Int(Interpolate(sp_maxres, sp_minres, 1 / 600 * dis))

            If da < sp_minres Then da = sp_minres Else If da > sp_maxres Then da = sp_maxres

            If sp(a_obj, 10) Then da = sp_maxres

            db = Int(da * .7): ssq_c = Int((da - 1) * db): temp0 = _Pi / (db - 1): temp1 = _Width(text) / (da - 1): temp2 = _Height(text) / (db - 1): temp3 = 2 * _Pi / (da - 1)

            For da2 = 0 To da: dega = temp3 * da2: For db2 = 0 To db: degb = temp0 * db2: ap = Int(da2 * db + db2)

                pc(ap, 0) = Sin(degb) * Cos(dega) * sp(a_obj, 3): pc(ap, 1) = Sin(degb) * Sin(dega) * sp(a_obj, 4): pc(ap, 2) = Cos(degb) * sp(a_obj, 5)

                rotate_2d pc(ap, 0), pc(ap, 1), sp(a_obj, 6): rotate_2d pc(ap, 0), pc(ap, 2), sp(a_obj, 7)

                For t = 0 To 2: pc(ap, t) = pc(ap, t) + (sp(a_obj, t) - me(t)): Next t: point_set ap

                    pc(ap, 10) = ap: pc(ap, 11) = pc(ap, 10) + db: pc(ap, 12) = pc(ap, 10) + 1: pc(ap, 13) = pc(ap, 12) + db

                    pc(ap, 14) = (temp1 * da2) - 1: pc(ap, 15) = (temp1 * (da2 + 1)) - 1

            pc(ap, 16) = Int(temp2 * db2): pc(ap, 17) = Int(temp2 * (db2 + 1)): Next db2, da2

            For ap = 0 To ssq_c - 1: For t = 0 To 3: who = pc(ap, 10 + t): For t2 = 0 To 2

                p(t, t2, mtc) = pc(who, t2): p(t + 4, t2, mtc) = pc(who, t2 + 4): Next t2: py(t, mtc) = pc(who, 7)

        pi(t, mtc) = pc(ap, 14 + t): Next t: mtc = mtc + 1: Next ap, a_obj

    End If







    For t = 0 To ord_c - 1: ord(t) = 0: Next t

    For a = 0 To mtc - 1: x = Abs(Int((p(0, 2, a) + p(1, 2, a) + p(2, 2, a) + p(3, 2, a)) * 20)): If x > ord_c - 1 Then _Continue

    Do While ord(x) And x < ord_c - 1: x = x + 1: Loop: ord(x) = a + 1: Next a





    For t = ord_c - 1 To 0 Step -1: If ord(t) = 0 Then _Continue

        a = ord(t) - 1: For t1 = 0 To 1: t2 = t1 * 3

            _MapTriangle (pi(0 + t1, a), pi(2 + t1, a))-(pi(1, a), pi(2, a))-(pi(0, a), pi(3, a)), text To(p(t2, 0, a), p(t2, 1, a), p(t2, 2, a))-(p(1, 0, a), p(1, 1, a), p(1, 2, a))-(p(2, 0, a), p(2, 1, a), p(2, 2, a)), , _Smooth

            _MapTriangle (shp(0), py(t2, a))-(shp(1), py(1, a))-(shp(2), py(2, a)), shdw_text To(p(4 + t2, 0, a), p(4 + t2, 1, a), p(4 + t2, 2, a))-(p(5, 0, a), p(5, 1, a), p(5, 2, a))-(p(6, 0, a), p(6, 1, a), p(6, 2, a)), , _Smooth

    Next t1, t



    _Display





    For a_obj = 0 To cube_c - 1: obj(a_obj, 6) = obj(a_obj, 6) + obj(a_obj, 8): obj(a_obj, 7) = obj(a_obj, 7) + obj(a_obj, 9): Next a_obj: 'cubes rotating

    For a_obj = 0 To sph_c - 1: sp(a_obj, 6) = sp(a_obj, 6) + sp(a_obj, 8): sp(a_obj, 7) = sp(a_obj, 7) + sp(a_obj, 9): Next a_obj 'spheres rotating

Loop

Function Interpolate (a, b, x): Interpolate = a + (b - a) * x: End Function

Sub rotate_2d (x, y, ang): x1 = x * Cos(ang) - y * Sin(ang): y1 = x * Sin(ang) + y * Cos(ang): x = x1: y = y1: End Sub

Sub rotate_3d (x, y, z, ang1, ang2, ang3): rotate_2d x, z, ang1: rotate_2d y, z, ang2: rotate_2d x, y, ang3: End Sub

Sub point_set (ap): rotate_3d pc(ap, 0), pc(ap, 1), pc(ap, 2), me(3), me(4), me(5): pc(ap, 3) = Abs(pc(ap, 2)): If pc(ap, 2) < 0 Then sm = Int(pc(ap, 2)) Else sm = 0

    If sm < 0 Then sm = 0

    sm = shdw_m(sm): For t2 = 0 To 2: pc(ap, 4 + t2) = pc(ap, t2) * sm: Next t2: pc(ap, 7) = Int(p_set(1) * pc(ap, 3)): If pc(ap, 7) > p_set(0) Then pc(ap, 7) = p_set(0)

End Sub