Welcome, Guest
You have to register before you can post on our site.

Username/Email:
  

Password
  





Search Forums

(Advanced Search)

Forum Statistics
» Members: 308
» Latest member: Donaldvem
» Forum threads: 1,741
» Forum posts: 17,901

Full Statistics

Latest Threads
The QB64 IDE shell
Forum: Utilities
Last Post: JasonPag
09-16-2024, 05:37 PM
» Replies: 9
» Views: 762
Importance regarding Ches...
Forum: Utilities
Last Post: JasonPag
09-01-2024, 06:34 PM
» Replies: 0
» Views: 31
Chess and Analysis and En...
Forum: Utilities
Last Post: JasonPag
08-28-2024, 02:37 PM
» Replies: 0
» Views: 32
DAY 009:_PutImage
Forum: Keyword of the Day!
Last Post: grymmjack
09-02-2023, 02:57 PM
» Replies: 54
» Views: 2,034
Fall Banner Contest?
Forum: Site Suggestions
Last Post: grymmjack
08-31-2023, 11:50 PM
» Replies: 36
» Views: 1,261
ColorPicker - Function th...
Forum: Dav
Last Post: Dav
08-31-2023, 11:04 PM
» Replies: 3
» Views: 315
Goals(1) = New Tile()
Forum: Works in Progress
Last Post: RhoSigma
08-31-2023, 09:45 PM
» Replies: 3
» Views: 127
micro(A)v11
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:14 PM
» Replies: 90
» Views: 3,589
Updating The Single Most ...
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 09:13 PM
» Replies: 7
» Views: 254
QBJS Image Question
Forum: QBJS, BAM, and Other BASICs
Last Post: bplus
08-31-2023, 05:49 PM
» Replies: 5
» Views: 155

 
  3D Ferris Wheel
Posted by: james2464 - 02-10-2023, 05:44 AM - Forum: Programs - Replies (4)

A while ago I made a Ferris Wheel program and recently I've been tinkering with 3D stuff so I thought I'd give it another try.

I'll post both programs below.   No attachments needed but the 3D version might be a little much for a slower computer.   Thank goodness for speedy hardware images  Big Grin

There are controls in the new version if you're interested.   

Move around using WASD keys and mouse.   The L&R arrow keys control the wheel direction and speed.   The up arrow puts you in one of the seats.   The down arrow puts you back down on the ground.    And the F key allows you to fly around in ghost mode.   

Cheers!




Code: (Select All)
'ferris wheel
'james2464 - Nov 11 2022 - Radian Ferris Wheel

Dim Shared scx, scy As Integer
scx = 800: scy = 600
Screen _NewImage(scx, scy, 32)

Const PI = 3.141592654#
Randomize Timer

Dim Shared bg&
bg& = _NewImage(scx + 1, scy + 1, 32)

Dim Shared c(100) As Long
colour1

background1
_PutImage (1, 1)-(scx - 1, scy - 1), 0, bg&, (1, 1)-(scx - 1, scy - 1) 'take snapshot of screen



'origin
xx = 400
yy = 300
w = 220 'wheel radius
p = 17 'number of positions
'=====================================================
h = _Hypot(w, 0)
h1 = _Atan2(0, w)
'=====================================================
Do
    _Limit 30
    Cls
    _PutImage (0, 0)-(scx, scy), bg&, 0 'draw background
    Circle (xx, yy), w, c(0)
    Line (xx, yy)-(xx - 50, yy + w + 40), c(0)
    Line (xx, yy)-(xx + 50, yy + w + 40), c(0)
    Line (xx - 50, yy + w + 40)-(xx + 50, yy + w + 40), c(0)
    h1 = h1 + .002
    If h1 >= PI * 2 Then h1 = 0
    '-------------------------------------------------
    For t = 1 To p
        h2 = h1 + ((PI * 2) / p) * t
        x = Cos(h2) * h: y = Sin(h2) * h
        Line (xx, yy)-(xx + x, yy + y), c(0)
        Line (xx + x - 7, yy + y - 1)-(xx + x + 7, yy + y + 1), c(12), BF
        Line (xx + x, yy + y)-(xx + x, yy + y + 15), c(0)
        Line (xx + x - 7, yy + y + 15)-(xx + x + 7, yy + y + 25), c(12), BF
    Next t
    _Display
Loop

Sub background1
    Cls
    Line (1, 1)-(scx - 1, scy - 1), c(1), BF

    y = 400
    For t = 1 To y
        m = 255 * ((400 - t) / 400)
        c(99) = _RGBA(150, 150, 255, m)
        Line (1, t)-(scx - 1, t), c(99)
    Next t

    ty = scy - y
    For t = y To scy
        t2 = ((scy - t) * 2)
        m = 255 * ((scy - t2) / scy)
        c(99) = _RGBA(50, 150, 50, m)
        Line (1, t)-(scx - 1, t), c(99)
    Next t
End Sub



Sub colour1
    c(0) = _RGB(0, 0, 0)
    c(1) = _RGB(255, 255, 255)
    c(2) = _RGB(255, 255, 0)
    c(3) = _RGB(255, 0, 0)
    c(4) = _RGB(0, 255, 0)
    c(5) = _RGB(0, 255, 255)
    c(6) = _RGB(255, 0, 255)
    c(7) = _RGB(30, 30, 255)
    c(8) = _RGB(150, 150, 250)
    c(9) = _RGB(250, 150, 150)
    c(10) = _RGB(150, 250, 150)
    c(11) = _RGB(150, 150, 255) 'sky blue
    c(12) = _RGB(125, 75, 125) 'cars
    c(13) = _RGB(255, 0, 0)
    c(14) = _RGB(50, 150, 50) 'ground
    c(15) = _RGB(0, 255, 255)
    c(16) = _RGB(255, 0, 255)
    c(17) = _RGB(30, 30, 255)
    c(18) = _RGB(150, 150, 250)
    c(19) = _RGB(250, 150, 150)
    c(20) = _RGB(150, 250, 150)
    c(21) = _RGB(255, 255, 255)
    c(22) = _RGB(255, 255, 0)
    c(23) = _RGB(255, 0, 0)
    c(24) = _RGB(0, 255, 0)
    c(25) = _RGB(0, 255, 255)
    c(26) = _RGB(255, 0, 255)
    c(27) = _RGB(30, 30, 255)
    c(28) = _RGB(150, 150, 250)
    c(29) = _RGB(250, 150, 150)
    c(30) = _RGBA(0, 0, 0, 5)
End Sub


Code: (Select All)
'3d Ferris Wheel - james2464 - Feb 2023
'Credit to MasterGy for 3D programming help and support

'CONTROLS
'UP ARROW = Ride Ferris Wheel
'DOWN ARROW = Walk on ground
'LEFT ARROW = Rotate wheel CCW (+ speed)
'RIGHT ARROW = Rotate wheel CW (+ speed)
'F KEY = Free float (ghost mode)


Option _Explicit
Randomize Timer

Screen _NewImage(1000, 1000, 32)

Const pip180 = 3.141592 / 180

Dim Shared c(100) As Long
Dim scr, da, db, da2, dega, db2, degb, ss, ap, sqa
Dim sky_points, sky_image, actual_point, asq
Dim wx0, wy0, wz0, wx1, wy1, wz1, wx2, wy2, wz2, wx3, wy3, wz3, sx0, sy0, sx1, sy1, sx2, sy2, sx3, sy3
Dim Shared mousex, mousey, mw, mouse_sens, vec_x, vec_y, vec_z, speed, moving
Dim sp3
Dim t
Dim Shared trx(5000), try(5000), trz(5000) 'terrain points
Dim Shared fr1(5000), fr2(5000), fr3(5000) 'terrain point groups
Dim Shared maxterrain
Dim Shared deep(1000, 1000), ed(4)
Dim Shared xm, ym
Dim Shared or1(5), key1, keyct, oc
Dim Shared pmode, rspd





maketerrain


Cls


colour1

Dim Shared ground1, sky1, cbx(200)



ground1 = _NewImage(500, 500, 32): makeground
sky1 = _NewImage(750, 750, 32): makesky

For t = 1 To 20: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette

Dim Shared tximage(200)
For t = 1 To 20: tximage(t) = _CopyImage(cbx(t), 33): Next t

tximage(0) = _CopyImage(ground1, 33)

Type rawobject
    n As Integer 'object drawing number
    n2 As Integer 'drawing detail number
    n3 As Integer 'total number of details
    x1 As Single
    y1 As Single
    z1 As Single
    x2 As Single
    y2 As Single
    z2 As Single
    x3 As Single
    y3 As Single
    z3 As Single
    x4 As Single
    y4 As Single
    z4 As Single
    ix As Single 'image x
    iy As Single 'image y
    in As Integer 'image number - tximage()
End Type
Dim Shared raw(2000) As rawobject

Type xyzgroup
    x As Single
    y As Single
    z As Single
End Type

Type axisgroup
    xy As Single
    yz As Single
    xz As Single
End Type


Type mapobject
    det As rawobject 'details
    pos1 As xyzgroup 'position
    ori As axisgroup 'orientation
    vel1 As xyzgroup 'velocity
    sp As Single 'speed
    sc As Single 'scale
End Type

Dim Shared foo(900) As mapobject 'fixed objects eg water
Dim Shared moo(3900) As mapobject 'moveable objects

'create texture point data array
Dim Shared tx(1500, 19), txtot, rawtxtot, mootxtot

