Shadowing

[bplus]

Oh I read the mid$ and the drawing as figuring out which plane (surface) to draw.

[james2464]

Yeah that's it for sure, selecting a plane. But for some reason instead of "plane 1, plane 2" etc, or it uses the corner numbers and then grabs those from that string. It seems like a neat way to go about this. I would have had separate strings, like side1$ = "0246" and so on.

[OldMoses]

So how many lines when Double Parking colons, :, removed?

Anyone got a quick app? Eh, has to distinguish a single line IF with block IF to insert END IF's in correct place.

Playing with it a bit, I chopped it down for ease of reading and I come in around 120 or so, excluding comments and whitespace. Still impressive.

[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

[bplus]

Wow, MasterGy continues to amaze!

[mnrvovrfc]

@MasterGy thank you for creating this program. Also for allowing left and right mouse button presses to adjust the light although the top of the program screen says "mousewheel" to do it. One modification I would make is checking for "escape" key press to leave the program. But that's just me.