Shadowing

[MasterGy]

I added a sphere and transparency. Set an image at the beginning of the code!

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