'objects and data points
Data 1,1,1,-1000,0,200,-1000,0,-200,1000,0,200,1000,0,-200,500,100,12: 'wall
Data 2,1,1,-4000,-4000,0,-4000,4000,0,4000,-4000,0,4000,4000,0,500,100,3: 'water
Data 3,1,6,-2,-20,10.01,2,-20,10.01,-2,20,10.01,2,20,10.01,100,100,15: 'axle
Data 3,2,6,2,-20,10.01,-2,-20,10.01,2,-20,0,-2,-20,0,100,100,13: 'end
Data 3,3,6,2,20,10.01,-2,20,10.01,2,20,0,-2,20,0,100,100,13: 'end
Data 4,1,6,-.4,-.4,27,.4,-.4,27,-.4,-.4,-20,.4,-.4,-20,100,100,13: 'main beam
Data 4,2,6,-.4,.4,27,.4,.4,27,-.4,.4,-20,.4,.4,-20,100,100,13
Data 4,3,6,-.4,-.4,27,-.4,.4,27,-.4,-.4,-20,-.4,.4,-20,100,100,15
Data 4,4,6,.4,-.4,27,.4,.4,27,.4,-.4,-20,.4,.4,-20,100,100,15
Data 4,5,6,.4,-.4,-20,.4,.4,-20,-.4,-.4,-20,-.4,.4,-20,100,100,10: 'end
Data 4,6,6,.4,-.4,27,.4,.4,27,-.4,-.4,27,-.4,.4,27,100,100,10: 'end
Data 5,1,6,-.1,-.1,-5,.1,-.1,-5,-.1,-.1,-64.5,.1,-.1,-64.5,100,100,7: 'thin beam
Data 5,2,6,-.1,.1,-5,.1,.1,-5,-.1,.1,-64.5,.1,.1,-64.5,100,100,7
Data 5,3,6,-.1,-.1,-5,-.1,.1,-5,-.1,-.1,-64.5,-.1,.1,-64.5,100,100,8
Data 5,4,6,.1,-.1,-5,.1,.1,-5,.1,-.1,-64.5,.1,.1,-64.5,100,100,8
Data 6,1,6,45.9,45.9,-4.95,46.1,45.9,-4.95,45.9,45.9,4.95,46.1,45.9,4.95,100,100,7: 'thin short beam
Data 6,2,6,45.9,46.1,-4.95,46.1,46.1,-4.95,45.9,46.1,4.95,46.1,46.1,4.95,100,100,7
Data 6,3,6,45.9,45.9,-4.95,45.9,46.1,-4.95,45.9,45.9,4.95,45.9,46.1,4.95,100,100,8
Data 6,4,6,46.1,45.9,-4.95,46.1,46.1,-4.95,46.1,45.9,4.95,46.1,46.1,4.95,100,100,8
Data 7,1,4,-8.42,-4.8,-63.9,8.42,-4.8,-63.9,-8.59,-4.8,-65.2,8.59,-4.8,-65.2,100,100,15: 'outer perimeter beam
Data 7,2,4,-8.42,-5.2,-63.9,8.42,-5.2,-63.9,-8.59,-5.2,-65.2,8.59,-5.2,-65.2,100,100,15
Data 7,3,4,-8.59,-4.8,-65.2,-8.59,-5.2,-65.2,8.59,-4.8,-65.2,8.59,-5.2,-65.2,100,100,13
Data 7,4,4,-8.42,-4.8,-63.9,-8.42,-5.2,-63.9,8.42,-4.8,-63.9,8.42,-5.2,-63.9,100,100,13
Data 8,1,14,-.1,-.1,3,.1,-.1,3,-.1,-.1,0,.1,-.1,0,100,100,7: 'carriage roof center beam
Data 8,2,6,-.1,.1,3,.1,.1,3,-.1,.1,0,.1,.1,0,100,100,7
Data 8,3,6,-.1,-.1,3,-.1,.1,3,-.1,-.1,0,-.1,.1,0,100,100,8
Data 8,4,6,.1,-.1,3,.1,.1,3,.1,-.1,0,.1,.1,0,100,100,8
Data 8,5,6,-2,-2,10,2,-2,10,-2,-2,6,2,-2,6,100,100,7: 'walls
Data 8,6,6,-2,2,10,2,2,10,-2,2,6,2,2,6,100,100,7
Data 8,7,6,-2,-2,10,-2,2,10,-2,-2,6,-2,2,6,100,100,17
Data 8,8,6,2,-2,10,2,2,10,2,-2,6,2,2,6,100,100,17
Data 8,9,6,2,-2,3,2,2,3,-2,-2,3,-2,2,3,100,100,18: 'roof
Data 8,10,6,2,-2,10,2,2,10,-2,-2,10,-2,2,10,100,100,18: 'floor
Data 8,11,6,-2,-2,6,-1.95,-2,6,-2,-2,3,-1.95,-2,3,100,100,7: 'corner beam 1
Data 8,12,6,-2,-2,6,-2,-1.95,6,-2,-2,3,-2,-1.95,3,100,100,8
Data 8,12,6,-2,2,6,-1.95,2,6,-2,2,3,-1.95,2,3,100,100,7: 'corner beam 2
Data 8,14,6,-2,2,6,-2,1.95,6,-2,2,3,-2,1.95,3,100,100,8
Data 8,13,6,2,2,6,1.95,2,6,2,2,3,1.95,2,3,100,100,7: 'corner beam 3
Data 8,14,6,2,2,6,2,1.95,6,2,2,3,2,1.95,3,100,100,8
Data 8,12,6,2,-2,6,1.95,-2,6,2,-2,3,1.95,-2,3,100,100,7: 'corner beam 4
Data 8,14,6,2,-2,6,2,-1.95,6,2,-2,3,2,-1.95,3,100,100,8



rawtxtot = 41: txtot = rawtxtot


'read data into array tx()
Dim t2
For t = 1 To txtot
    For t2 = 1 To 18
        Read tx(t, t2)
    Next t2
    'create 'raw' objects
    raw(t).n = tx(t, 1): raw(t).n2 = tx(t, 2): raw(t).n3 = tx(t, 3)
    raw(t).x1 = tx(t, 4): raw(t).y1 = tx(t, 5): raw(t).z1 = tx(t, 6)
    raw(t).x2 = tx(t, 7): raw(t).y2 = tx(t, 8): raw(t).z2 = tx(t, 9)
    raw(t).x3 = tx(t, 10): raw(t).y3 = tx(t, 11): raw(t).z3 = tx(t, 12)
    raw(t).x4 = tx(t, 13): raw(t).y4 = tx(t, 14): raw(t).z4 = tx(t, 15)
    raw(t).ix = tx(t, 16): raw(t).iy = tx(t, 17): raw(t).in = tx(t, 18)
Next t




Dim n1, n2, n3, n4, n5, n6, n7, n8 'n, x, y, z, sc,ac,ac2,ac3

'water
n1 = 2: n2 = 0: n3 = 0: n4 = 500: n5 = 1: n6 = 0: n7 = 0: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'water

'main beams
n1 = 4: n2 = 170: n3 = 70: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = .50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
n1 = 4: n2 = 130: n3 = 70: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = -.50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
n1 = 4: n2 = 170: n3 = 90: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = .50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam
n1 = 4: n2 = 130: n3 = 90: n4 = 447: n5 = 2: n6 = _Pi / 2: n7 = -.50: n8 = 0: foocopy n1, n2, n3, n4, n5, n6, n7, n8 'main beam

'axle
n1 = 3: n2 = 150: n3 = 80: n4 = 411: n5 = .55: n6 = 0: n7 = 0
For t = 1 To 16
    n8 = _Pi / 16 * (2 * t): foocopy n1, n2, n3, n4, n5, n6, n7, n8 'short beam
Next t

'rotating beam
n1 = 5: n2 = 150: n3 = 75: n4 = 411: n5 = 1: n6 = _Pi / 2: n8 = 0
For t = 1 To 24
    n7 = (_Pi / 6) * (.5 * t) + .131: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t

n1 = 5: n2 = 150: n3 = 85: n4 = 411: n5 = 1: n6 = _Pi / 2: n8 = 0
For t = 1 To 24
    n7 = (_Pi / 6) * (.5 * t) + .131: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t

'rotating short end beam  (carriage attached to this)
n1 = 6: n2 = 150: n3 = 80: n4 = 411: n5 = 1: n6 = 0: n7 = _Pi / 2
For t = 1 To 24
    n8 = (_Pi / 6) * (.5 * t) + .131: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t

'outer perimeter beam
n1 = 7: n2 = 150: n3 = 80: n4 = 411: n5 = 1: n6 = 0: n7 = 0
For t = 1 To 24
    n8 = (_Pi / 6) * (.5 * t): moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t

'outer perimeter beam
n1 = 7: n2 = 150: n3 = 90: n4 = 411: n5 = 1: n6 = 0: n7 = 0
For t = 1 To 24
    n8 = (_Pi / 6) * (.5 * t): moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t


'carriages
n1 = 8: n2 = 50: n3 = 80: n4 = 431: n5 = 1: n6 = 0: n7 = 0
For t = 1 To 24
    n8 = 0: moocopy n1, n2, n3, n4, n5, n6, n7, n8
Next t
Dim v, c1

'colours
For t = 1 To mootxtot
    If moo(t).det.n = 8 Then
        If moo(t).det.n2 = 1 Then
            c1 = ((t / 1) Mod 7) + 10

            moo(t + 4).det.in = c1
            moo(t + 5).det.in = c1
            moo(t + 8).det.in = c1

        End If
    End If
Next t


'create spectator
Dim Shared sp(6)
sp(0) = 250 'X position
sp(1) = 150 'Y
sp(2) = 470 'Z
sp(3) = 0 'looking in the direction of the observer XZ
sp(4) = 0 'looking in the direction of the observer YZ
sp(5) = .1 'multiplier X-Y see
sp(6) = .1 'multiplier Z see

'create screen
scr = _NewImage(1000, 1000 / _DesktopWidth * _DesktopHeight, 32)
Screen scr
_MouseHide
_FullScreen
_Dest scr
_DisplayOrder _Hardware , _Software


'sky install
da = 11 'resolution sphere X
db = 7 'resolution sphere Y

sky_points = da * db
Dim sky_points(sky_points - 1, 9), sq(sky_points - 1, 7)
sky_image = _CopyImage(sky1, 33)

For da2 = 0 To da - 1
    dega = 360 / (da - 1) * da2 * pip180
    For db2 = 0 To db - 1
        degb = 180 / (db - 1) * db2 * pip180
        ss = 4000
        ap = da2 * db + db2
        sky_points(ap, 0) = Sin(degb) * Cos(dega) * ss
        sky_points(ap, 1) = Sin(degb) * Sin(dega) * ss
        sky_points(ap, 2) = Cos(degb) * ss
    Next db2
Next da2

For da2 = 0 To da - 2
    For db2 = 0 To db - 2
        sqa = da2 * db + db2
        sq(sqa, 0) = sqa
        sq(sqa, 1) = sq(sqa, 0) + 1
        sq(sqa, 2) = sq(sqa, 0) + db
        sq(sqa, 3) = sq(sqa, 2) + 1
        sq(sqa, 4) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * da2) - 1
        sq(sqa, 5) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * (da2 + 1)) - 1
        sq(sqa, 6) = Int(_Height(sky_image) / (db - 1) * db2)
        sq(sqa, 7) = Int(_Height(sky_image) / (db - 1) * (db2 + 1))
    Next db2
Next da2

pmode = 3
rspd = 0
Dim rcount

'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================

Do
    _Limit 40


    'keyboard input
    keyct = keyct + 1
    If keyct > 10 Then 'wait before more input
        key1 = keyboard
        keyct = 0
    Else
        key1 = 0
    End If


    'keyboard actions

    If key1 = 1 Then
        rspd = rspd + .001
        If rspd > .016 Then rspd = .012
    End If

    If key1 = 2 Then
        rspd = rspd - .001
        If rspd < -.016 Then rspd = -.012
    End If



    If key1 = 5 Then
        pmode = 1
    End If

    If key1 = 4 Then
        pmode = 2
    End If

    If key1 = 3 Then
        pmode = 3
    End If





    or1(1) = 5: or1(2) = 0: or1(3) = 0: or1(4) = 0: or1(5) = rspd: objrotate3
    or1(1) = 6: or1(2) = 0: or1(3) = 0: or1(4) = 0: or1(5) = rspd: objrotate3
    or1(1) = 7: or1(2) = 0: or1(3) = 0: or1(4) = 0: or1(5) = rspd: objrotate3

    processcarriages
    processterrain
    processfootextures
    processmootextures




    'draw sky    *********************************************************************************
    't = 1  'use for checkered sky

    'rotating
    For actual_point = 0 To sky_points - 1
        sky_points(actual_point, 4) = sky_points(actual_point, 0)
        sky_points(actual_point, 5) = sky_points(actual_point, 1)
        sky_points(actual_point, 6) = sky_points(actual_point, 2)
        r2m sky_points(actual_point, 4), sky_points(actual_point, 5), sky_points(actual_point, 6)
    Next actual_point

    For asq = 0 To sky_points - 1
        wx0 = sky_points(sq(asq, 0), 4) + 0: wy0 = sky_points(sq(asq, 0), 5) + 0: wz0 = sky_points(sq(asq, 0), 6)
        wx1 = sky_points(sq(asq, 1), 4) + 0: wy1 = sky_points(sq(asq, 1), 5) + 0: wz1 = sky_points(sq(asq, 1), 6)
        wx2 = sky_points(sq(asq, 2), 4) + 0: wy2 = sky_points(sq(asq, 2), 5) + 0: wz2 = sky_points(sq(asq, 2), 6)
        wx3 = sky_points(sq(asq, 3), 4) + 0: wy3 = sky_points(sq(asq, 3), 5) + 0: wz3 = sky_points(sq(asq, 3), 6)
        sy0 = sq(asq, 6): sx0 = sq(asq, 4): sy1 = sq(asq, 7): sx1 = sq(asq, 4): sy2 = sq(asq, 6): sx2 = sq(asq, 5): sy3 = sq(asq, 7): sx3 = sq(asq, 5)
        't = t * -1 'use for checkered sky
        'If t > 0 Then 'use for checkered sky
        _MapTriangle (sx0, sy0)-(sx1, sy1)-(sx2, sy2), sky_image To(wx0, wy0, wz0)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
        _MapTriangle (sx3, sy3)-(sx1, sy1)-(sx2, sy2), sky_image To(wx3, wy3, wz3)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
        'End If 'use for checkered sky
    Next asq
    ' ****************************************************************************************************


    _Display


    '-------------------------------------------------------------
    'mouse input axis movement and mousewheel
    '-------------------------------------------------------------
    mousex = mousex * .6
    mousey = mousey * .6
    mw = 0
    While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mw = mw + _MouseWheel: Wend 'movement data read

    'control spectator
    mouse_sens = .0007 'mouse rotating sensitive
    sp(3) = sp(3) - mousex * mouse_sens
    sp(4) = sp(4) + mousey * mouse_sens
    If Abs(sp(4)) > _Pi / 2 Then sp(4) = _Pi / 2 * Sgn(sp(4))
    sp3 = sp(3) + (_KeyDown(Asc("d")) - _KeyDown(Asc("a"))) * 90 * pip180
    vec_x = (Sin(sp3) * (Cos(sp(4) + _Pi)))
    vec_y = (Cos(sp3) * (Cos(sp(4) + _Pi)))
    vec_z = -Sin(sp(4) + _Pi)
    If _KeyDown(Asc("a")) Or _KeyDown(Asc("d")) Then vec_z = 0
    speed = .5 'moving speed
    moving = Abs(_MouseButton(1) Or _KeyDown(Asc("w")) Or _KeyDown(Asc("a")) Or _KeyDown(Asc("d"))) * speed - Abs(_MouseButton(2) Or _KeyDown(Asc("s"))) * speed

    If pmode = 1 Then
        sp(0) = sp(0) + vec_x * moving
        sp(1) = sp(1) + vec_y * moving
        sp(2) = sp(2) + vec_z * moving
    End If
    If pmode = 2 Then
        'take a ride
        sp(0) = moo(907).pos1.x
        sp(1) = moo(907).pos1.y
        sp(2) = moo(907).pos1.z + 4
    End If

    If pmode = 3 Then

        sp(0) = sp(0) + vec_x * moving
        sp(1) = sp(1) + vec_y * moving


        'find current terrain location
        xm = sp(0) / 50
        ym = sp(1) / 50

        If sp(0) > 3 And sp(0) < 498 Then
            If sp(1) > 3 And sp(1) < 498 Then
                sp(2) = 494 + exact_deep(ym, xm)
            End If
        Else
            sp(2) = 494
        End If

    End If

    t = Abs(rspd) / (2 * _Pi)
    rcount = rcount + t


    'Locate 1, 1
    'Print rspd
    'Locate 2, 1
    'Print rcount

    'If rcount > 1000 Then rspd = 0


Loop Until _KeyDown(27)



'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================


Function keyboard
    keyboard = 0

    If _KeyDown(19712) Then 'right arrow key
        keyboard = 1
    End If

    If _KeyDown(19200) Then 'left arrow key
        keyboard = 2
    End If

    If _KeyDown(20480) Then 'down arrow key
        keyboard = 3
    End If

    If _KeyDown(18432) Then 'up arrow key
        keyboard = 4
    End If

    If _KeyDown(102) Then 'f key
        keyboard = 5
    End If


End Function



Function exact_deep (x, y)
    Dim x1, y1, x2, y2, p0, p1, p2, p3, aposx, aposy, q
    x1 = Int(x) + 1: x2 = x1 + 1: aposx = x - (x1 - 1)
    y1 = Int(y) + 1: y2 = y1 + 1: aposy = y - (y1 - 1)

    p1 = deep(x2, y1)
    p2 = deep(x1, y2)

    If aposx * aposx + aposy * aposy < (1 - aposx) * (1 - aposx) + (1 - aposy) * (1 - aposy) Then
        p0 = deep(x1, y1)
        q = p0 + aposx * (p1 - p0) + aposy * (p2 - p0)
    Else
        p3 = deep(x2, y2)
        q = p3 + (1 - aposy) * (p1 - p3) + (1 - aposx) * (p2 - p3)
    End If

    exact_deep = q

End Function





Sub r2m (x, y, z)
    Dim x2, y2, z2
    x2 = x - sp(0)
    y2 = y - sp(1)
    z2 = z - sp(2)
    rotate_2d x2, y2, sp(3)
    rotate_2d y2, z2, sp(4) + _Pi / 2
    x = x2 * sp(5)
    y = y2 * sp(5)
    z = z2 * sp(6)
End Sub

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




Sub processterrain
    Dim x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim xx1, yy1, xx2, yy2, xx3, yy3
    Dim flag, ct, scale1, shx, shy, shz, txm
    flag = 0
    ct = 0
    scale1 = 1.
    shx = 0 'shift x position
    shy = 0 'shift y position
    shz = 502 'shift z position

    Do
        ct = ct + 1

        x1 = trx(fr1(ct)): y1 = try(fr1(ct)): z1 = trz(fr1(ct))
        x2 = trx(fr2(ct)): y2 = try(fr2(ct)): z2 = trz(fr2(ct))
        x3 = trx(fr3(ct)): y3 = try(fr3(ct)): z3 = trz(fr3(ct))

        xx1 = x1: yy1 = y1
        xx2 = x2: yy2 = y2
        xx3 = x3: yy3 = y3


        x1 = x1 * scale1: y1 = y1 * scale1: 'z1 = z1 * scale1
        x2 = x2 * scale1: y2 = y2 * scale1: 'z2 = z2 * scale1
        x3 = x3 * scale1: y3 = y3 * scale1: 'z3 = z3 * scale1
        x4 = x4 * scale1: y4 = y4 * scale1: 'z4 = z4 * scale1

        x1 = x1 + shx: y1 = y1 + shy: z1 = z1 + shz
        x2 = x2 + shx: y2 = y2 + shy: z2 = z2 + shz
        x3 = x3 + shx: y3 = y3 + shy: z3 = z3 + shz
        x4 = x4 + shx: y4 = y4 + shy: z4 = z4 + shz

        r2m x1, y1, z1
        r2m x2, y2, z2
        r2m x3, y3, z3

        txm = 0
        _MapTriangle (xx1, yy1)-(xx2, yy2)-(xx3, yy3), tximage(txm) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        If ct >= maxterrain Then flag = 1
    Loop Until flag = 1

End Sub





Sub foocopy (n, x, y, z, sc, ac, ac2, ac3)
    Dim t, t2, flag, xt, yt, zt
    oc = oc + 1 'object count - used for object id number

    For t = 1 To rawtxtot 'find number of details in this object
        If raw(t).n = n Then
            t2 = 1
            flag = 0
            Do 'search foo() array for availability
                If foo(t2).det.n = 0 Then
                    flag = 1
                Else
                    t2 = t2 + 1
                End If
            Loop Until flag > 0
            't2 is next available array position


            foo(t2).det.n = n: foo(t2).pos1.x = x: foo(t2).pos1.y = y: foo(t2).pos1.z = z: foo(t2).sc = sc

            xt = raw(t).x1: yt = raw(t).y1: zt = raw(t).z1: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x1 = xt * sc: foo(t2).det.y1 = yt * sc: foo(t2).det.z1 = zt * sc
            xt = raw(t).x2: yt = raw(t).y2: zt = raw(t).z2: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x2 = xt * sc: foo(t2).det.y2 = yt * sc: foo(t2).det.z2 = zt * sc
            xt = raw(t).x3: yt = raw(t).y3: zt = raw(t).z3: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x3 = xt * sc: foo(t2).det.y3 = yt * sc: foo(t2).det.z3 = zt * sc
            xt = raw(t).x4: yt = raw(t).y4: zt = raw(t).z4: objrotation xt, yt, zt, ac, ac2, ac3: foo(t2).det.x4 = xt * sc: foo(t2).det.y4 = yt * sc: foo(t2).det.z4 = zt * sc

            foo(t2).det.ix = raw(t).ix: foo(t2).det.iy = raw(t).iy: foo(t2).det.in = raw(t).in
        End If
    Next t
End Sub


Sub objrotation (x, y, z, a, a2, a3)
    Dim xt, yt, zt, h, h1, h2, xt2, yt2, zt2
    Dim y2
    'yz rotation
    yt = y: zt = z
    h = _Hypot(zt, yt)
    h1 = _Atan2(yt, zt)
    h2 = h1 - a2
    yt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    y2 = yt2
    z = zt2
    'xy rotation
    xt = x: yt = y2
    h = _Hypot(yt, xt)
    h1 = _Atan2(xt, yt)
    h2 = h1 - a
    xt2 = Sin(h2) * h
    yt2 = Cos(h2) * h
    x = xt2
    y = yt2
    'xz rotation
    zt = z: xt = x
    h = _Hypot(zt, xt)
    h1 = _Atan2(xt, zt)
    h2 = h1 - a3
    If h2 < 0 Then h2 = h2 + _Pi * 2
    xt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    z = zt2
    x = xt2

End Sub


Sub moocopy (n, x, y, z, sc, ac, ac2, ac3)
    Dim t, t2, flag, xt, yt, zt
    oc = oc + 1 'object count - used for object id number

    For t = 1 To rawtxtot 'find number of details in this object
        If raw(t).n = n Then
            t2 = 1
            flag = 0
            Do 'search foo() array for availability
                If moo(t2).det.n = 0 Then
                    flag = 1
                Else
                    t2 = t2 + 1
                End If
            Loop Until flag > 0
            't2 is next available array position
            mootxtot = t2

            moo(t2).det.n = n: moo(t2).pos1.x = x: moo(t2).pos1.y = y: moo(t2).pos1.z = z: moo(t2).sc = sc
            moo(t2).det.n2 = raw(t).n2
            xt = raw(t).x1: yt = raw(t).y1: zt = raw(t).z1: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x1 = xt * sc: moo(t2).det.y1 = yt * sc: moo(t2).det.z1 = zt * sc
            xt = raw(t).x2: yt = raw(t).y2: zt = raw(t).z2: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x2 = xt * sc: moo(t2).det.y2 = yt * sc: moo(t2).det.z2 = zt * sc
            xt = raw(t).x3: yt = raw(t).y3: zt = raw(t).z3: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x3 = xt * sc: moo(t2).det.y3 = yt * sc: moo(t2).det.z3 = zt * sc
            xt = raw(t).x4: yt = raw(t).y4: zt = raw(t).z4: objrotation xt, yt, zt, ac, ac2, ac3: moo(t2).det.x4 = xt * sc: moo(t2).det.y4 = yt * sc: moo(t2).det.z4 = zt * sc

            moo(t2).det.ix = raw(t).ix: moo(t2).det.iy = raw(t).iy: moo(t2).det.in = raw(t).in
            moo(t2).ori.xz = ac3
        End If
    Next t
End Sub





Sub moocopy2 (n, x, y, z, sc)
    Dim t, t2, flag
    oc = oc + 1 'object count - used for object id number

    For t = 1 To rawtxtot 'find number of details in this object
        If raw(t).n = n Then
            t2 = 1
            flag = 0
            Do 'search moo() array for availability
                If moo(t2).det.n = 0 Then
                    flag = 1
                Else
                    t2 = t2 + 1
                End If
            Loop Until flag > 0
            't2 is next available array position

            moo(t2).det.n = n: moo(t2).pos1.x = x: moo(t2).pos1.y = y: moo(t2).pos1.z = z: moo(t2).sc = sc
            moo(t2).det.x1 = raw(t).x1 * sc: moo(t2).det.y1 = raw(t).y1 * sc: moo(t2).det.z1 = raw(t).z1 * sc
            moo(t2).det.x2 = raw(t).x2 * sc: moo(t2).det.y2 = raw(t).y2 * sc: moo(t2).det.z2 = raw(t).z2 * sc
            moo(t2).det.x3 = raw(t).x3 * sc: moo(t2).det.y3 = raw(t).y3 * sc: moo(t2).det.z3 = raw(t).z3 * sc
            moo(t2).det.x4 = raw(t).x4 * sc: moo(t2).det.y4 = raw(t).y4 * sc: moo(t2).det.z4 = raw(t).z4 * sc
            moo(t2).det.ix = raw(t).ix: moo(t2).det.iy = raw(t).iy: moo(t2).det.in = raw(t).in
        End If
    Next t
End Sub




Sub moorotate
    Dim t, x1, y1, x2, y2, x3, y3, x4, y4

    For t = 1 To mootxtot
        If moo(t).det.n = or1(1) Then
            x1 = moo(t).det.x1: y1 = moo(t).det.y1
            xyrotation x1, y1, or1(5)
            x2 = moo(t).det.x2: y2 = moo(t).det.y2
            xyrotation x2, y2, or1(5)
            x3 = moo(t).det.x3: y3 = moo(t).det.y3
            xyrotation x3, y3, or1(5)
            x4 = moo(t).det.x4: y4 = moo(t).det.y4
            xyrotation x4, y4, or1(5)
            moo(t).det.x1 = x1: moo(t).det.y1 = y1
            moo(t).det.x2 = x2: moo(t).det.y2 = y2
            moo(t).det.x3 = x3: moo(t).det.y3 = y3
            moo(t).det.x4 = x4: moo(t).det.y4 = y4
        End If
    Next t
End Sub



Sub processfootextures
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim flag

    flag = 0
    t = 1

    Do
        x1 = foo(t).det.x1 + foo(t).pos1.x: y1 = foo(t).det.y1 + foo(t).pos1.y: z1 = foo(t).det.z1 + foo(t).pos1.z
        x2 = foo(t).det.x2 + foo(t).pos1.x: y2 = foo(t).det.y2 + foo(t).pos1.y: z2 = foo(t).det.z2 + foo(t).pos1.z
        x3 = foo(t).det.x3 + foo(t).pos1.x: y3 = foo(t).det.y3 + foo(t).pos1.y: z3 = foo(t).det.z3 + foo(t).pos1.z
        x4 = foo(t).det.x4 + foo(t).pos1.x: y4 = foo(t).det.y4 + foo(t).pos1.y: z4 = foo(t).det.z4 + foo(t).pos1.z
        x = foo(t).det.ix: y = foo(t).det.iy
        r2m x1, y1, z1
        r2m x2, y2, z2
        r2m x3, y3, z3
        r2m x4, y4, z4
        _MapTriangle (0, 0)-(0, y)-(x, 0), tximage(foo(t).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
        _MapTriangle (x, y)-(0, y)-(x, 0), tximage(foo(t).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        t = t + 1
        If foo(t).det.n = 0 Then flag = 1

    Loop Until flag > 0

End Sub




Sub processmootextures
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim flag

    flag = 0
    t = 1

    Do
        x1 = moo(t).det.x1 + moo(t).pos1.x: y1 = moo(t).det.y1 + moo(t).pos1.y: z1 = moo(t).det.z1 + moo(t).pos1.z
        x2 = moo(t).det.x2 + moo(t).pos1.x: y2 = moo(t).det.y2 + moo(t).pos1.y: z2 = moo(t).det.z2 + moo(t).pos1.z
        x3 = moo(t).det.x3 + moo(t).pos1.x: y3 = moo(t).det.y3 + moo(t).pos1.y: z3 = moo(t).det.z3 + moo(t).pos1.z
        x4 = moo(t).det.x4 + moo(t).pos1.x: y4 = moo(t).det.y4 + moo(t).pos1.y: z4 = moo(t).det.z4 + moo(t).pos1.z
        x = moo(t).det.ix: y = moo(t).det.iy
        r2m x1, y1, z1
        r2m x2, y2, z2
        r2m x3, y3, z3
        r2m x4, y4, z4
        _MapTriangle (0, 0)-(0, y)-(x, 0), tximage(moo(t).det.in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
        _MapTriangle (x, y)-(0, y)-(x, 0), tximage(moo(t).det.in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        t = t + 1
        If moo(t).det.n = 0 Then flag = 1

    Loop Until flag > 0

End Sub




Sub processcarriages
    Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
    Dim flag, ct6, ct8, c(50), xc(50), zc(50), k
    Dim xt, zt, h, h2, v, c1

    flag = 0
    ct6 = 0
    ct8 = 0
    For t = 1 To mootxtot

        If moo(t).det.n = 6 Then

            If moo(t).det.n2 = 1 Then
                ct6 = ct6 + 1
                c(ct6) = moo(t).ori.xz
                xc(ct6) = moo(t).pos1.x
                zc(ct6) = moo(t).pos1.z
            End If

        End If


        If moo(t).det.n = 8 Then

            If moo(t).det.n2 = 1 Then
                ct8 = ct8 + 1
                k = c(ct8)
                h2 = k ' + .131
                h = 65.05

                xt = Sin(h2) * h
                zt = Cos(h2) * h

                c1 = Int(Rnd * 6) + 12
                moo(t).pos1.x = xc(ct8) + xt: moo(t).pos1.z = zc(ct8) + zt

                'Locate 1, 1
                'Print t

                For v = 1 To 18
                    moo(t + v).pos1.x = xc(ct8) + xt: moo(t + v).pos1.z = zc(ct8) + zt
                Next v


            End If


        End If

    Next t
    'Locate 1, 1
    'Print ct6, ct8
    'Print c(1); c(2); c(3); c(4)
End Sub





Sub xyrotation (x, y, a)
    Dim xt, yt, h, h1, h2, xt2, yt2
    xt = x: yt = y
    h = _Hypot(yt, xt)
    h1 = _Atan2(xt, yt)
    h2 = h1 - a
    xt2 = Sin(h2) * h
    yt2 = Cos(h2) * h
    x = xt2
    y = yt2
End Sub


Sub yzrotation (y, z, a)
    Dim zt, yt, h, h1, h2, zt2, yt2
    zt = z: yt = y
    h = _Hypot(zt, yt)
    h1 = _Atan2(yt, zt)
    h2 = h1 - a
    If h2 < 0 Then h2 = h2 + _Pi * 2
    yt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    z = zt2
    y = yt2
End Sub


Sub xzrotation (x, z, a)
    Dim zt, xt, h, h1, h2, zt2, xt2
    zt = z: xt = x
    h = _Hypot(zt, xt)
    h1 = _Atan2(xt, zt)
    h2 = h1 - a
    If h2 < 0 Then h2 = h2 + _Pi * 2
    xt2 = Sin(h2) * h
    zt2 = Cos(h2) * h
    z = zt2
    x = xt2
End Sub





Sub makeground
    Dim t, x1, y1, s, s2, x, y, c, ed
    s = 320
    s2 = (500 - s) / 2
    Cls
    Line (0, 0)-(500, 500), c(14), BF 'border/beach
    Line (0, 0)-(500, 500), c(40), BF 'ground background
    For y = 1 To 500
        For x = 1 To 500
            x1 = x / 50
            y1 = y / 50
            ed = exact_deep(y1, x1)
            s = 0 - ed
            c(99) = _RGBA(10 - s / 2, 40 - s / 2, 30 - s / 2, s)
            For t = 1 To 60
                If s > t + 5 Then
                    'PSet (x, y), c(99)
                    Circle (x, y), 1, c(99)
                End If
            Next t


            'texture dots
            s2 = Rnd * 15
            c(99) = _RGBA(120, 100, 70, 5)
            If s2 > 2 Then Circle (x, y), 1, c(99)
            c(99) = _RGBA(125, 95, 70, 5)
            If s2 > 3 Then Circle (x, y), 1, c(99)


        Next x
    Next y
    '_Display
    _PutImage (0, 0)-(500, 500), 0, ground1, (0, 0)-(500, 500)
    'Sleep

End Sub








Sub maketerrain
    Dim t, s, x, y, x1, y1, p, q, p2, ct, flag
    Dim xt, yt, xh, yh, vc, dx, dy, pt(4)
    Cls
    'Line (0, 0)-(500, 500), c(20), BF 'background
    t = 0
    x1 = 500: y1 = 500
    s = 50
    'create points  (trx,try,trz)
    For x = 0 To x1 Step s
        For y = 0 To y1 Step s
            t = t + 1
            xt = Abs(x): yt = Abs(y)
            'trx(t) = x - s: try(t) = y - s
            trx(t) = x: try(t) = y
            If x > 0 And x < x1 Then
                'trz(t) = -2
                If y > 0 And y < y1 Then
                    'trz(t) = 0
                    trz(t) = 0 - Int(Rnd * 8) - 2
                    xh = Abs(trx(t) - x1 / 2)
                    yh = Abs(try(t) - y1 / 2)
                    vc = _Hypot(xh, yh)
                    vc = 140 - vc
                    trz(t) = trz(t) - vc / 12
                    'trz(t) = trz(t) - (Int(Rnd * vc))
                End If
            End If
        Next y
    Next x
    '_Display
    'Sleep


    'create point groups (fr1,fr2,fr3)
    p = Int(x1 / s) + 1
    q = Int(y1 / s) - 1

    p2 = p * q
    t = -1
    flag = 0
    ct = 0
    x = 0
    Do
        For x = 1 To p - 1
            t = t + 2
            fr1(t) = x + ct
            fr2(t) = x + ct + 1
            fr3(t) = x + ct + p
            fr1(t + 1) = x + ct + 1
            fr2(t + 1) = x + ct + p
            fr3(t + 1) = x + ct + p + 1
        Next x
        ct = ct + p
        If ct > p2 Then flag = 1
    Loop Until flag = 1
    maxterrain = t + 1

    'Cls
    't = t + 1
    'For ct = 1 To t
    'Print fr1(ct), fr2(ct), fr3(ct)
    'Next ct

    Cls
    For t = 1 To maxterrain
        Line (trx(fr1(t)), try(fr1(t)))-(trx(fr2(t)), try(fr2(t))), c(1)
        Line (trx(fr2(t)), try(fr2(t)))-(trx(fr3(t)), try(fr3(t))), c(1)
        Line (trx(fr3(t)), try(fr3(t)))-(trx(fr1(t)), try(fr1(t))), c(1)
    Next t

    'set some terrain z points manually
    trz(13) = -8
    trz(24) = -9
    trz(35) = -10
    trz(46) = -9
    trz(57) = -8

    trz(14) = -8
    trz(25) = -9
    trz(36) = -10
    trz(47) = -9
    trz(58) = -8

    trz(15) = -7

    trz(48) = -14
    trz(59) = -14
    trz(70) = -14

    trz(49) = -14
    trz(60) = -14
    trz(71) = -14



    'create DEEP array
    t = 0
    For y = 1 To 11
        For x = 1 To 11
            t = t + 1
            deep(x, y) = trz(t)
            Locate y * 3, x * 6
            Print deep(x, y)
        Next x
    Next y

    '_Display
    'Sleep

End Sub




Sub makesky
    Dim t, y, m
    Cls
    y = 750
    For t = 1 To y
        m = 255 * ((750 - t * .65) / 750)
        c(99) = _RGBA(200, 200, 255, m)
        Line (0, t)-(750, t), c(99)
    Next t
    'For t = 0 To 750 Step 25 'longituge lines
    'Line (t, 0)-(t, 750), c(1)
    'Next t
    'For t = 0 To 750 Step 25 'latitude lines
    'Line (0, t)-(750, t), c(1)
    'Next t
    '_Display
    _PutImage (0, 0)-(750, 750), 0, sky1, (0, 0)-(750, 750)
    'Sleep
End Sub







Sub makepallette
    Dim t
    For t = 1 To 20
        Cls
        Line (0, 0)-(400, 400), c(t), BF
        _PutImage (0, 0)-(400, 400), 0, cbx(t), (0, 0)-(400, 400)
        '_Display
        'Sleep
    Next t
End Sub



Sub colour1
    c(0) = _RGB(0, 0, 0)
    c(1) = _RGB(255, 255, 255)
    c(2) = _RGB(35, 25, 10)
    c(3) = _RGB(35, 70, 100)
    c(4) = _RGB(40, 250, 10)
    c(5) = _RGB(0, 25, 75)
    c(6) = _RGB(45, 35, 20)
    c(7) = _RGB(100, 100, 105)
    c(8) = _RGB(75, 75, 80)
    c(9) = _RGB(50, 50, 55)
    c(10) = _RGB(95, 95, 100)
    c(11) = _RGB(50, 150, 50)
    c(12) = _RGB(150, 50, 50)
    c(13) = _RGB(0, 45, 85)
    c(14) = _RGB(160, 150, 100)
    c(15) = _RGB(0, 25, 75)
    c(16) = _RGB(55, 25, 30)
    c(17) = _RGB(175, 175, 175)
    c(18) = _RGB(100, 100, 100)
    c(20) = _RGB(20, 30, 15)
    c(31) = _RGB(255, 255, 255)
    c(32) = _RGB(255, 0, 0)
    c(33) = _RGB(0, 55, 255)
    c(34) = _RGB(255, 255, 0)
    c(40) = _RGBA(45, 20, 25, 125)
    c(41) = _RGBA(50, 50, 30, 40)
    c(42) = _RGBA(20, 30, 15, 40)
    c(43) = _RGBA(75, 45, 15, 40)
    c(44) = _RGBA(40, 60, 30, 40)
    c(45) = _RGB(50, 50, 30)
    c(46) = _RGB(20, 30, 15)
    c(47) = _RGB(55, 45, 15)
    c(48) = _RGB(40, 50, 10)
    c(51) = _RGBA(10, 40, 30, 160)
    c(52) = _RGBA(10, 43, 30, 140)
    c(53) = _RGBA(10, 46, 30, 120)
    c(54) = _RGBA(10, 49, 30, 100)
    c(55) = _RGBA(10, 52, 30, 80)
    c(56) = _RGBA(10, 55, 30, 60)
    c(57) = _RGBA(10, 58, 30, 40)
    c(58) = _RGBA(10, 61, 30, 20)
    c(59) = _RGBA(10, 64, 30, 10)

End Sub



Sub objrotate
    Dim t, x1, y1, x2, y2, x3, y3, x4, y4

    For t = 1 To txtot
        If moo(t).det.n = or1(1) Then
            x1 = moo(t).det.x1 - or1(2): y1 = moo(t).det.y1 - or1(4)
            xyrotation x1, y1, or1(5)
            x2 = moo(t).det.x2 - or1(2): y2 = moo(t).det.y2 - or1(4)
            xyrotation x2, y2, or1(5)
            x3 = moo(t).det.x3 - or1(2): y3 = moo(t).det.y3 - or1(4)
            xyrotation x3, y3, or1(5)
            x4 = moo(t).det.x4 - or1(2): y4 = moo(t).det.y4 - or1(4)
            xyrotation x4, y4, or1(5)
            moo(t).det.x1 = x1 + or1(2): moo(t).det.y1 = y1 + or1(4)
            moo(t).det.x2 = x2 + or1(2): moo(t).det.y2 = y2 + or1(4)
            moo(t).det.x3 = x3 + or1(2): moo(t).det.y3 = y3 + or1(4)
            moo(t).det.x4 = x4 + or1(2): moo(t).det.y4 = y4 + or1(4)
        End If
    Next t
End Sub


Sub objrotate2
    Dim t, y1, z1, y2, z2, y3, z3, y4, z4

    For t = 1 To txtot
        If moo(t).det.n = or1(1) Then
            y1 = moo(t).det.y1 - or1(2): z1 = moo(t).det.z1 - or1(4)
            yzrotation y1, z1, or1(5)
            y2 = moo(t).det.y2 - or1(2): z2 = moo(t).det.z2 - or1(4)
            yzrotation y2, z2, or1(5)
            y3 = moo(t).det.y3 - or1(2): z3 = moo(t).det.z3 - or1(4)
            yzrotation y3, z3, or1(5)
            y4 = moo(t).det.y4 - or1(2): z4 = moo(t).det.z4 - or1(4)
            yzrotation y4, z4, or1(5)
            moo(t).det.y1 = y1 + or1(2): moo(t).det.z1 = z1 + or1(4)
            moo(t).det.y2 = y2 + or1(2): moo(t).det.z2 = z2 + or1(4)
            moo(t).det.y3 = y3 + or1(2): moo(t).det.z3 = z3 + or1(4)
            moo(t).det.y4 = y4 + or1(2): moo(t).det.z4 = z4 + or1(4)
        End If
    Next t
End Sub


Sub objrotate3
    Dim t, x1, z1, x2, z2, x3, z3, x4, z4

    For t = 1 To mootxtot
        If moo(t).det.n = or1(1) Then
            x1 = moo(t).det.x1 - or1(2): z1 = moo(t).det.z1 - or1(4)
            xzrotation x1, z1, or1(5)
            x2 = moo(t).det.x2 - or1(2): z2 = moo(t).det.z2 - or1(4)
            xzrotation x2, z2, or1(5)
            x3 = moo(t).det.x3 - or1(2): z3 = moo(t).det.z3 - or1(4)
            xzrotation x3, z3, or1(5)
            x4 = moo(t).det.x4 - or1(2): z4 = moo(t).det.z4 - or1(4)
            xzrotation x4, z4, or1(5)
            moo(t).det.x1 = x1 + or1(2): moo(t).det.z1 = z1 + or1(4)
            moo(t).det.x2 = x2 + or1(2): moo(t).det.z2 = z2 + or1(4)
            moo(t).det.x3 = x3 + or1(2): moo(t).det.z3 = z3 + or1(4)
            moo(t).det.x4 = x4 + or1(2): moo(t).det.z4 = z4 + or1(4)
            moo(t).ori.xz = moo(t).ori.xz - or1(5)
            If moo(t).ori.xz > 7 Then
                moo(t).ori.xz = moo(t).ori.xz - (2 * _Pi)
            End If
            If moo(t).ori.xz < -7 Then
                moo(t).ori.xz = moo(t).ori.xz + (2 * _Pi)
            End If

        End If
    Next t

End Sub

Print this item

  UniDate
Posted by: SMcNeill - 02-09-2023, 07:40 PM - Forum: SMcNeill - Replies (3)

As we were talking on Discord, it'd be nice if there was some function to easily format a date to the proper localization.  (month-day-year vs day-month-year, for example)

Well, now there is!

Code: (Select All)
PRINT UniDate$("mm/dd/yyyy", DATE$)
PRINT UniDate$("w, MM dd, YYYY", DATE$)
PRINT UniDate$("W, MM DD, YYYY", DATE$)
PRINT UniDate$("dd/mm/yyyy", DATE$)
PRINT UniDate$("W, E D, YYYY", DATE$)
PRINT UniDate$("mm-dd-yy", DATE$)

FUNCTION UniDate$ (format$, userdate$)
    'some basic documentation for formatting:
    'dates sent via userdate$ should be in the standardized QB64 DATE$ format -- MM/DD/YYYY
    'To customize your return date format, use the following syntax
    'w = short weekday names.  (Mon, Tue, Wed, Thu, Fri, Sat, Sun)
    'W = long weekday names.  (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday)
    'E = Extended month names.  (January, February, March....)
    'M = long month names.  (Jan, Feb, Mar...)
    'm = short month names.  (01, 02, 03...)
    'D = long day names.  (01st, 02nd, 03rd...)
    'd = short day names.  (01, 02, 03...)
    'Y or y (case insensitive) = year.  Number of Yy present determines the number of digits we return.
    '       YY = 2-digit year
    '       YYYY = 4 digit year
    '       Y with any additional number of y's = 4 digit year by default, so a typo of YYYYY is the same as YYYY.
    'Any other character is simply considered part of the desired output and faithfully carried over into the proper spot.
    '      For example, "mm/dd/yyyy" gives us "02/10/2023" for Feb 10th, 2023.
    '      Second example, "dd.mm.yyyy" gives us "10.02.2023" for the same date.
    '      Third example, "dd EE YYYY" gives us "02 February 2023" for that same date.
    'Note:  Extra digits of most of these codes are simply ignored for error proofing purposes, with only the initial code being accepted.
    '      For example "mM YYYY" is actually processed as a simple "m YYYY".  The process won't mix short, long, or extended results.
    '      Also for example, "m YY" is the *exact* same as "mm YY".
    '      Feel free to use extra digits as you desire to help you keep track of positional spacing in your format string.
    '      Even though "M D, yyyy" may process the same as "MMM DDDD, YYYY", the second may work better for you if you're trying to track
    '             position of formatted objects.  (The output would be "Feb 10th, 2023", and those extra characters help hold that
    '             positioning for us easily.)

    'And, I think that's it.  Enjoy, guys!


    temp$ = userdate$
    IF temp$ = "" THEN temp$ = DATE$
    m$ = LEFT$(temp$, 2)
    d$ = MID$(temp$, 4, 2)
    y$ = RIGHT$(temp$, 4)
    temp$ = format$
    DO
        firstchar$ = LEFT$(temp$, 1)
        SELECT CASE firstchar$
            CASE "E" 'extended month
                temp$ = MID$(temp$, 2)
                IF NOT MonthSet THEN
                    MonthSet = -1
                    SELECT CASE VAL(m$)
                        CASE 1: out$ = out$ + "January"
                        CASE 2: out$ = out$ + "February"
                        CASE 3: out$ = out$ + "March"
                        CASE 4: out$ = out$ + "April"
                        CASE 5: out$ = out$ + "May"
                        CASE 6: out$ = out$ + "June"
                        CASE 7: out$ = out$ + "July"
                        CASE 8: out$ = out$ + "August"
                        CASE 9: out$ = out$ + "September"
                        CASE 10: out$ = out$ + "October"
                        CASE 11: out$ = out$ + "November"
                        CASE 12: out$ = out$ + "December"
                    END SELECT
                END IF
            CASE "M" 'long month
                temp$ = MID$(temp$, 2)
                IF NOT MonthSet THEN
                    MonthSet = -1
                    SELECT CASE VAL(m$)
                        CASE 1: out$ = out$ + "Jan"
                        CASE 2: out$ = out$ + "Feb"
                        CASE 3: out$ = out$ + "Mar"
                        CASE 4: out$ = out$ + "Apr"
                        CASE 5: out$ = out$ + "May"
                        CASE 6: out$ = out$ + "Jun"
                        CASE 7: out$ = out$ + "Jul"
                        CASE 8: out$ = out$ + "Aug"
                        CASE 9: out$ = out$ + "Sep"
                        CASE 10: out$ = out$ + "Oct"
                        CASE 11: out$ = out$ + "Nov"
                        CASE 12: out$ = out$ + "Dec"
                    END SELECT
                END IF
            CASE "m" 'short month
                temp$ = MID$(temp$, 2)
                IF NOT MonthSet THEN
                    MonthSet = -1
                    SELECT CASE VAL(m$)
                        CASE 1: out$ = out$ + "01"
                        CASE 2: out$ = out$ + "02"
                        CASE 3: out$ = out$ + "03"
                        CASE 4: out$ = out$ + "04"
                        CASE 5: out$ = out$ + "05"
                        CASE 6: out$ = out$ + "06"
                        CASE 7: out$ = out$ + "07"
                        CASE 8: out$ = out$ + "08"
                        CASE 9: out$ = out$ + "09"
                        CASE 10: out$ = out$ + "10"
                        CASE 11: out$ = out$ + "11"
                        CASE 12: out$ = out$ + "12"
                    END SELECT
                END IF
            CASE "D" 'long day
                temp$ = MID$(temp$, 2)
                IF NOT DaySet THEN
                    DaySet = -1
                    out$ = out$ + RIGHT$("00" + _TRIM$(d$), 2)
                    SELECT CASE VAL(d$)
                        CASE 1, 11, 21, 31: out$ = out$ + "st"
                        CASE 2, 22: out$ = out$ + "nd"
                        CASE 3, 23: out$ = out$ + "rd"
                        CASE ELSE: out$ = out$ + "th"
                    END SELECT
                END IF
            CASE "d" 'short day
                temp$ = MID$(temp$, 2)
                IF NOT DaySet THEN
                    DaySet = -1
                    out$ = out$ + RIGHT$("00" + _TRIM$(d$), 2)
                END IF

            CASE "W" 'long weekday
                temp$ = MID$(temp$, 2)
                IF NOT WeekdaySet THEN
                    GOSUB getday
                    SELECT CASE result
                        CASE 0: Day$ = "Saturday"
                        CASE 1: Day$ = "Sunday"
                        CASE 2: Day$ = "Monday"
                        CASE 3: Day$ = "Tuesday"
                        CASE 4: Day$ = "Wednesday"
                        CASE 5: Day$ = "Thursday"
                        CASE 6: Day$ = "Friday"
                    END SELECT
                    out$ = out$ + Day$
                END IF
            CASE "w" 'short weekday
                temp$ = MID$(temp$, 2)
                IF NOT WeekdaySet THEN
                    GOSUB getday
                    SELECT CASE result
                        CASE 0: Day$ = "Sat"
                        CASE 1: Day$ = "Sun"
                        CASE 2: Day$ = "Mon"
                        CASE 3: Day$ = "Tue"
                        CASE 4: Day$ = "Wed"
                        CASE 5: Day$ = "Thr"
                        CASE 6: Day$ = "Fri"
                    END SELECT
                    out$ = out$ + Day$
                END IF
            CASE "Y", "y" 'year
                IF NOT YearSet THEN
                    YearSet = -1
                    IF LEFT$(UCASE$(temp$), 4) = "YYYY" THEN
                        temp$ = MID$(temp$, 5)
                        out$ = out$ + y$
                    ELSEIF LEFT$(UCASE$(temp$), 2) = "YY" THEN
                        temp$ = MID$(temp$, 3)
                        out$ = out$ + RIGHT$(y$, 2)
                    ELSE
                        temp$ = MID$(temp$, 2)
                        out$ = out$ + y$
                    END IF
                ELSE
                    temp$ = MID$(temp$, 2)
                END IF
            CASE ELSE 'seperator
                temp$ = MID$(temp$, 2)
                out$ = out$ + firstchar$
        END SELECT
    LOOP UNTIL temp$ = ""
    UniDate$ = out$
    EXIT FUNCTION

    getday:
    WeekdaySet = -1
    'From Zeller's congruence: https://en.wikipedia.org/wiki/Zeller%27s_congruence
    mm = VAL(m$): dd = VAL(d$): yyyy = VAL(y$)
    IF mm < 3 THEN mm = mm + 12: yyyy = yyyy - 1
    century = yyyy MOD 100
    zerocentury = yyyy \ 100
    result = (dd + INT(13 * (mm + 1) / 5) + century + INT(century / 4) + INT(zerocentury / 4) + 5 * zerocentury) MOD 7
    RETURN
END FUNCTION


   

Print this item

  Using periods in sub and function names?
Posted by: TerryRitchie - 02-09-2023, 06:36 AM - Forum: Help Me! - Replies (13)

I noticed this can be done:

FUNCTION MY.NEW.FUNCTION()

    - code here

    MY.NEW.FUNCTION = -1

END FUNCTION

I saw the use of periods as word separators in someone else's code. I decided to use this construct on a project I'm working on. However, as the code grows (up to 4000 lines now) the IDE sometime fails to color code the SUBS and FUNCTIONS that use periods in their names. I need to move the cursor by pressing the space bar (or simply typing) and the color coding will come back, but disappear later again.

Is the IDE doing this because it does not like the use of periods in the SUB and FUNCTION names? Should I not be using this construct? I find it to be much cleaner looking than MY_NEW_FUNCTION but can revert to this if need be.

I've not run into a problem with the code compiling or running in any way, just curious behavior from the IDE I've noticed, especially like I said as the code continues to grow and only affecting SUBs and FUNCTIONs with periods in their name.

Print this item

  Exercism
Posted by: bruce_axtens - 02-09-2023, 06:17 AM - Forum: General Discussion - Replies (4)

I'm sure I've mentioned this before. Can't find it in a search. So, here we go again.

Exercism.org is a place where programmers can go to get better. The blurb on the front page includes "Solve coding exercises and get mentored to develop fluency in your chosen programming languages. Exercism is open-source and not-for-profit."

I've recently launched a learning track for 8th, a FORTH dialect. It took me a while but I was working mostly alone. I had a considerably larger team around me for the COBOL track.

There could be a BASIC track. It's not hard, just takes a bit of dogged persistence. The community is helpful and the admin support is outstanding. The requirements are well described.

I am NOT volunteering to lead. I'm still working on a Euphoria track, and if that doesn't kill me, I'll follow with SNOBOL4.

This is a suggestion. Get some folk inspired.

-Bruce

Print this item

  Explosions - Handy Drawing Tool
Posted by: bplus - 02-09-2023, 04:27 AM - Forum: Utilities - Replies (1)

I got tired of reinventing the wheel for explosions so I made a handy drawing tool. Just give it the x, y location, the diameter = spread to cover and red, green, blue colors to use. It will calculate the number of dots, frames and speeds needed for decent explosion and set that up with DrawDots sub.

This is my test code for developing Explode:

Code: (Select All)
Option _Explicit
_Title "Explosions test" 'b+ revisit 2023-02-08

Const xmax = 800, ymax = 600
Screen _NewImage(xmax, ymax, 32)
_ScreenMove (1280 - xmax) / 2 + 30, (760 - ymax) / 2
Randomize Timer
Type particle ' ===================================== Explosions Setup
    As Long life, death
    As Single x, y, dx, dy, r
    As _Unsigned Long c
End Type

Dim Shared nDots
nDots = 2000
ReDim Shared dots(nDots) As particle ' ==============================
Dim As Long mx, my, mb

Do
    Cls
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    Circle (mx, my), 5
    If mb Then
        ' explode sets up dots and runs them out over several loops
        Explode mx, my, 100, 0, 120, 40
        Circle (mx, my), 100
        _Display
        _Delay .2 ' alittle delay for user to release mousebutton
    End If
    DrawDots
    _Display
    _Limit 30 ' or 60
Loop
Print "done"

' explode sets up old dead particles for display for a life
' This sub sets up Dots to display with DrawDots
' this sub uses rndCW
Sub Explode (x, y, spread, cr, cg, cb)
    ' x, y explosion origin
    ' spread is diameter of area to cover from it number of dots, number of frames and speed are calculated

    ' setup for explosions in main
    'Type particle
    '    As Long life, death
    '    As Single x, y, dx, dy, r
    '    As _Unsigned Long c
    'End Type

    'Dim Shared nDots
    'nDots = 2000
    'ReDim Shared dots(nDots) As particle

    Dim As Long i, dotCount, newDots
    Dim angle, speed, rd, rAve, frames
    newDots = spread / 2 ' quota
    frames = spread / 5
    speed = spread / frames ' 0 to spread in frames
    rAve = .5 * spread / Sqr(newDots)
    For i = 1 To nDots ' find next available dot
        If dots(i).life = 0 Then
            dots(i).life = 1 ' turn on display
            dots(i).death = frames
            angle = _Pi(2 * Rnd)
            dots(i).x = x: dots(i).y = y ' origin
            rd = Rnd
            dots(i).dx = rd * speed * Cos(angle) ' moving
            dots(i).dy = rd * speed * Sin(angle)
            dots(i).r = RndCW(rAve, rAve) ' radius
            dots(i).c = _RGB32(cr + Rnd * 40 - 20, cg + Rnd * 40 - 20, cb + Rnd * 40 - 20) 'color
            dotCount = dotCount + 1
            If dotCount >= newDots Then Exit Sub
        End If
    Next
End Sub

Sub DrawDots ' this sub needs fcirc to Fill Circles and Sub Explode sets up the Dots to draw.
    ' setup in main for explosions
    'Type particle
    '    As Long life, death
    '    As Single x, y, dx, dy, r
    '    As _Unsigned Long c
    'End Type

    'Dim Shared nDots
    'nDots = 2000
    'ReDim Shared dots(nDots) As particle

    Dim As Long i
    For i = 1 To nDots ' display of living particles
        If dots(i).life Then
            FCirc dots(i).x, dots(i).y, dots(i).r, dots(i).c
            ' update dot
            If dots(i).life + 1 >= dots(i).death Then
                dots(i).life = 0
            Else
                dots(i).life = dots(i).life + 1
                ' might want air resistence or gravity added to dx or dy
                dots(i).x = dots(i).x + dots(i).dx
                dots(i).y = dots(i).y + dots(i).dy
                If dots(i).x < 0 Or dots(i).x > xmax Then dots(i).life = 0
                If dots(i).y < 0 Or dots(i).y > ymax Then dots(i).life = 0
                dots(i).r = dots(i).r * 1 - (dots(i).life / dots(i).death) ' puff!
                If dots(i).r <= 0 Then dots(i).life = 0
            End If
        End If
    Next
End Sub

'from Steve Gold standard
Sub FCirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
    Dim Radius As Integer, RadiusError As Integer
    Dim X As Integer, Y As Integer
    Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
    If Radius = 0 Then PSet (CX, CY), C: Exit Sub
    Line (CX - X, CY)-(CX + X, CY), C, BF
    While X > Y
        RadiusError = RadiusError + Y * 2 + 1
        If RadiusError >= 0 Then
            If X <> Y + 1 Then
                Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
                Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
            End If
            X = X - 1
            RadiusError = RadiusError - X * 2
        End If
        Y = Y + 1
        Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
        Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
    Wend
End Sub

Function RndCW (C As Single, range As Single) 'center +/-range weights to center
    RndCW = C + Rnd * range - Rnd * range
End Function

Print this item

  The Window Closer X
Posted by: Ron - 02-08-2023, 06:58 PM - Forum: Help Me! - Replies (7)

Hello everyone,  I am using the QB64 for windows compatibility converted all the QB 4.5 to QB64 it has been working for 6 years now.  Anyway one of my users asked me to disable the X on closing the program because they didn't want it to close in the middle of what they were doing so I put in the the command 'ex = _EXIT'.  This works like it states you can't close the program with the X on the window.  Now to kill the program when it freezes they have to kill the process in windows.  Is there a why to use ON KEY to close it?  I have tried ON KEY(1) with a subroutine and GOSUB it will not do the code when I press F1 so somehow the ON KEY is not working for me. I am using QB64 Version 1.1 Revision 20170120/51 does it work in more recent versions and where do I find them now.   Alt + F4 should be what the Window close X button uses I think but maybe I am wrong.   

Is there anyone that may know something to help me or should I leave it the way it is.

Print this item

  ibb.co errors
Posted by: bplus - 02-08-2023, 02:52 PM - Forum: Site Suggestions - Replies (4)

Just tried to enlarge TempodiBasic's snap and it seems every time I click a snap in a post I get this:
   
So those images are waste of space unless you want a thumbprint.

I think these are made when you add a snap from "Add image to post" button instead of going down stairs in editor and adding an image with that equipment.

Is this broken? or just with my browser? or intended just for thumbprints?

I don't recall this problem when forum first started, I do remember getting ads added in with the snaps.

Print this item

  Welcome to 2023.
Posted by: eoredson - 02-08-2023, 03:39 AM - Forum: Help Me! - Replies (5)

Hi,

Happy belated 2023! This is a program to display the factors of 2023:

Code: (Select All)
Year = 2023
z = Year - 1
Do Until z = Year
  z = z + 1
  x = z
  Print x; "=";
  l = 1
  q = 0
  Do Until x = 1
      l = l + 1
      Do While x / l = x \ l ' continue to divide number
        q = q + 1
        If q > 1 Then
            Print "*";
        End If
        Print l;
        x = x / l
      Loop
      If l > Int(z / 2) Then ' test for maximum divisor
        Exit Do
      End If
      If l > Int(Sqr(x)) Then ' test maximum divisor is prime
        If q = 0 Then
            Exit Do
        End If
      End If
  Loop
  If q = 0 Then ' display number is prime
      Print " (prime)";
  End If
  Print
Loop
End

Print this item

  some suggestions / requests for anyone looking to port a classic game to QB64PE
Posted by: madscijr - 02-07-2023, 10:20 PM - Forum: General Discussion - Replies (12)

Hey all!

After Terry's killer version of Pac Man and RokCoder's Galaga, I'm compelled to list a few that may be beyond my current skillset, patience level, and/or free time, but which would make the world a better place if they existed... 

  • Pinball Construction Set
  • Zaxxon / Super Zaxxon - except let the player have full freedom of motion to fly in any direction (i.e. the plane can turn 360 degrees like in Time Pilot or Asteroids) and maybe even land and the player can get out and run around isometrically (like Realm of Impossibility), and maybe pilot other vehicles (like Frontline)! And a level editor!
  • Gravitar - the vector game, but maybe with multiplayer (split screen or quad split screen) options and a level editor of course.
  • Cliff Hanger - the C64 game which is basically like the old Road Runner cartoon
  • Sprint 8 / Super Sprint - top down racing fun
  • Jumpman / Jumpman Jr. / Ultimate Wizard - with level editor
  • Tempest with level editor
  • Defender / Stargate
  • Mr. Do! / Dig Dug or maybe a combination of the 2
  • Lode Runner (the 8-bit C64 or IBM version) with editor
  • Racing Destruction Set
  • Spy vs Spy
  • Ultima III Construction Set
  • a Zork game construction set
  • Berzerk / Outlaw / Gunfighter but for 2-4 players with an editor
  • Atari Adventure Construction Set (maybe multiplayer option too)
  • Pitfall! and/or Pitfall II (with editor)
  • Mail Order Monsters

(I would happily program all of the above but I'm still working on Spacewar! and maybe a Lunar Lander / Asteroids mashup, and a Pong Construction Set, maybe eventually one for multiplayer controllable with multiple USB mice plugged into a single PC!)

That's all I got for now -
Cheers

Print this item

  SEEK with INPUT for variable length strings
Posted by: SMcNeill - 02-07-2023, 07:28 PM - Forum: SMcNeill - Replies (2)

Code: (Select All)
OPEN "data.txt" FOR OUTPUT AS #1
OPEN "data.ndx" FOR RANDOM AS #2 LEN = 4 'one long variable in size

DIM ndx AS LONG 'that long variable I mentioned above
DIM text AS STRING 'and a random length string
DIM count AS LONG 'and a counter for which element we want

DO
    ndx = LOF(1) + 1
    PUT #2, , ndx
    READ text$
    PRINT #1, text$
LOOP UNTIL text$ = "EOD"
CLOSE #1
OPEN "data.txt" FOR INPUT AS #1
'now we have a data file that we can use input with and read any record out of at will
DO
    INPUT "Which record would you like to retrieve =>"; count
    IF count = 0 THEN SYSTEM
    GET #2, count, ndx
    SEEK #1, ndx
    INPUT #1, text
    PRINT "That record was: "; text
LOOP

1

DATA one,two,three,four,five,six,seven,eight,nine,ten,eleven,twelve
DATA thirteen,fourteen,fiveteen,sixteen,seventeen,eighteen,nineteen,tenteen,eleventeen,twelveteen,EOD

Print this item