DeathTeatDungeon is a simple rogue-like example. It's based off the code I used in Wandering in the Cave but makes use of a graphic tileset.
It's currently set-up to play a simple escape scenario. Eventually monsters and treasures will be added to the game, the graphics are there currently just not all the rest of the code.
This is in two codeblocks, the main program you can name however you like the tileset and tileloading function should be saved in a file called "DTDtiles.bi" if you want to use the code as is.
thanks again to DAV for his BASIMAGE program whichmade this program possible as is.
DeathTestDungeon Main Program
Code: (Select All)
'DeathTestDungeon v0.3b
'By James D. Jarvis
' a simple rogue-like example
' in progress
' has simple exit challenge built in for now , no guarantee the starting positon will be safe or the game will be playable just yet
'
'curenntly this is all rough and in-development you'll see the dungeon get drawn as you start and it will stay on screen
'as long as you wish, press the spacebar to start playing
' use the numberpad or WASD to navigate <esc> to quit
'$dynamic
Screen _NewImage(800, 500, 32)
_Title "DeathTestDungeon v0.3"
_Define K As _UNSIGNED LONG
Dim Shared dmap As _Unsigned Long
Dim Shared ms As _Unsigned Long
Dim Shared Kblack, Kwhite, Kdgrey, Klgrey, kredm, kwater, kslime, klava, krubble, kcrystal, kexit, kfungus
Dim Shared kfloor2, kfloor3, kfloor4, cornerrubblechance
Dim Shared tiles&
Dim Shared rect_count As Integer
Type rect_type
xx As Integer
yy As Integer
ww As Integer
hh As Integer
lk As _Unsigned Long
fk As _Unsigned Long
notes As String
End Type
Dim Shared tilespot(0 To 528, 2) As Integer
Dim Shared rect(0) As rect_type
Dim Shared min_rectd
Dim Shared fillcell, openwallchance, pillarchance, puddleno, slimechance, lavachance
Dim Shared phealth, pstamina, pwounds, ptemp, ppx, ppy, lastx, lasty
Randomize Timer
Kblack = _RGB32(0, 0, 0) 'this is visible black as 0,0,0 will be "nothing is here" eventually
Kwhite = _RGB32(250, 250, 250) 'this is cooled paper white
Kdgrey = _RGB32(40, 40, 40)
Klgrey = _RGB32(150, 150, 150)
kfloor2 = _RGB32(151, 151, 151): kfloor3 = _RGB32(152, 152, 152): kfloor4 = _RGB32(153, 153, 153)
kred = _RGB32(250, 0, 0)
kwater = _RGB32(10, 30, 240): kslime = _RGB32(20, 240, 100): klava = _RGB32(200, 5, 5)
krubble = _RGB32(80, 80, 80): kcrystal = _RGB32(250, 250, 0): kexit = _RGB32(255, 0, 255)
kfungus = _RGB32(200, 50, 150)
dmap = _NewImage(800, 500, 32)
ms = _NewImage(800, 500, 32)
tiles& = Loadtileset1& 'loads the tileset in the file DTDtiles.bi
Const tilemaxx = 48
Const tilemaxy = 11
t = 0
For y = 0 To tilemaxy - 1
For x = 0 To tilemaxx - 1
tilespot(t, 1) = x * 16
tilespot(t, 2) = y * 16
t = t + 1
Next x
Next y
maxtiles = t - 1
fh = _FontHeight
fw = _FontWidth
Do
'Cls
For r = 1 To rect_count
bisectrect r
Next r
For r = 1 To rect_count
drawrect r
Next r
_Limit 5
kk$ = InKey$
n = n + Int(1 + Rnd * 8)
Loop Until kk$ <> "" Or n > 40
kk$ = Chr$(27)
Loop Until kk$ = Chr$(27)
For r = 1 To rect_count
If Int(1 + Rnd * 100) < fillcell Then rect(r).fk = Kdgrey
drawrect r
Next r
For r = 1 To rect_count 'if there's an open space across a wall open a space in the wall
If rect(r).fk <> Kdgrey Then
mx = rect(r).xx + Int(rect(r).ww / 2)
my = rect(r).yy + Int(rect(r).hh / 2)
If Point(mx, my + Int(rect(r).hh / 2) + 2) = Klgrey Then
Line (mx, my)-(mx, my + Int(rect(r).hh / 2) + 2), Klgrey
End If
If Point(mx, my - Int(rect(r).hh / 2) - 2) = Klgrey Then
Line (mx, my)-(mx, my - Int(rect(r).hh / 2) - 2), Klgrey
End If
If Point(mx - Int(rect(r).ww / 2) - 2, my) = Klgrey Then
Line (mx - Int(rect(r).ww / 2) - 2, my)-(mx, my), Klgrey
End If
If Point(mx + Int(rect(r).ww / 2) + 2, my) = Klgrey Then
Line (mx + Int(rect(r).ww / 2) + 2, my)-(mx, my), Klgrey
End If
End If
Next r
For y = 11 To rht - 1
For x = 11 To rwid - 2
If Point(x, y) = Klgrey And Point(x + 1, y) = Kdgrey And Point(x + 2, y) = Klgrey Then
PSet (x + 1, y), kred
End If
If Point(x, y) = Klgrey And Point(x + 1, y) = kred And Point(x + 2, y) = Kdgrey And Point(x + 3, y) = Klgrey Then
PSet (x + 2, y), kred
End If
If Point(x, y) = kdrgey And Point(x + 1, y) = Klgrey And Point(x + 2, y) = Kdgrey And Point(x + 3, y) = Kdgrey And Point(x + 4, y) = Klgrey And Point(x + 5, y) = Kdgrey Then
PSet (x + 2, y), Klgrey
PSet (x + 3, y), Klgrey
End If
Next x
Next y
For x = 11 To rwid - 2
For y = 11 To rht - 2
If Point(x, y) = Klgrey And Point(x, y + 1) = Kdgrey And Point(x, y + 2) = Klgrey Then
PSet (x, y + 1), kred
End If
If Point(x, y) = Klgrey And Point(x, y + 1) = kred And Point(x, y + 2) = Kdgrey And Point(x, y + 3) = Klgrey Then
PSet (x, y + 2), kred
End If
If Point(x, y) = kdrgey And Point(x, y + 1) = Klgrey And Point(x, y + 2) = Kdgrey And Point(x, y + 3) = Kdgrey And Point(x, y + 4) = Klgrey And Point(x, y + 5) = Kdgrey Then
PSet (x, y + 2), Klgrey
PSet (x, y + 3), Klgrey
End If
Next
Next
aa$ = Input$(1)
For y = 10 To rht
For x = 10 To rwid
If Point(x, y) = kred Then PSet (x, y), Klgrey
Next
Next
Color Kblack, Kwhite
'check to open walls
For r = 1 To rect_count
If rect(r).fk <> Kdgrey And Int(1 + Rnd * 100) <= openwallchance Then
Select Case Int(1 + Rnd * 4)
Case 1
rect(r).xx = rect(r).xx - 2
rect(r).ww = rect(r).ww + 2
Case 2
rect(r).xx = rect(r).xx + 2
rect(r).ww = rect(r).ww + 2
Case 3
rect(r).yy = rect(r).yy - 2
rect(r).hh = rect(r).hh + 2
Case 4
rect(r).yy = rect(r).yy + 2
rect(r).hh = rect(r).hh + 2
End Select
Line (rect(r).xx, rect(r).yy)-(rect(r).xx + rect(r).ww, rect(r).yy + rect(r).hh), Klgrey, BF
End If
Next r
'straysspaces
sp = Int(Rnd * 12)
For ss = 1 To sp
sx = Int(10 + Rnd * rwid - 30)
sy = Int(10 + Rnd * rht - 30)
sw = 10 + Int(Rnd * 20)
sh = 10 + Int(Rnd * 20)
Line (sx, sy)-(sx + sw, sy + sh), Klgrey, BF
Next
'add wormtunnels
nwt = Int(Rnd * (12 + fillcell))
For ww = 1 To nwt
wsx = Int(20 + Rnd * rwid - 50)
wsy = Int(20 + Rnd * rht - 50)
wtx = Int(20 + Rnd * rwid - 50)
wty = Int(20 + Rnd * rht - 50)
If wsx < wtx Then xtrend = 1
If wsx > wtx Then xtrend = -1
If wsy < wty Then ytrend = 1
If wsy > wty Then ytrend = -1
sx = wsx
sy = wsy
rl = 0
Do
nx = sx + Int(xtrend + Rnd * 2 - Rnd * 2)
ny = sy + Int(ytrend + Rnd * 2 - Rnd * 2)
If nx < 11 Then
nx = 11
xtrend = xtrend * -1
End If
If ny < 11 Then
ny = 11
ytrend = ytrend * -1
End If
If nx > rwid Then
nx = rwid
xtrend = xtrend * -1
End If
If ny > rht Then
ny = rht
ytrend = ytrend * -1
End If
dx = Abs(nx - wtx)
dy = Abs(ny - wty)
Line (sx, sy)-(nx, ny), Klgrey
sx = nx
sy = ny
rl = rl + 1
Loop Until dx < 5 And dy < 5 Or rl > rwid + 40
Line (sx, sy)-(wtx, wty), Klgrey
Next ww
For r = 1 To rect_count 'add pillars
pillarspread = 2 + Int(Rnd * 7)
If rect(r).fk <> Kdgrey And Int(1 + Rnd * 100) <= pillarchance Then
For y = rect(r).yy + pillarspread To rect(r).yy + rect(r).hh - pillarspread Step pillarspread
For x = rect(r).xx + pillarspread To rect(r).xx + rect(r).ww - pillarspread Step pillarspread
PSet (x, y), Kdgrey
Next
Next
End If
Next
For pr = 1 To rect_count
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= cornerrubblechance Then
addcornerrubble pr
End If
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= puddleno Then
addwater pr, Int(rect(pr).xx + 1 + Rnd * (rect(pr).ww - 2)), Int(rect(pr).yy + 1 + Rnd * (rect(pr).hh - 2)), Int(1 + Rnd * 3)
End If
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= slimechance Then
addslime pr, Int(rect(pr).xx + 1 + Rnd * (rect(pr).ww - 2)), Int(rect(pr).yy + 1 + Rnd * (rect(pr).hh - 2)), Int(1 + Rnd * 3)
End If
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= lavachance Then
addlava pr, Int(rect(pr).xx + 1 + Rnd * (rect(pr).ww - 2)), Int(rect(pr).yy + 1 + Rnd * (rect(pr).hh - 2)), Int(1 + Rnd * 3)
End If
If rect(pr).fk <> Kdgrey And Int(1 + Rnd * 100) <= funguschance Then
addfungus pr, Int(rect(pr).xx + 1 + Rnd * (rect(pr).ww - 2)), Int(rect(pr).yy + 1 + Rnd * (rect(pr).hh - 2)), Int(1 + Rnd * 3)
End If
Next pr
'dress floor to make it more interesting
For y = 1 To rht
For x = 1 To rwid
If Point(x, y) = Klgrey Then
Select Case Int(1 + Rnd * 100)
Case 1, 2
PSet (x, y), kfloor2
Case 3
PSet (x, y), kfloor3
Case 4
PSet (x, y), kfloor4
End Select
If Point(x, y) = Kdgrey Then 'convert some wall near lava inot rubble
If Point(x - 1, y) = klava And Int(1 + Rnd * 100) < 30 Then PSet (x, y), krubble
If Point(x + 1, y) = klava And Int(1 + Rnd * 100) < 30 Then PSet (x, y), krubble
If Point(x, y + 1) = klava And Int(1 + Rnd * 100) < 30 Then PSet (x, y), krubble
If Point(x, y - 1) = klava And Int(1 + Rnd * 100) < 30 Then PSet (x, y), krubble
If Point(x - 2, y) = klava And Int(1 + Rnd * 100) < 10 Then PSet (x, y), krubble
If Point(x + 2, y) = klava And Int(1 + Rnd * 100) < 10 Then PSet (x, y), krubble
If Point(x, y + 2) = klava And Int(1 + Rnd * 100) < 10 Then PSet (x, y), krubble
If Point(x, y - 2) = klava And Int(1 + Rnd * 100) < 10 Then PSet (x, y), krubble
End If
End If
Next
Next
For e = 0 To 9 'clean edge
Line (e, e)-(_Width - e, e), Kdgrey: Line (e, e)-(e, _Height - e), Kdgrey: Line (_Width - e, e)-(_Width - e, _Height - e), Kdgrey
Next e
Screen ms
_Source dmap
pick = 0
Do
pick = pick + 1
ppx = rect(pick).xx + Int(rect(pick).ww / 2): ppy = rect(pick).yy + Int(rect(pick).hh / 2)
kk = Point(ppx, ppy)
Loop Until kk <> Kdgrey
Do
If rec_count > 12 Then
exitspot = Int(6 + Rnd * (rect_count - 7))
Else
exitspot = Int(1 + Rnd * rect_count)
End If
exitX = rect(exitspot).xx + Int(rect(exitspot).ww / 2)
exitY = rect(exitspot).yy + Int(rect(exitspot).hh / 2)
startX = Abs(exitX - ppx)
startY = Abs(exitY - ppy)
start_dx = Sqr(startX * startX + startY * startY)
Loop Until Point(exitX, exitY) <> Kdgrey And exitspot <> pick
_Dest dmap
PSet (exitX, exitY), kexit
_Dest ms
_PrintMode _KeepBackground
View Print 25 To 30
Cls
Do
'draw location
rsqrd = lightradius * lightradius
y = -lightradius
While y <= lightradius
x = Int(Sqr(rsqrd - y * y))
For x2 = ppx - x To ppx + x
vx = x2 - ppx + 12
kk = Point(x2, ppy + y)
Line (vx * 16, (y + 12) * 16)-(vx * 16 + 15, (y + 12) * 16 + 15), kk, BF
If kk = Kdgrey Then
coltileat walltile, _RGB32(100, 100, 100), vx * 16, (y + 12) * 16
End If
If kk = kfloor2 Then
coltileat 2, _RGB32(160, 160, 160), vx * 16, (y + 12) * 16
End If
If kk = kfloor3 Then
coltileat 3, _RGB32(165, 165, 170), vx * 16, (y + 12) * 16
End If
If kk = kfloor4 Then
coltileat 4, _RGB32(175, 165, 165), vx * 16, (y + 12) * 16
End If
If kk = kexit Then
coltileat 24, _RGB32(250, 40, 255), vx * 16, (y + 12) * 16
End If
If kk = kfungus Then
Color _RGB32(250, 100, 200)
' _PrintString (vx * 16, (y + 12) * 16), Chr$(234)
coltileat 57, _RGB32(250, 100, 200), vx * 16, (y + 12) * 16
Color _RGB32(255, 255, 255)
End If
If kk = kcrystal Then
'_PrintString (vx * 16, (y + 12) * 16), Chr$(127)
coltileat 433, _RGB32(10, 0, 10), vx * 16, (y + 12) * 16
End If
If kk = krubble Then
Color _RGB32(150, 150, 150)
'_PrintString (vx * 16, (y + 12) * 16), Chr$(177)
coltileat 61, _RGB32(220, 200, 180), vx * 16, (y + 12) * 16
Color _RGB32(255, 255, 255)
End If
If kk = kslime Then
Color _RGB32(250, 250, 150)
sb = Int(Rnd * 4)
'If sb = 1 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(247)
If sb = 1 Then coltileat 61, _RGB32(250, 250, 150), vx * 16, (y + 12) * 16
' If sb = 2 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(126)
If sb = 2 Then coltileat 61, _RGB32(150, 250, 150), vx * 16, (y + 12) * 16
Color _RGB32(255, 255, 255)
End If
If kk = klava Then
Color _RGB32(250, 250, 150)
lb = Int(Rnd * 7)
'If lb = 1 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(249)
If lb = 1 Then coltileat 61, _RGB32(250, 250, 150), vx * 16, (y + 12) * 16
'If lb = 2 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(9)
If lb = 2 Then coltileat 468, _RGB32(250, 250, 150), vx * 16, (y + 12) * 16
'If lb = 3 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(176)
If lb = 3 Then coltileat 461, _RGB32(250, 250, 150), vx * 16, (y + 12) * 16
'If lb = 4 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(248)
If lb = 4 Then coltileat 61, _RGB32(250, 0, 0), vx * 16, (y + 12) * 16
'If lb = 5 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(46)
If lb = 5 Then coltileat 468, _RGB32(250, 100, 0), vx * 16, (y + 12) * 16
Color _RGB32(255, 255, 255)
End If
If kk = kwater Then
Color _RGB32(40, 120, 250)
wb = Int(Rnd * 6)
'If wb = 1 Then _PrintString (vx * 16, (y + 12) * 16), Chr$(45)
If wb = 1 Then coltileat 136, _RGB32(40, 120, 250), vx * 16, (y + 12) * 16
If wb = 2 Then coltileat 136, _RGB32(40, 120, 250), vx * 16, (y + 12) * 16
If wb = 3 Then _PrintString (vx * 16 + 4, (y + 12) * 16), Chr$(240)
Color _RGB32(255, 255, 255)
End If
Next
y = y + 1
Wend
Line (598, 18)-(795, 124), Kdgrey, BF
'_PrintString ((12) * 8, (12) * 16), "@"
If ptemp > 199 Then coltileat 470, _RGB32(40, 0, 0), (12) * 16, (12) * 16
coltileat 304, _RGB32(250, 250, 250), (12) * 16, (12) * 16
o$ = "Stamina " + Str$(pstamina)
_PrintString (600, 20), o$
o$ = "Health " + Str$(phealth)
_PrintString (600, 40), o$
o$ = "Wounds " + Str$(pwounds)
_PrintString (600, 60), o$
o$ = "Temperature " + Str$(ptemp)
_PrintString (600, 80), o$
edd = Int(Sqr((ppx - exitX) * (ppx - exitX) + (ppy - exitY) * (ppy - exitY)))
o$ = "Distance to Exit " + Str$(edd)
_PrintString (600, 100), o$
Print "Turn", turn
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
turn = turn + 1
lastx = ppx
lasty = ppy
Select Case kk$
Case "w", "8"
If pstamina > 0 And Point(ppx, ppy - 1) <> Kdgrey Then ppy = ppy - 1
Case "s", "2"
If pstamina > 0 And Point(ppx, ppy + 1) <> Kdgrey Then ppy = ppy + 1
Case "a", "4"
If pstamina > 0 And Point(ppx - 1, ppy) <> Kdgrey Then ppx = ppx - 1
Case "d", "6"
If pstamina > 0 And Point(ppx + 1, ppy) <> Kdgrey Then ppx = ppx + 1
Case "7"
If pstamina > 0 And Point(ppx - 1, ppy - 1) <> Kdgrey Then
ppy = ppy - 1
ppx = ppx - 1
End If
Case "9"
If pstamina > 0 And Point(ppx + 1, ppy - 1) <> Kdgrey Then
ppy = ppy - 1
ppx = ppx + 1
End If
Case "1"
If pstamina > 0 And Point(ppx - 1, ppy + 1) <> Kdgrey Then
ppy = ppy + 1
ppx = ppx - 1
End If
Case "3"
If pstamina > 0 And Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppy = ppy + 1
ppx = ppx + 1
End If
Case "5", "."
If Int(1 + Rnd * 50) < phealth And pstamina < 100 Then pstamina = pstamina + Int(1.5 + Rnd * (phealth / 25))
End Select
If Point(ppx, ppy) = krubble Then pwounds = pwounds + checkrubble(ppx, ppy)
If Point(ppx, ppy) = kcrystal Then pwounds = pwounds + checkcrystal(ppx, ppy)
If Int(1 + Rnd * 80 + pwounds) > phealth Then pstamina = pstamina - 1
If Point(ppx, ppy) = kslime Then
Print "The slime is nauseating...";
If Int(Rnd * 120) > phealth Then phealth = phealth - Int(Rnd * 4)
If Int(Rnd * 120) > phealth Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
Print " it's making you itch."
Case 4, 5, 6
Print " it's feel's like it is burning you."
wounds = wounds + Abs(Int(Rnd * 2 - Rnd * 2))
End Select
End If
End If
If Point(ppx, ppy) = kwater Then ptemp = ptemp - Int(Abs(Rnd * 2 - Rnd * 2))
If Point(ppx, ppy) = klava Then
ptemp = ptemp + 100
dmg = 10 + Int(Rnd * 20)
pwounds = pwounds + dmg
Print "YOU ARE STANDING IN LAVA !!!"
Print "....suffering "; dmg; " points of damage !"
End If
If ptemp < 0 Then
Print "You are dangerously COLD .... brrrrr"
pstamina = pstamina - Int(Rnd * 2)
If Int(1 + Rnd * (50 + Abs(ptemp))) > pstamina Then
pwounds = pwounds + Int(1 + Rnd * 2)
phealth = phealth - Int(Rnd * 2)
End If
End If
tcheck = ptemp + Rnd * 10
If tcheck > 108 Then
pstamina = pstamina - 1
Print "You are dangerously warm!"
If Int(1 + Rnd * ptemp) > pstamina Then
pwounds = pwounds + 1
phealth = phealth - Int(Rnd * 2)
End If
End If
'If Point(ppx, ppy) = (kfloor2 Or kfloor3 or kfloor4 or klgrey) Then
If ptemp < 98 Then ptemp = ptemp + 1
If ptemp > 98 Then ptemp = Int((ptemp + 98) / 2)
' End If
If pstamina < 20 Then
Print "You are ";
If pstamina < 1 Then
Print "exhausted."
Else
Print "fatigued."
End If
End If
If wounds > phealth Then
Print "You are in intense pain !"
pstamina = pstamina = Int(Rnd * 2)
End If
If Point(ppx, ppy) = kexit Then
Print
Print "YOU HAVE FOUND THE EXIT"
Print
Print "it took you "; turn; " turns after starting "; start_dx; " spaces away from the exit."
Print
kk$ = Chr$(27)
End If
If phealth < 1 Or pwounds > 99 Then
Print "YOU HAVE PERISHED DUE TO YOUR POOR CONDITION."
Print
Print "(press any key to continue)"
any$ = Input$(1)
kk$ = Chr$(27)
End If
Loop Until kk$ = Chr$(27)
Print "GAME OVER"
Print "play again?"
Print "Y or N?"
Do
ask$ = Input$(1)
ask$ = UCase$(ask$)
Loop Until ask$ = "Y" Or ask$ = "N"
If ask$ = "Y" Then
Screen cmap
GoTo restartdungeon
End If
System
'SUBS======================================================================
'$INCLUDE: 'DTDtiles.bi'
'==========================================================================
Sub bisectrect (r)
If r > 0 Or r < rect_count + 1 Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3 'vertical split
tries = 0
Do
tries = tries + 1
vpercent = (Int(1 + Rnd * 4) + Int(1 + Rnd * 4)) * .1
Loop Until vpercent * rect(r).ww >= min_rectd And vpercent * rect(r).hh >= min_rectd Or tries > 7
If tries < 8 Then
oldWW = Int(rect(r).ww * vpercent)
newX = rect(r).xx + oldWW
newWW = rect(r).ww - oldWW
If oldWW >= min_rectd And newWW >= min_rectd Then
rect(r).ww = oldWW
newrect newX, rect(r).yy, newWW, rect(r).hh, rect(r).lk, rect(r).fk
End If
End If
Case 4, 5, 6 'horizontal split
tries = 0
Do
tries = tries + 1
vpercent = (Int(1 + Rnd * 4) + Int(1 + Rnd * 4)) * .1
Loop Until vpercent * rect(r).ww >= min_rectd And vpercent * rect(r).hh >= min_rectd Or tries > 7
If tries < 8 Then
oldHH = Int(rect(r).hh * vpercent)
newYY = (rect(r).yy + oldHH)
newHH = rect(r).hh - oldHH
If oldHH >= min_rectd And newHH >= min_rectd Then
rect(r).hh = oldHH
newrect rect(r).xx, newYY, rect(r).ww, newHH, rect(r).lk, rect(r).fk
End If
End If
End Select
End If
End Sub
Sub wrect (rx, ry, ww, hh, line_klr As _Unsigned Long, fill_klr As _Unsigned Long)
If fill_klr > 0 Then Line (rx, ry)-(rx + ww - 1, ry + hh - 1), fill_klr, BF
If line_klr > 0 Then Line (rx, ry)-(rx + ww - 1, ry + hh - 1), line_klr, B
End Sub
Sub drawrect (r)
wrect rect(r).xx, rect(r).yy, rect(r).ww, rect(r).hh, rect(r).lk, rect(r).fk
End Sub
Sub newrect (XX, YY, WW, HH, klk, kfl)
rect_count = rect_count + 1
ReDim _Preserve rect(rect_count) As rect_type
rect(rect_count).xx = XX
rect(rect_count).yy = YY
rect(rect_count).ww = WW
rect(rect_count).hh = HH
rect(rect_count).lk = klk
rect(rect_count).fk = kfl
rect(rect_count).notes = "newrect"
End Sub
Sub addwater (rno, pcx, pcy, scale)
prr = Int(6 + Rnd * (12 * scale))
preps = (3 + Int(Rnd * prr))
For wr = 1 To preps
pcxx = pcx + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
pcyy = pcy + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcxx - x To pcxx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If pcyy + y >= rect(rno).yy And pcyy + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, pcyy + y)
If kk = Klgrey Then
PSet (x2, pcyy + y), kwater
End If
End If
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub addslime (rno, pcx, pcy, scale)
prr = Int(5 + Rnd * (10 * scale))
preps = (3 + Int(Rnd * prr))
For wr = 1 To preps
pcxx = pcx + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
pcyy = pcy + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcxx - x To pcxx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If pcyy + y >= rect(rno).yy And pcyy + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, pcyy + y)
If kk = Klgrey Or kk = kwater Then
PSet (x2, pcyy + y), kslime
End If
End If
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub addlava (rno, pcx, pcy, scale)
prr = Int(5 + Rnd * (10 * scale))
preps = (3 + Int(Rnd * prr))
For wr = 1 To preps
pcxx = pcx + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
pcyy = pcy + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcxx - x To pcxx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If pcyy + y >= rect(rno).yy And pcyy + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, pcyy + y)
If kk = Klgrey Or kk = kwater Or kk = kslime Then
If kk = kwater Then
If Abs(y) < prr / 2 Then
PSet (x2, pcyy + y), klava
Else
Select Case Int(1 + Rnd * 12)
Case 1, 2, 3, 4, 5
PSet (x2, pcyy + y), klava
Case 6, 7, 8
PSet (x2, pcyy + y), krubble
Case 9, 10
PSet (x2, pcyy + y), Klgrey
Case 11
PSet (x2, pcyy + y), Kdgrey
Case 12
PSet (x2, pcyy + y), kcrystal
End Select
End If
Else
PSet (x2, pcyy + y), klava
End If
End If
End If
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub addfungus (rno, pcx, pcy, scale)
prr = Int(2 + Rnd * (2 * scale))
preps = (3 + Int(Rnd * prr))
For wr = 1 To preps
pcxx = pcx + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
pcyy = pcy + Int(Rnd * (prr / 2)) - Int(Rnd * (prr / 2))
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcxx - x To pcxx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If pcyy + y >= rect(rno).yy And pcyy + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, pcyy + y)
If kk = Klgrey Or kk = kwater Then
If Int(1 + Rnd * 100) <= 30 Then PSet (x2, pcyy + y), kfungus
End If
End If
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Function checkrubble (xx, yy)
stumblecheck = Int(1 + Rnd * 120)
dmg = 0
If stumblecheck > health Then
Print "whooops.... you stumbled on the rubble...";
Select Case Int(1 + Rnd * 20)
Case 1
If Point(ppx - 1, ppy - 1) <> Kdgrey Then
ppx = ppx - 1: ppy = ppy - 1
End If
Case 2
If Point(ppx, ppy - 1) <> Kdgrey Then
ppy = ppy - 1
End If
Case 3
If Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppx = ppx + 1: ppy = ppy + 1
End If
Case 4
If Point(ppx - 1, ppy) <> Kdgrey Then
ppx = ppx - 1
End If
Case 6
If Point(ppx + 1, ppy) <> Kdgrey Then
ppx = ppx + 1
End If
Case 7
If Point(ppx - 1, ppy + 1) <> Kdgrey Then
ppx = ppx - 1: ppy = ppy + 1
End If
Case 8
If Point(ppx, ppy + 1) <> Kdgrey Then
ppy = ppy + 1
End If
Case 9
If Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppy = ppy + 1: ppx = ppx + 1
End If
Case 10, 11, 12, 13, 14
Print " knocking the wind out of you... ";
pstamina = Int(pstamina / 4)
Case 15, 16, 17, 18, 19, 20
ppx = lastx: ppy = lasty
Print "you tumble back...";
End Select
dmg = Abs(Int((Rnd * 3) - (Rnd * 3)))
If dmg > 0 Then
Print "you suffer "; dmg; " points of damage!"
Else
Print "."
End If
End If
checkrubble = dmg
End Function
Sub addcornerrubble (rno)
numcorn = Int(1 + Rnd * 4)
For crr = 1 To numcorn
Select Case Int(Rnd * 5)
Case 1
crx = rect(rno).xx + 1
cry = rect(rno).yy + 1
Case 2
crx = rect(rno).xx + 1
cry = rect(rno).yy + rect(rno).hh - 2
Case 3
crx = rect(rno).xx + rect(rno).ww - 2
cry = rect(rno).yy + 1
Case 4
crx = rect(rno).xx + rect(rno).ww - 2
cry = rect(rno).yy + rect(rno).hh - 2
End Select
prr = Int((rect(rno).hh + rect(rno).ww) / 12)
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = crx - x To crx + x
If x2 >= rect(rno).xx And x2 <= rect(rno).xx + rect(rno).ww Then
If cry + y >= rect(rno).yy And cry + y <= rect(rno).yy + rect(rno).hh Then
kk = Point(x2, cry + y)
If kk = Klgrey And Int(1 + Rnd * 100) < (cornerrubblechance * 2.5) Then
PSet (x2, cry + y), krubble
End If
End If
End If
Next
y = y + 1
Wend
Next crr
End Sub
Function checkcrystal (xx, yy)
climbcheck = Int(1 + Rnd * 100)
If climbcheck > phealth Then
Print "You just can't gain any purchase to climb the crystal."
Else
stumblecheck = Int(1 + Rnd * 120)
dmg = 0
If stumblecheck > health Then
Print ".... you fell from the crytsal...";
Select Case Int(1 + Rnd * 9)
Case 1
If Point(ppx - 1, ppy - 1) <> Kdgrey Then
ppx = ppx - 1: ppy = ppy - 1
End If
Case 2
If Point(ppx, ppy - 1) <> Kdgrey Then
ppy = ppy - 1
End If
Case 3
If Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppx = ppx + 1: ppy = ppy + 1
End If
Case 4
If Point(ppx - 1, ppy) <> Kdgrey Then
ppx = ppx - 1
End If
Case 5
ppx = lastx: ppy = lasty
Case 6
If Point(ppx + 1, ppy) <> Kdgrey Then
ppx = ppx + 1
End If
Case 7
If Point(ppx - 1, ppy + 1) <> Kdgrey Then
ppx = ppx - 1: ppy = ppy + 1
End If
Case 8
If Point(ppx, ppy + 1) <> Kdgrey Then
ppy = ppy + 1
End If
Case 9
If Point(ppx + 1, ppy + 1) <> Kdgrey Then
ppy = ppy + 1: ppx = ppx + 1
End If
End Select
dmg = Abs(Int((Rnd * 4) - (Rnd * 4)))
If dmg > 0 Then
Print "you suffer "; dmg; " points of damage!"
Else
Print "."
End If
End If
End If
checkcrystal = dmg
End Function
Sub coltileat (tn, ktc, xx, yy)
Dim kc As _Unsigned Long
_Source tiles&
_Dest ms
tx = tilespot(tn, 1): ty = tilespot(tn, 2)
For px = 0 To 16
For py = 0 To 15
kc = Point(tx + px, ty + py)
If kc <> Kblack Then
PSet (xx + px, yy + py), ktc
End If
Next py
Next px
_Source dmap
End Sub
Function getwalltile
wt = Int(1 + Rnd * 8)
Select Case wt
Case 1, 2, 3
wt = 8
Case 4, 5
wt = 15
Case 6
wt = 14
Case 7
wt = 11
Case 8
wt = 12
End Select
getwalltile = wt
End Function
Here's the tile set and loading function "DTDtiles.bi"
I've been using Spiral Linux, this one that came about a few weeks ago, which is based on Debian but is a lot like Ubuntu. I chose Cinnamon desktop environment, which is a first for me, similar to MATE but it might be the same for a different "skin" such as GNOME or KDE. Many others based on Debian or Ubuntu should be alike. The "default" profile of the terminal is dark print on light background. If the user doesn't change it to "dark mode", some messages QB64PE compiler gives out might not be readable unless "-m" switch is used to suppress all coloring. What if the user doesn't like "dark mode" for the terminal?
I use "-x" switch a lot because I consider the QB64 "mainwin" bothersome only for compilation and there might be a need to pick up the compiler's error messages into a text file. I think there is an "error log" for this, the same one as for the C++ compilation errors.
Finally there's at least one person that forgets to use "-e", or desires to enable verbose for reasons they have to be asked for.
I suppose things could be run from "-s" switch but it's yet another thing to remember when running the compiler.
Therefore I propose an environment variable, or an INI file loaded only by the compiler, that reads switches to use already if not specified at the command line. Something like "options.bin" but only for the compiler mode of QB64PE executable.
One more thing: the "-m" switch is not listed in the "man" page "qb64pe.1".
I've added new commands, more in-depth concepts, and of course the new look and feel. I'll post a banner on the old tutorial site directing everyone to the new site.
Have a look around and please report anything you find incorrect or needs fixing. I've probably looked over everything really well 5 times but I'm sure I missed something.
The old tutorial asset file will not work with this new version. I renamed the "Tasks" in the old tutorial to "Lessons" in this one. The new subdirectory names in the asset file reflect this. Also, I made modifications to some of the source code that will only be reflected in the new asset file.
Let me know what you think.
Also, I eventually want to create a lesson on Real-time/World Physics. I would really appreciate any help with this subject matter. Perhaps you want to write the lesson? Of course anyone that writes anything for the tutorial would get full credit. Have an idea for a lesson? Let me know. Now that I'm using Google Sites I can make modifications and additions quickly and easily.
So I decided on the long division methods over the approximation methods for nth roots then thought, why not apply these to decimal powers? It worked, because of the inverse relationship. So this is really choppy right now, and needs more work, but it looks like it is getting the digits correct.
What does it do?
Nth roots for whole numbers greater than zero.
Decimal roots for whole numbers greater than zero.
Mixed roots (Number >1 with decimal) for whole numbers greater than zero.
Powers for whole numbers greater than zero.
Decimal powers for whole numbers greater than zero.
Mixed powers (Power >1 with decimal) for whole numbers greater than zero.
So after I debug this for a bit, I want to see if I can figure out what needs to be done to go from whole numbers to mixed numbers with decimals and negative numbers.
Code: (Select All)
$CONSOLE:ONLY
DIM SHARED limit&&
PRINT "Demo does not display decimal point yet, and fails with zero roots/powers.": PRINT
DO
INPUT "Input 1 for general roots or 2 for decimal powers: "; k$
SELECT CASE k$
CASE "1"
LINE INPUT "Whole number: "; n$
LINE INPUT "Root: "; r$
j&& = INSTR(r$, ".")
IF j&& THEN ' Decimal or mixed whole and decimal.
IF j&& = 1 THEN ' Decimal only root. OKAY
pow$ = "1" + STRING$(LEN(r$) - 1, "0")
r$ = MID$(r$, INSTR(r$, ".") + 1)
''PRINT n$, r$, pow$
greatest_common_factor pow$, r$
''PRINT n$, r$, pow$: SLEEP
IF r$ <> "1" THEN GOSUB root_calc ELSE d$ = n$
tmp$ = d$
FOR i&& = 1 TO VAL(pow$) - 1
d$ = sm_mult$(tmp$, d$)
NEXT
sm_rt$ = d$
EXIT DO
ELSE ' Mixed whole and decimal root. OKAY
r_whole$ = MID$(r$, 1, INSTR(r$, ".") - 1)
r$ = MID$(r$, INSTR(r$, ".") + 1)
pow$ = "1" + STRING$(LEN(r$), "0")
''PRINT n$, r$, pow$
greatest_common_factor pow$, r$
''PRINT n$, r$, pow$
tmp$ = sm_mult$(r_whole$, pow$)
r$ = sm_add$(tmp$, r$)
''PRINT n$, r$: SLEEP
IF r$ <> "1" THEN GOSUB root_calc ELSE d$ = n$
''PRINT d$: SLEEP
tmp$ = d$ ' Combine both parts.
FOR i&& = 1 TO VAL(pow$) - 1
tmp$ = sm_mult$(tmp$, d$)
NEXT
sm_rt$ = tmp$
''PRINT sm_rt$
EXIT DO
END IF
ELSE ' Whole root. OKAY
IF r$ <> "1" THEN GOSUB root_calc ELSE d$ = n$
END IF
sm_rt$ = d$
EXIT DO
CASE "2"
LINE INPUT "Number: "; n$
LINE INPUT "Power: "; pow$
j&& = INSTR(pow$, ".")
IF j&& THEN ' Decimal or mixed whole and decimal.
IF j&& = 1 THEN ' Decimal only. OKAY
r$ = "1" + STRING$(LEN(pow$) - 1, "0")
pow$ = MID$(pow$, INSTR(pow$, ".") + 1)
''PRINT pow$, r$
greatest_common_factor pow$, r$
''PRINT pow$, r$: SLEEP
IF r$ <> "1" THEN GOSUB root_calc ELSE d$ = n$
sm_rt$ = d$
EXIT DO
ELSE ' Mixed whole number and decimal. OKAY
d_whole$ = n$
FOR i&& = 1 TO VAL(MID$(pow$, 1, INSTR(pow$, ".") - 1)) - 1
d_whole$ = sm_mult$(d_whole$, n$)
NEXT
pow$ = MID$(pow$, INSTR(pow$, ".") + 1)
r$ = "1" + STRING$(LEN(pow$), "0")
greatest_common_factor pow$, r$
''PRINT n$, d_whole$, r$, pow$: SLEEP
IF r$ <> "1" THEN GOSUB root_calc ELSE d$ = n$
''PRINT d$, d_whole$: SLEEP
d$ = sm_mult$(d_whole$, d$)
sm_rt$ = d$
EXIT DO
END IF
ELSE ' Whole number OKAY
d$ = n$
FOR i&& = 1 TO VAL(pow$) - 1
d$ = sm_mult$(d$, n$)
NEXT
sm_rt$ = d$
EXIT DO
END IF
END SELECT
LOOP
PRINT "Answer: "; sm_rt$: PRINT
RUN
root_calc:
' Decimal root conversion.
r = VAL(r$)
nu&& = INSTR(n$, ".") - 1: IF nu&& < 0 THEN nu&& = LEN(n$)
h&& = (r - (r - nu&& MOD r)) + 1
t$ = MID$(n$, 1, h&& - 1): d$ = "0"
limit&& = 16
' Calculate Pascal's Triangle.
REDIM p$(r + 1)
FOR i1&& = 1 TO r + 1
p&& = 1
FOR j1&& = 1 TO i1&&
p$(j1&&) = LTRIM$(STR$(p&&))
p&& = p&& * (i1&& - j1&&) \ j1&&
NEXT
NEXT
DO
oldx$ = "0"
lcnt&& = lcnt&& + 1
FOR j = 1 TO 10
x$ = "0"
FOR i&& = 1 TO r
REM PRINT "(10 ^"; (i&& - 1); "*"; p$(i&&); "* d ^"; i&& - 1; " * j ^"; (r + 1 - i&&); ") + ";
REM x = x + 10 ^ (i&& - 1) * VAL(p$(i&&)) * d ^ (i&& - 1) * j ^ (r + 1 - i&&)
tmp$ = "1"
FOR k% = 1 TO i&& - 1
tmp$ = sm_mult$(tmp$, "10")
NEXT
tmp$ = sm_mult$(tmp$, p$(i&&))
tmp2$ = "1"
FOR k% = 1 TO i&& - 1
tmp2$ = sm_mult$(tmp2$, d$)
NEXT
IF d$ = "0" AND k% = 1 THEN tmp2$ = "1" ' zero^0 = 1
tmp3$ = sm_mult$(tmp$, tmp2$)
tmp$ = "1"
FOR k% = 1 TO r + 1 - i&&
tmp$ = sm_mult$(tmp$, LTRIM$(STR$(j)))
NEXT
tmp2$ = sm_mult$(tmp3$, tmp$)
x$ = sm_add(x$, tmp2$)
NEXT
IF LEN(x$) > LEN(t$) OR LEN(x$) = LEN(t$) AND x$ > t$ THEN EXIT FOR
oldx$ = x$
NEXT
d$ = d$ + LTRIM$(STR$(j - 1))
IF LEFT$(d$, 1) = "0" THEN d$ = MID$(d$, 2) ' Remove leading zero.
tmp1$ = sm_sub$(t$, oldx$)
tmp2$ = MID$(n$, h&&, r) + STRING$(r - LEN(MID$(n$, h&&, r)), "0")
t$ = tmp1$ + tmp2$
IF LEFT$(t$, 1) = "0" THEN t$ = MID$(t$, 2) 'Remove leading zero.
h&& = h&& + r
IF t$ = STRING$(LEN(t$), "0") AND h&& >= LEN(n$) OR lcnt&& = limit&& THEN EXIT DO
IF dpx&& = 0 THEN ' Decimal point relocator. Limited to && size unless converted to string.
IF h&& >= nu&& THEN
dpx&& = INT(nu&& / 2 + .5)
IF dpx&& = 0 THEN dpx&& = -1 ' Do not set to zero as -1 accomplishes the same thing and prevents ongoing loops here.
END IF
END IF
LOOP
dpx&& = 0 ' Remove this when all decimal situations are included.
IF dpx&& THEN
sm_rt$ = MID$(d$, 0, dpx&& + 1) + "." + MID$(d$, dpx&& + 1)
ELSE
sm_rt$ = d$
END IF
RETURN
SUB sm_greater_lesser (stringmatha$, stringmathb$, gl%)
compa$ = stringmatha$: compb$ = stringmathb$ ' So original variables do not get changed.
DO
WHILE -1 ' Falx loop.
IF gl% = 2 THEN EXIT WHILE ' For bypassing sign and decimal adjustments when only positive non-decimal numbers are being evaluated.
' Remove trailing zeros after a decimal point.
IF INSTR(compa$, ".") THEN
DO UNTIL RIGHT$(compa$, 1) <> "0" AND RIGHT$(compa$, 1) <> "." AND RIGHT$(compa$, 1) <> "-"
compa$ = MID$(compa$, 1, LEN(compa$) - 1)
LOOP
END IF
IF INSTR(compb$, ".") THEN
DO UNTIL RIGHT$(compb$, 1) <> "0" AND RIGHT$(compb$, 1) <> "." AND RIGHT$(compb$, 1) <> "-"
compb$ = MID$(compb$, 1, LEN(compb$) - 1)
LOOP
END IF
IF MID$(compa$, 1, 2) = "-0" OR compa$ = "" OR compa$ = "-" THEN compa$ = "0"
IF MID$(compb$, 1, 2) = "-0" OR compb$ = "" OR compb$ = "-" THEN compb$ = "0"
' A - and +
j% = 0: k% = 0
IF LEFT$(compa$, 1) = "-" THEN j% = -1
IF LEFT$(compb$, 1) = "-" THEN k% = -1
IF k% = 0 AND j% THEN gl% = -1: EXIT DO
IF j% = 0 AND k% THEN gl% = 1: EXIT DO
j&& = INSTR(compa$, ".")
k&& = INSTR(compb$, ".")
' A starting decimal and non-decimal.
IF j&& = 0 AND k&& = 1 THEN
IF compa$ = "0" THEN gl% = -1 ELSE gl% = 1
EXIT DO
END IF
IF k&& = 0 AND j&& = 1 THEN
IF compb$ = "0" THEN gl% = 1 ELSE gl% = -1
EXIT DO
END IF
' remove decimals and align.
j2&& = 0: k2&& = 0
IF j&& <> 0 OR k&& <> 0 THEN
IF j&& THEN compa$ = MID$(compa$, 1, INSTR(compa$, ".") - 1) + MID$(compa$, INSTR(compa$, ".") + 1): j2&& = LEN(compa$) - j&& + 1
IF k&& THEN compb$ = MID$(compb$, 1, INSTR(compb$, ".") - 1) + MID$(compb$, INSTR(compb$, ".") + 1): k2&& = LEN(compb$) - k&& + 1
compa$ = compa$ + STRING$(k2&& - j2&&, "0")
compb$ = compb$ + STRING$(j2&& - k2&&, "0")
END IF
EXIT WHILE
WEND
' Remove leading zeros if any.
DO UNTIL LEFT$(compa$, 1) <> "0"
compa$ = MID$(compa$, 2)
LOOP
IF compa$ = "" THEN compa$ = "0"
DO UNTIL LEFT$(compb$, 1) <> "0"
compb$ = MID$(compb$, 2)
LOOP
IF compb$ = "" THEN compb$ = "0"
' Both positive or both negative whole numbers.
SELECT CASE LEN(compa$)
CASE IS < LEN(compb$)
gl% = -1
CASE IS = LEN(compb$)
IF compa$ = compb$ THEN
gl% = 0
ELSEIF compa$ > compb$ THEN gl% = 1
ELSEIF compa$ < compb$ THEN gl% = -1
END IF
CASE IS > LEN(compb$)
gl% = 1
END SELECT
EXIT DO
LOOP
END SUB
SUB sm_add_subtract_router (stringmatha$, operator$, stringmathb$, runningtotal$)
DIM AS _INTEGER64 a, c, s
a1$ = stringmatha$: b1$ = stringmathb$
s = 18: i&& = 0: c = 0
IF op$ = "-" THEN
IF LEFT$(b$, 1) = "-" THEN b$ = MID$(b$, 2) ELSE b$ = "-" + b$
END IF
IF INSTR(a$, ".") <> 0 OR INSTR(b$, ".") <> 0 THEN
decimal% = -1
IF INSTR(a$, ".") <> 0 THEN
dec_a&& = LEN(MID$(a$, INSTR(a$, ".") + 1))
a$ = MID$(a$, 1, INSTR(a$, ".") - 1) + MID$(a$, INSTR(a$, ".") + 1)
END IF
IF INSTR(b$, ".") <> 0 THEN
dec_b&& = LEN(MID$(b$, INSTR(b$, ".") + 1))
b$ = MID$(b$, 1, INSTR(b$, ".") - 1) + MID$(b$, INSTR(b$, ".") + 1)
END IF
' Line up decimal places by inserting trailing zeros.
IF dec_b&& > dec_a&& THEN
j&& = dec_b&&
a$ = a$ + STRING$(dec_b&& - dec_a&&, "0")
ELSE
j&& = dec_a&&
b$ = b$ + STRING$(dec_a&& - dec_b&&, "0")
END IF
END IF
IF LEFT$(a$, 1) = "-" OR LEFT$(b$, 1) = "-" THEN
IF LEFT$(a$, 1) = "-" AND LEFT$(b$, 1) = "-" THEN
sign$ = "": a$ = MID$(a$, 2): b$ = MID$(b$, 2)
ELSE
IF LEFT$(a$, 1) = "-" THEN a$ = MID$(a$, 2): sign_a$ = "-"
IF LEFT$(b$, 1) = "-" THEN b$ = MID$(b$, 2): sign_b$ = "-"
IF LEFT$(a1$, 1) = "-" THEN a1_x$ = MID$(a1$, 2) ELSE a1_x$ = a1$
IF LEFT$(b1$, 1) = "-" THEN b1_x$ = MID$(b1$, 2) ELSE b1_x$ = b1$
sm_greater_lesser a1_x$, b1_x$, gl%
IF gl% < 0 THEN
IF LEN(sign_b$) THEN sign$ = "-": SWAP a$, b$
ELSE
IF LEN(sign_a$) THEN sign$ = "-": SWAP sign_a$, sign_b$
END IF
END IF
END IF
z$ = ""
' Addition and subtraction of digits.
DO
i&& = i&& + s
x1$ = MID$(a$, LEN(a$) - i&& + 1, s)
x2$ = MID$(b$, LEN(b$) - i&& + 1, s)
IF LEN(x2$) > LEN(x1$) THEN SWAP x1$, x2$
a = VAL(sign_a$ + x1$) + VAL(sign_b$ + x2$) + c
IF x1$ + x2$ = "" AND c = 0 THEN EXIT DO
c = 0
IF a > VAL(STRING$(s, "9")) THEN a = a - 10 ^ s: c = 1
IF a < 0 THEN a = a + 10 ^ s: c = -1 ' a will never be less than 0.
tmp$ = LTRIM$(STR$(a))
z$ = STRING$(LEN(x1$) - LEN(tmp$), "0") + tmp$ + z$
LOOP
IF decimal% THEN
z$ = MID$(z$, 1, LEN(z$) - j&&) + "." + MID$(z$, LEN(z$) - j&& + 1)
END IF
' Remove any leading zeros.
DO
IF LEFT$(z$, 1) = "0" THEN z$ = MID$(z$, 2) ELSE EXIT DO
LOOP
IF z$ = "" OR z$ = "0" THEN z$ = "0" ELSE z$ = LEFT$(sign$, 1) + z$
runningtotal$ = z$
sign$ = "": sign_a$ = "": sign_b$ = "": i&& = 0: j&& = 0: decimal% = 0: c = 0
END SUB
FUNCTION sm_add$ (stringmatha$, stringmathb$)
operator$ = "+"
sm_add_subtract_router stringmatha$, operator$, stringmathb$, runningtotal$
sm_add$ = runningtotal$
END FUNCTION
FUNCTION sm_sub$ (stringmatha$, stringmathb$)
operator$ = "-"
sm_add_subtract_router stringmatha$, operator$, stringmathb$, runningtotal$
sm_sub$ = runningtotal$
END FUNCTION
FUNCTION sm_mult$ (stringmatha$, stringmathb$)
DIM AS _INTEGER64 a, c, aa, cc, s, ss
z$ = "": sign$ = "": mult&& = 0: h&& = 0: i&& = 0: j&& = 0: c = 0: decimal% = 0
zz$ = "": ii&& = 0: jj&& = 0
s = 8: ss = 18
a$ = stringmatha$: b$ = stringmathb$
IF INSTR(a$, "-") <> 0 OR INSTR(b$, "-") <> 0 THEN
IF INSTR(a$, "-") <> 0 AND INSTR(b$, "-") <> 0 THEN
a$ = MID$(a$, 2): b$ = MID$(b$, 2)
ELSE
IF INSTR(a$, "-") <> 0 THEN a$ = MID$(a$, 2) ELSE b$ = MID$(b$, 2)
sign$ = "-"
END IF
END IF
IF INSTR(a$, ".") <> 0 OR INSTR(b$, ".") <> 0 THEN
decimal% = -1
IF INSTR(a$, ".") <> 0 THEN
dec_a&& = LEN(MID$(a$, INSTR(a$, ".") + 1))
a$ = MID$(a$, 1, INSTR(a$, ".") - 1) + MID$(a$, INSTR(a$, ".") + 1)
END IF
IF INSTR(b$, ".") <> 0 THEN
dec_b&& = LEN(MID$(b$, INSTR(b$, ".") + 1))
b$ = MID$(b$, 1, INSTR(b$, ".") - 1) + MID$(b$, INSTR(b$, ".") + 1)
END IF
END IF
IF LEN(a$) < LEN(b$) THEN SWAP a$, b$ ' Needed so x1$ is always the largest for leading zero replacements.
' Multiplication of digits.
DO
h&& = h&& + s: i&& = 0
x2$ = MID$(b$, LEN(b$) - h&& + 1, s)
DO
i&& = i&& + s
x1$ = MID$(a$, LEN(a$) - i&& + 1, s)
a = VAL(x1$) * VAL(x2$) + c
c = 0
tmp$ = LTRIM$(STR$(a))
IF LEN(tmp$) > s THEN c = VAL(MID$(tmp$, 1, LEN(tmp$) - s)): tmp$ = MID$(tmp$, LEN(tmp$) - s + 1)
z$ = STRING$(LEN(x1$) - LEN(tmp$), "0") + tmp$ + z$
LOOP UNTIL i&& >= LEN(a$) AND c = 0
jj&& = jj&& + 1
IF jj&& > 1 THEN
ii&& = 0: cc = 0
aa$ = holdaa$
bb$ = z$ + STRING$((jj&& - 1) * s, "0")
' Addition only of digits.
DO
ii&& = ii&& + ss
xx1$ = MID$(aa$, LEN(aa$) - ii&& + 1, ss)
xx2$ = MID$(bb$, LEN(bb$) - ii&& + 1, ss)
IF LEN(xx1$) < LEN(xx2$) THEN SWAP xx1$, xx2$
aa = VAL(xx1$) + VAL(xx2$) + cc
IF xx1$ + xx2$ = "" AND cc = 0 THEN EXIT DO ' Prevents leading zeros.
cc = 0
IF aa > VAL(STRING$(ss, "9")) THEN aa = aa - 10 ^ ss: cc = 1
tmp$ = LTRIM$(STR$(aa))
zz$ = STRING$(LEN(xx1$) - LEN(tmp$), "0") + tmp$ + zz$
LOOP
DO WHILE LEFT$(zz$, 1) = "0"
IF LEFT$(zz$, 1) = "0" THEN zz$ = MID$(zz$, 2)
LOOP
IF zz$ = "" THEN zz$ = "0"
holdaa$ = zz$
ELSE
holdaa$ = z$ + STRING$(jj&& - 1, "0")
END IF
z$ = "": zz$ = ""
LOOP UNTIL h&& >= LEN(b$)
z$ = holdaa$
IF decimal% THEN
DO UNTIL LEN(z$) >= dec_a&& + dec_b&&
z$ = "0" + z$
LOOP
DO UNTIL RIGHT$(z$, 1) <> "0" AND RIGHT$(z$, 1) <> "."
z$ = MID$(z$, 1, LEN(z$) - 1)
LOOP
END IF
IF STRING$(LEN(z$), "0") = z$ OR z$ = "" OR z$ = "0" THEN z$ = "0" ELSE z$ = sign$ + z$
decimal% = 0: sign$ = ""
runningtotal$ = z$
sm_mult$ = z$
END FUNCTION
FUNCTION sm_div$ (stringmatha$, stringmathb$)
hold_stringmatha$ = stringmatha$: hold_stringmathb$ = stringmathb$
q$ = "": divisor$ = stringmathb$: dividend$ = stringmatha$
DO ' Falx loop.
'Strip off neg(s) and determine quotent sign.
IF LEFT$(divisor$, 1) = "-" THEN divisor$ = MID$(divisor$, 2): q$ = "-"
IF LEFT$(dividend$, 1) = "-" THEN dividend$ = MID$(dividend$, 2): IF q$ = "-" THEN q$ = "" ELSE q$ = "-"
' Quick results for divisor 1 or 0.
IF dividend$ = "0" THEN q$ = "0": EXIT DO
IF divisor$ = "1" THEN q$ = dividend$: EXIT DO
IF divisor$ = "0" THEN q$ = "Division by zero not possible.": EXIT DO
' Determine decimal direction. -1 to left, +1 to right.
gl% = 0: sm_greater_lesser divisor$, dividend$, gl%
IF betatest% AND gl% = 1 THEN PRINT divisor$; " > "; dividend$; " Move decimal to the left"
IF betatest% AND gl% = 0 THEN PRINT divisor$; " = "; dividend$
IF betatest% AND gl% = -1 THEN PRINT divisor$; " < "; dividend$; " Move deciml to the right."
IF gl% = 1 THEN ' Divisor is larger than dividend so decimal moves to the left.
div_decimal% = -1 ' Move decimal point to the left.
ELSEIF gl% = -1 THEN
div_decimal% = 1 ' Move decimal point to the right.
ELSE
' Divisor and dividend are the same number.
q$ = q$ + "1": EXIT DO
END IF
divisor_ratio_dividend% = gl%
' Strip off decimal point(s) and determine places in these next 2 routines.
dp&& = 0: dp2&& = 0: j2&& = 0
temp&& = INSTR(divisor$, ".")
IF temp&& THEN
divisor$ = MID$(divisor$, 1, temp&& - 1) + MID$(divisor$, temp&& + 1)
IF temp&& = 1 THEN
DO UNTIL LEFT$(divisor$, 1) <> "0" ' Strip off any leading zeros on divisor only.
divisor$ = MID$(divisor$, 2)
dp&& = dp&& + 1
LOOP
dp&& = dp&& + 1
ELSE
dp&& = -(temp&& - 2)
END IF
ELSE
dp&& = -(LEN(divisor$) - 1)
END IF
temp&& = INSTR(dividend$, ".")
IF temp&& THEN
dividend$ = MID$(dividend$, 1, temp&& - 1) + MID$(dividend$, temp&& + 1)
IF temp&& = 1 THEN
DO UNTIL LEFT$(dividend$, 1) <> "0" ' Strip off any leading zeros on divisor only.
dividend$ = MID$(dividend$, 2)
dp2&& = dp2&& + 1
LOOP
dp2&& = dp2&& + 1
ELSE
dp2&& = -(temp&& - 2)
END IF
ELSE
dp2&& = -(LEN(dividend$) - 1)
END IF
IF betatest% THEN COLOR 11: PRINT "Divisor decimal moves "; LTRIM$(STR$(dp&&)); ". Dividend decimal moves"; LTRIM$(STR$(dp2&&)); ". Quotent decimal ABS("; LTRIM$(STR$(dp&&)); " - "; LTRIM$(STR$(dp2&&)); ") =";: COLOR 14: PRINT ABS(dp&& - dp2&&);: COLOR 11: PRINT "+ any adjustment.": COLOR 7
dp&& = ABS(dp&& - dp2&&)
IF betatest% THEN PRINT "Divisor 1st# = "; MID$(divisor$, 1, 1); " Remainder 1st# = "; MID$(dividend$, 1, 1)
' Adjust decimal place for instances when divisor is larger than remainder the length of the divisor.
j% = 0
IF MID$(divisor$, 1, 1) > MID$(dividend$, 1, 1) THEN
j% = 1
IF betatest% THEN PRINT "Larger divisor, so move quotent decimal one place back to: ";: COLOR 14: PRINT LTRIM$(STR$(dp&&)): COLOR 7
ELSEIF MID$(divisor$, 1, 1) = MID$(dividend$, 1, 1) THEN
IF LEN(divisor$) = LEN(dividend$) THEN
IF divisor$ > dividend$ THEN j% = 1
ELSE
IF LEN(divisor$) > LEN(dividend$) THEN
temp$ = dividend$ + STRING$(LEN(divisor$) - LEN(dividend$), "0")
ELSE
temp$ = MID$(dividend$, 1, LEN(divisor$))
END IF
IF divisor$ > temp$ THEN j% = 1
END IF
IF betatest% THEN
IF j% THEN PRINT "Larger divisor than dividend at LEN(divisor$), so move quotent decimal one place back to: ";: COLOR 14: PRINT LTRIM$(STR$(dp&&)): COLOR 7
IF j% = 0 THEN PRINT "Smaller divisor than dividend at LEN(divisor$), so no quotent decimal place adjustment needed. Quotent decimal place = ";: COLOR 14: PRINT LTRIM$(STR$(dp&&)): COLOR 7
END IF
ELSE
j% = 0
IF betatest% THEN PRINT "Smaller divisor, so no quotent decimal place adjustment needed. Quotent decimal place = ";: COLOR 14: PRINT LTRIM$(STR$(dp&&)): COLOR 7
END IF
IF j% THEN dp&& = dp&& - div_decimal%
origdividend$ = dividend$
' Determine length of divisor and dividend to begin initial long divison step.
gl% = 2: sm_greater_lesser divisor$, MID$(dividend$, 1, LEN(divisor$)) + STRING$(LEN(divisor$) - LEN(dividend$), "0"), gl%
divisor_ratio_dividend% = gl%
IF gl% = 1 AND MID$(dividend$, 1, 1) <> "0" THEN
dividend$ = MID$(dividend$, 1, LEN(divisor$) + 1) + STRING$(LEN(divisor$) + 1 - LEN(dividend$), "0")
ELSE
dividend$ = MID$(dividend$, 1, LEN(divisor$)) + STRING$(LEN(divisor$) - LEN(dividend$), "0")
END IF
' Long divison loop. Mult and subtraction of dividend and remainder.
k&& = 0
IF betatest% THEN PRINT "Begin long divison loop..."
DO
SELECT CASE MID$(divisor$, 1, 1)
CASE IS < MID$(dividend$, 1, 1)
adj_rem_len% = 0
CASE IS = MID$(dividend$, 1, 1)
gl% = 2: sm_greater_lesser divisor$, MID$(dividend$, 1, LEN(divisor$)), gl%
IF gl% = 1 THEN adj_rem_len% = 1 ELSE adj_rem_len% = 0
CASE IS > MID$(dividend$, 1, 1)
adj_rem_len% = 1
END SELECT
IF j2&& = 0 THEN j2&& = LEN(divisor$) + adj_rem_len%
DO
IF LEN(divisor$) > LEN(dividend$) THEN
w3&& = 0: runningtotal$ = dividend$: stringmathb$ = "0"
IF betatest% THEN PRINT: COLOR 3: PRINT "Divisor is larger so "; dividend$; " \ "; divisor$; " =";: COLOR 5: PRINT w3&&: COLOR 7
EXIT DO
END IF
IF LEN(divisor$) = LEN(dividend$) THEN
gl% = 2: sm_greater_lesser divisor$, dividend$, gl%
IF gl% = 1 THEN
w3&& = 0: runningtotal$ = dividend$: stringmathb$ = "0"
IF betatest% THEN COLOR 9: PRINT "Length of divisor is the same as remainder but remainder is smaller so w3&& = ";: COLOR 5: PRINT "0": COLOR 7
EXIT DO
END IF
END IF
SELECT CASE LEN(dividend$)
CASE IS > 2
w3&& = VAL(MID$(dividend$, 1, 2 + adj_rem_len%)) \ VAL(MID$(divisor$, 1, 2))
IF betatest% THEN PRINT MID$(dividend$, 1, 2 + adj_rem_len%); " \ "; MID$(divisor$, 1, 2); " =";
CASE ELSE
w3&& = VAL(MID$(dividend$, 1, 1 + adj_rem_len%)) \ VAL(MID$(divisor$, 1, 1))
IF betatest% THEN PRINT MID$(dividend$, 1, 1 + adj_rem_len%); " \ "; MID$(divisor$, 1, 1); " =";
END SELECT
IF betatest% THEN COLOR 5: PRINT " " + LTRIM$(STR$(w3&&));: COLOR 7: PRINT ". Begin mult est. at or one above this number."
IF w3&& < 9 THEN w3&& = w3&& + 1 ELSE IF w3&& = 10 THEN w3&& = 9
DO
stringmatha$ = divisor$: stringmathb$ = LTRIM$(STR$(w3&&))
runningtotal$ = sm_mult$(divisor$, LTRIM$(STR$(w3&&)))
gl% = 2: sm_greater_lesser runningtotal$, dividend$, gl%
IF gl% <= 0 OR w3&& = 0 THEN EXIT DO
IF betatest% THEN COLOR 8: PRINT "Mult loop:"; w3&&; "* "; divisor$; " = "; runningtotal$: COLOR 7
w3&& = w3&& - 1
LOOP
stringmatha$ = dividend$: stringmathb$ = runningtotal$
sm_add_subtract_router dividend$, "-", stringmathb$, runningtotal$
EXIT DO
LOOP
IF betatest% THEN PRINT LTRIM$(STR$(w3&&)); " * "; divisor$; " = "; stringmathb$; " | "; stringmatha$; " - "; stringmathb$; " = "; runningtotal$; " Remainder and drop-down = ";
j2&& = j2&& + 1
drop$ = "0": MID$(drop$, 1, 1) = MID$(origdividend$, j2&&, 1)
IF runningtotal$ <> "0" THEN remainder$ = runningtotal$ ELSE remainder$ = ""
dividend$ = remainder$ + drop$
w3$ = LTRIM$(STR$(w3&&))
temp$ = ""
IF div_decimal% = -1 THEN
IF dp&& AND k&& = 0 THEN
q$ = q$ + "." + STRING$(dp&& - 1, "0")
IF w3&& = 0 THEN w3$ = ""
END IF
END IF
IF div_decimal% >= 0 THEN
IF dp&& = k&& THEN
temp$ = "."
END IF
END IF
q$ = q$ + w3$ + temp$
IF betatest% AND remainder$ = "" THEN betatemp$ = CHR$(34) + CHR$(34) ELSE IF betatest% THEN betatemp$ = remainder$
IF betatest% AND MID$(origdividend$, j2&&, 1) = "" THEN betatemp2$ = CHR$(34) + CHR$(34) ELSE IF betatest% THEN betatemp2$ = MID$(origdividend$, j2&&, 1)
IF betatest% THEN PRINT dividend$; " ("; betatemp$; " + "; drop$; ") at:"; j2&&; "of "; origdividend$; " Loop"; k&& + 1; "Quotent = ";: COLOR 14, 4: PRINT q$;: COLOR 7, 0: PRINT: SLEEP
' Check to terminate
IF div_decimal% = -1 THEN
' Decimal to left.
IF remainder$ = "" AND MID$(origdividend$, j2&&, 1) = "" OR LEN(q$) >= limit&& THEN EXIT DO
ELSE
' Decimal to right.
IF remainder$ = "" AND MID$(origdividend$, j2&&, 1) = "" AND k&& >= dp&& OR LEN(q$) >= limit&& THEN EXIT DO
END IF
IF INKEY$ = " " THEN EXIT DO
k&& = k&& + 1
LOOP
EXIT DO
LOOP
IF RIGHT$(q$, 1) = "." AND divisor$ <> "0" THEN runningtotal$ = MID$(q$, 1, LEN(q$) - 1) ELSE runningtotal$ = q$
sm_div$ = runningtotal$
stringmatha$ = hold_stringmatha$: stringmathb$ = hold_stringmathb$
END FUNCTION
SUB greatest_common_factor (gfca$, gfcb$)
IF betatest% THEN PRINT "Pre-GFC "; gfca$; " / "; gfcb$
numerator$ = gfca$: denominator$ = gfcb$
' Make both numbers positive.
IF MID$(gfca$, 1, 1) = "-" THEN gfca$ = MID$(gfca$, 2)
IF MID$(gfcb$, 1, 1) = "-" THEN gfcb$ = MID$(gfcb$, 2)
CALL sm_greater_lesser(gfca$, gfcb$, gl%)
IF gl% THEN SWAP gfca$, gfcb$
DO
stringmatha$ = gfca$: stringmathb$ = gfcb$
runningtotal$ = sm_div$(stringmatha$, stringmathb$)
IF INSTR(runningtotal$, ".") THEN runningtotal$ = MID$(runningtotal$, 1, INSTR(runningtotal$, ".") - 1)
stringmatha$ = runningtotal$: stringmathb$ = gfcb$
runningtotal$ = sm_mult$(stringmatha$, stringmathb$)
stringmatha$ = gfca$: stringmathb$ = runningtotal$
runningtotal$ = sm_sub$(stringmatha$, stringmathb$)
SWAP gfca$, gfcb$: gfcb$ = runningtotal$
IF runningtotal$ = "0" THEN EXIT DO
LOOP
stringmatha$ = numerator$: stringmathb$ = gfca$
IF betatest% THEN PRINT "GFC = "; gfca$
numerator$ = sm_div$(stringmatha$, stringmathb$)
stringmatha$ = denominator$: stringmathb$ = gfca$
denominator$ = sm_div$(stringmatha$, stringmathb$)
gfca$ = numerator$: gfcb$ = denominator$ ' Needed to pass back.
IF betatest% THEN PRINT "Fraction: "; numerator$; " / "; denominator$
END SUB
Wat I like is this format reduces fractions, which helps eliminates some rounding errors. For example, if the computation requires something like find the .2 root of 6, well, 2/10 root of 6 would be square root of 6 = 2.449489742783178 ^ 10 = 7,775.9999999999968826892081723528 whereas reducing 2/10 to 1/5 leaves us with 6^5 = 7,776.
Again, to solve for the discrepancy if reducing the fraction is not possible, or just doesn't matter, means I would have to get numbers lik the square root of 6 in either enough digits to reach the terminating decimal or convert the remainder and digits calculated to a fraction. So yes, Virginia, there is a Santa Clause, and I'd bet he'd rather shove his fat ascii down chimneys all night than mess with stuff.
I have a program that writes a series of numbers to a file that I can recall. The problem is I have to go into the program each time I want to write a different record.
OPEN "RECORD16.DAT" FOR OUTPUT AS #1
FOR TTP = 1 TO 8
FOR X = 1 TO 3
PRINT #1, ALINE(X, TTP)
PRINT #1, TIME(X, TTP)
NEXT X
NEXT TTP
CLOSE #1
I want to be able to make a new record :record16.dat without going to the program and changing it,
record 17.dat, or record18.dat or whatever. I also want to be able to recall this new record.
I hope I was able to explain this for someone to understand how I can add to my data base without doing it manually. Thank you
Here is some code you can use for accessing WinGDI in QB64. You can print straight to your printer or you can pick "Microsoft Print to PDF" if you just want to save a file.
Attached is the necessary header file as well as a PDF output of what the code currently makes.
Code: (Select All)
Option _Explicit
$ExeIcon:'.\internal\source\icon.ico'
_Icon
$VersionInfo:CompanyName=SpriggsySpriggs
$VersionInfo:ProductName=WinGDI Test
$VersionInfo:FileDescription=A test of the WinGDI printing system
$ScreenHide
Type SIZE
As Long cx, cy
End Type
Type POINT
As Long x, y
End Type
Type MSG
As _Offset hwnd
As _Unsigned Long message
As _Unsigned _Offset wParam
As _Offset lParam
As Long time
As POINT pt
As Long lPrivate
End Type
Type DOCINFO
As Long cbSize
As _Offset lpszDocName, lpszOutput, lpszDatatype
As _Unsigned Long fwType
End Type
Type PRINTDLG
As _Unsigned Long lStructSize
$If 64BIT Then
As String * 4 padding
$End If
As _Offset hwndOwner, hDevMode, hDevNames, hDC
As _Unsigned Long Flags
As _Unsigned Integer nFromPage, nToPage, nMinPage, nMaxPage, nCopies
$If 64BIT Then
As String * 2 padding2
$End If
As _Offset hInstance, lCustData, lpfnPrintHook, lpfnSetupHook, lpPrintTemplateName, lpSetupTemplateName, hPrintTemplate, hSetupTemplate
End Type
Declare Dynamic Library "Comdlg32"
Sub PrintDlg Alias "PrintDlgA" (ByVal lppd As _Offset)
End Declare
Declare Dynamic Library "Gdi32"
Function GetDeviceCaps& (ByVal hdc As _Offset, Byval index As Long)
Sub SelectObject (ByVal hdc As _Offset, Byval h As _Offset)
Function CreatePen%& (ByVal iStyle As Long, Byval cWidth As Long, Byval color As _Unsigned Long)
Sub Rectangle (ByVal hdc As _Offset, Byval left As Long, Byval top As Long, Byval right As Long, Byval bottom As Long)
Sub SetBkMode (ByVal hdc As _Offset, Byval mode As Long)
Sub TextOut Alias "TextOutA" (ByVal hdc As _Offset, Byval x As Long, Byval y As Long, Byval lpString As _Offset, Byval c As Long)
Function SetAbortProc& (ByVal hdc As _Offset, Byval proc As _Offset)
Sub StartDoc Alias "StartDocA" (ByVal hdc As _Offset, Byval lpdi As _Offset)
Sub StartPage (ByVal hdc As _Offset)
Sub EndPage (ByVal hdc As _Offset)
Sub EndDoc (ByVal hdc As _Offset)
Sub DeleteDC (ByVal hdc As _Offset)
Function CreateFont%& Alias "CreateFontA" (ByVal cHeight As Long, Byval cWidth As Long, Byval cEscapement As Long, Byval cOrientation As Long, Byval cWeight As Long, Byval bItalic As _Unsigned Long, Byval bUnderline As _Unsigned Long, Byval bStrikeout As _Unsigned Long, Byval iCharSet As _Unsigned Long, Byval iOutPrecision As _Unsigned Long, Byval iClipPrecision As _Unsigned Long, Byval iQuality As _Unsigned Long, Byval iPitchAndFamily As _Unsigned Long, pszFaceName As String)
Sub SetTextColor (ByVal hdc As _Offset, Byval color As _Unsigned Long)
Sub GetTextExtentPoint32 Alias "GetTextExtentPoint32A" (ByVal hdc As _Offset, lpString As String, Byval c As Long, Byval psizl As _Offset)
End Declare
Declare CustomType Library
Function PeekMessage& (ByVal lpMsg As _Offset, Byval hWnd As _Offset, Byval wMsgFilterMin As _Unsigned Long, Byval wMsgFilterMax As _Unsigned Long, Byval wRemoveMsg As _Unsigned Long)
Sub TranslateMessage (ByVal lpMsg As _Offset)
Sub DispatchMessage (ByVal lpMsg As _Offset)
Sub MessageBox (ByVal hWnd As _Offset, lpText As String, lpCaption As String, Byval uType As _Unsigned Long)
Function GetLastError~& ()
End Declare
Declare CustomType Library "abort"
Function pAbortProc%& ()
End Declare
$If 64BIT Then
Declare Library ".\internal\c\c_compiler\x86_64-w64-mingw32\include\wingdi"
Function RGB~& (ByVal r As _Unsigned _Byte, Byval g As _Unsigned _Byte, Byval b As _Unsigned _Byte)
End Declare
$Else
Declare Library ".\internal\c\c_compiler\i686-w64-mingw32\include\wingdi"
Function RGB~& (ByVal r As _Unsigned _Byte, Byval g As _Unsigned _Byte, Byval b As _Unsigned _Byte)
End Declare
$End If
Dim Shared As PRINTDLG pdlg
PrintJob
System
Sub InitPrintJobDoc (di As DOCINFO, docname As String)
docname = docname + Chr$(0)
di.cbSize = Len(di)
di.lpszDocName = _Offset(docname)
End Sub
Sub DrawPage (hdc As _Offset, Page As _Unsigned Long)
Const HORZRES = 8
Const VERTRES = 10
Const PS_SOLID = 0
Const TRANSPARENT = 1
Dim As String * 50 gdiline
Dim As Long nWidth, nHeight
nWidth = GetDeviceCaps(hdc, HORZRES)
nHeight = GetDeviceCaps(hdc, VERTRES)
'SelectObject hdc, CreatePen(PS_SOLID, 2, RGB(255, 0, 0))
'Rectangle hdc, 0, 0, nWidth - 4, nHeight - 2
SetBkMode hdc, TRANSPARENT
Dim As SIZE size
Dim As String t1, t2, t3
t1 = "Title!"
If Page = 1 Then t2 = "This is a print test on page 1!" Else t2 = "This is another print test on page" + _Trim$(Str$(Page)) + "!"
t3 = "Page" + Str$(Page)
HDCPrint hdc, t1, "Castellar", 72, "UNDERLINE", "BLACK", 425, 550, RGB(188, 33, 116)
HDCPrint hdc, t2, "Freestyle Script", 48, "UNDERLINE", "BLACK", 425, 750, RGB(33, 127, 127)
HDCPrint hdc, t3, "Goudy Stout", 24, "", "BLACK", 425, 1100, RGB(127, 55, 127)
End Sub
Function AbortProc%% (hDC As _Offset, Errr As Long)
Const PM_REMOVE = &H0001
Dim As MSG msg
While PeekMessage(_Offset(msg), 0, 0, 0, PM_REMOVE)
TranslateMessage _Offset(msg)
DispatchMessage _Offset(msg)
Wend
AbortProc = -1
End Function
Function GetPrinterDC%& (Pages As _Unsigned Long)
Const PD_RETURNDC = &H100
pdlg.lStructSize = Len(pdlg)
pdlg.Flags = PD_RETURNDC
pdlg.nMinPage = 1
pdlg.nMaxPage = Pages
pdlg.nToPage = Pages
PrintDlg _Offset(pdlg)
GetPrinterDC = pdlg.hDC
End Function
Sub PrintJob ()
Const MB_OK = &H00000000
Const MB_APPLMODAL = &H00000000
Const SP_ERROR = -1
Dim As _Offset hDC
Dim As DOCINFO di
hDC = GetPrinterDC(2)
If hDC = 0 Then
MessageBox 0, "Error creating DC" + Chr$(0), "Error" + Chr$(0), MB_APPLMODAL Or MB_OK
Exit Sub
End If
If SetAbortProc(hDC, pAbortProc) = SP_ERROR Then
MessageBox 0, "Error setting up AbortProc" + Chr$(0), "Error" + Chr$(0), MB_APPLMODAL Or MB_OK
Exit Sub
End If
InitPrintJobDoc di, "MyDoc"
StartDoc hDC, _Offset(di)
Dim As Long i, l
For l = 1 To pdlg.nCopies
For i = 1 To pdlg.nToPage
StartPage hDC
DrawPage hDC, i
EndPage hDC
Next
Next
EndDoc hDC
DeleteDC hDC
End Sub
Sub HDCPrint (hdc As _Offset, text As String, fontName As String * 32, height As Long, style As String, weightStyle As String, x As Long, y As Long, colorref As _Unsigned Long)
Dim As _Offset font
Dim As _Byte bold, underline, strikeout, italic
Dim As Long weight
style = UCase$(style)
If InStr(style, "UNDERLINE") Then underline = -1
If InStr(style, "STRIKEOUT") Then strikeout = -1
If InStr(style, "ITALIC") Then italic = -1
Select Case UCase$(weightStyle)
Case "THIN"
weight = 100
Case "EXTRALIGHT", "ULTRALIGHT"
weight = 200
Case "LIGHT"
weight = 300
Case "NORMAL", "REGULAR"
weight = 400
Case "MEDIUM"
weight = 500
Case "SEMIBOLD", "DEMIBOLD"
weight = 600
Case "BOLD"
weight = 700
Case "EXTRABOLD", "ULTRABOLD"
weight = 800
Case "HEAVY", "BLACK"
weight = 900
Case Else
weight = 0
End Select
Dim As Long FF_DECORATIVE: FF_DECORATIVE = _ShL(5, 4)
Dim As Long FF_MODERN: FF_MODERN = _ShL(3, 4)
Dim As Long FF_ROMAN: FF_ROMAN = _ShL(1, 4)
Dim As Long FF_SCRIPT: FF_SCRIPT = _ShL(4, 4)
Dim As Long FF_SWISS: FF_SWISS = _ShL(2, 4)
Const LOGPIXELSY = 90
Const LOGPIXELSX = 88
Const DT_CALCRECT = &H00000400
Dim As Long DPIScaleY: DPIScaleY = GetDeviceCaps(hdc, LOGPIXELSY) / 96
Dim As Long DPIScaleX: DPIScaleX = GetDeviceCaps(hdc, LOGPIXELSX) / 96
font = CreateFont(height * DPIScaleY, 0, 0, 0, weight, italic, underline, strikeout, 0, 0, 0, 5, FF_DECORATIVE Or FF_MODERN Or FF_ROMAN Or FF_SCRIPT Or FF_SWISS, fontName + Chr$(0))
If font Then
SelectObject hdc, font
SetTextColor hdc, colorref
Dim As SIZE size
GetTextExtentPoint32 hdc, text, Len(text), _Offset(size)
Dim As Long nx, ny
If x > 0 Then nx = (x * DPIScaleX) - size.cx / 2 Else nx = x * DPIScaleX
If y > 0 Then ny = (y * DPIScaleY) - (size.cy) Else ny = y * DPIScaleY
TextOut hdc, nx, ny, _Offset(text), Len(text)
End If
End Sub
I wanted to create an example program for lesson 18 of my tutorial that encompassed everything covered up to that point. What was supposed to be a simple demo ended up becoming an entire game. It's not very polished as I only spent a few days on it but it's good enough for the tutorial.
Use your arrow keys to maneuver the Falcon 9 stage 1 booster to a smooth landing:
UP ARROW - main thrust
RIGHT ARROW - side thrust left
LEFT ARROW - side thrust right
I made a pretty epic intro sequence for it as well that lasts 1:30. After watching it the first time you can simply press a key to skip it each time you run the program.
Simply put the files into your QB64 (or QB64pe) folder and run Falcon9.BAS. The included Falcon9.ZIP file contains everything you need.
I have Square Root worked out better faster and accurate to any decimal places (currently set 100) and conversions Dec2Bin$ strings and Bin2Dec$, still working on Real Number Power$
Dec2Bin$ and Bin2Dec$ don't work like bit math for negative values but like decimal numbers ie a minus sign says it's negative and no sign means it's positive. There is no checking if the test$ binary you enter is just 1's and zero's so don't test that and say it's not working. So to test -8.375 try -1000.011
Code: (Select All)
Option _Explicit
_Title "String Math Powers 2022-09-22" ' b+ try to do powers with string math
' directly from "String Math 2021-06-14" ' b+ from SM2 (2021 June) a bunch of experiments to fix and improve speeds.
' June 2021 fix some old String Math procedures, better nInverse with new LT frunction, remove experimental procedures.
' Now with decent sqrRoot it works independent of Mr$() = Math Regulator that handles signs and decimals and calls to
' add$(), subtr$, mult$, divide$ (100 significant digits), add$(), subtr$, mult$ are exact!
' If you need higher precsion divide, I recommend use nInverse on denominator (integer)
' then add sign and decimal and mult$() that number with numerator to get divsion answer in higher precision than 100.
' (See how Mr$() handles division and just call nInverse$ with what precision you need.)
' The final function showDP$() is for displaying these number to a set amount of Decimal Places.
' The main code is sampler of tests performed with these functions.
' 2022-09-22 a little fix to MR$ for Function change versions QB64 v2.0+
' Attempt to do Powers with SQRs of 2 Multipliers
' needs to be able to convert a number into a binary String
' might also need a Table setup for nested SQR's of 2
' needs a decent BigSQR$ string function for SQR
' 2022-09-25 this is one frustration after another LT does not work for strings??? but < does?
' try some more with BigSQR concentrate on Integer part first, just get that right
' 2022-09-26 Bin2Dec$ Function seems OK
' ============ For comparison this was the old routine
'Print: Print "Square Roots the old way of estimation:"
'For i = 1 To 50
' b$ = Str$(i + 1 / (2 ^ i))
' Print b$, sqrRoot$(b$)
'Next
'intger$ = "10000000000000000000000000000000000000000000000000000000000000000"
'Print: Print "Bonus SQR of "; intger$; " Len = "; Len(intger$); " is:"
'b$ = sqrRoot$(intger$)
'Print b$, " Len Integer Part ="; Len(b$)
'intger$ = "100000000000000000000000000000000000000000000000000000000000000000"
'Print: Print "Bonus SQR of "; intger$; " Len = "; Len(intger$); " is:"
'b$ = sqrRoot$(intger$)
'Print b$, " Len Integer Part ="; Len(Mid$(b$, 1, InStr(b$, ".") - 1))
' ============================================================================
' OK now test the new Power$ routine
'Print power$("5", ".333333333333333333333333333333333") ' 2 ' no this ain't work in well at all
Dim test$, ans$
Do
Input "Enter a Binary with/without - sgn or decimal "; test$
ans$ = Bin2Dec$(test$)
Print "Decimal is: "; ans$
Print "Check conversion back: "; Dec2Bin$(ans$)
Loop Until test$ = ""
' x to the power of pow
Function power$ (xx$, pow$) ' so far this sucks, decimal is lost and digits only good for about 10 places 10% of dp in SQR(2)'s
Dim build$, ip$, fp$, x$, bs$, runningXSQR$
Dim As Long dot, i
x$ = _Trim$(xx$)
dot = InStr(pow$, ".")
If dot Then
ip$ = Mid$(pow$, 1, dot - 1)
fp$ = Mid$(pow$, dot) ' keep dot
Else
ip$ = pow$
fp$ = ""
End If
'integer part or power
build$ = "1"
If ip$ <> "" Then
While LTE("0", ip$)
build$ = mr$(build$, "*", x$)
ip$ = mr$(ip$, "-", "1")
Wend
End If
If fp$ = "" Or fp$ = "." Then power$ = build$: Exit Function
build$ = build$ + "."
'now for the fraction part convert decimal to Binary
bs$ = Dec2Bin$(fp$)
'at moment we haven't taken any sqr of x
runningXSQR$ = mr$(x$, "*", x$)
'run through all the 0's and 1's in the bianry expansion of the fraction part of the power float
For i = 1 To Len(bs$)
'this is the matching sqr of the sqr of the sqr... of x
runningXSQR$ = bigSQR$(runningXSQR$)
'for every 1 in the expansion, multiple our build with the running sqr of ... sqr of x
If Mid$(bs$, i, 1) = "1" Then build$ = mr$(build$, "*", runningXSQR$)
Next
'our build should be a estimate or x to power of pow
power$ = build$
End Function
Function Bin2Dec$ (bn$) ' bn$ is binary string number with possible neg sign and decimal
Dim b$, sgn$, ip$, fp$, p2$, build$
Dim As Long dot, i
b$ = _Trim$(bn$)
If Left$(b$, 1) = "-" Then sgn$ = "-": b$ = Mid$(b$, 2) Else sgn$ = ""
dot = InStr(b$, ".")
If dot Then
ip$ = Mid$(b$, 1, dot - 1)
fp$ = Mid$(b$, dot + 1)
Else
ip$ = b$
fp$ = ""
End If
p2$ = "1"
For i = Len(ip$) To 1 Step -1
If Mid$(ip$, i, 1) = "1" Then build$ = mr$(build$, "+", p2$)
p2$ = mr$(p2$, "*", "2")
Next
If fp$ <> "" Then
build$ = build$ + "."
p2$ = "1"
For i = 1 To Len(fp$)
p2$ = mr$(p2$, "/", "2")
If Mid$(fp$, i, 1) = "1" Then build$ = mr$(build$, "+", p2$)
Next
End If
Bin2Dec$ = sgn$ + build$
End Function
Function bigSQR$ (number$)
Dim ip$, fp$, n$, calc$, remainder$, new$, test$
Dim As Long dot, dp, i, pulldown, cal, digit, maxDec
maxDec = 100
' divide number into integer part, ip$ and fraction part, fp$ , figure decimal places to left of decimal then even up front and back
dot = InStr(number$, ".")
If dot Then
ip$ = _Trim$(Mid$(number$, 1, dot - 1))
fp$ = Left$(_Trim$(Mid$(number$, dot + 1)) + String$(2 * maxDec, "0"), 2 * maxDec)
Else
ip$ = _Trim$(number$)
If Len(ip$) Mod 2 = 1 Then ip$ = "0" + ip$
fp$ = String$(2 * maxDec, "0")
End If
dp = Int((Len(ip$) + 1) / 2)
If Len(ip$) Mod 2 = 1 Then ip$ = "0" + ip$
n$ = ip$ + fp$
For i = 1 To Len(n$) Step 2
pulldown = Val(Mid$(n$, i, 2))
If i = 1 Then
cal = Int(Sqr(pulldown))
remainder$ = _Trim$(Str$(pulldown - cal * cal))
calc$ = _Trim$(Str$(cal))
Else
new$ = mr$("100", "*", remainder$)
new$ = mr$(new$, "+", _Trim$(Str$(pulldown)))
For digit = 9 To 0 Step -1
'test$ = (20 * Val(calc$) + digit) * digit
test$ = mr$("20", "*", calc$)
test$ = mr$(test$, "+", _Trim$(Str$(digit)))
test$ = mr$(test$, "*", _Trim$(Str$(digit)))
If LTE(test$, new$) Then Exit For
Next
calc$ = calc$ + _Trim$(Str$(digit))
remainder$ = mr$(new$, "-", test$)
End If
Next
If dp Then
calc$ = Mid$(calc$, 1, dp) + "." + Mid$(calc$, dp + 1)
Else
calc$ = "." + calc$
End If
bigSQR$ = calc$
End Function
' New stuff
Function Dec2Bin$ (Dec$)
Dim sgn$, d$, ip$, fp$, b$, tp$
Dim As Long dot, c
If _Trim$(Left$(Dec$, 1)) = "-" Then
sgn$ = "-": d$ = Mid$(_Trim$(Dec$), 2)
Else
sgn$ = "": d$ = _Trim$(Dec$)
End If
dot = InStr(d$, ".")
If dot Then
ip$ = Mid$(d$, 1, dot - 1): fp$ = Mid$(d$, dot)
Else ' all integer
ip$ = d$: fp$ = "."
End If
tp$ = "2"
If LTE(tp$, ip$) Then
While LTE(tp$, ip$)
tp$ = mr$(tp$, "*", "2")
Wend
End If
While LT("1", tp$)
tp$ = mr$(tp$, "/", "2")
If LTE(tp$, "1") Then b$ = b$ + ip$: Exit While
If LT(ip$, tp$) Then
b$ = b$ + "0"
Else
b$ = b$ + "1"
ip$ = mr$(ip$, "-", tp$)
End If
Wend
b$ = b$ + "." ' cross over point to fractions
tp$ = "1"
'Print "start fp$ "; fp$
While c < 200 'And LT("0", fp$)
tp$ = mr$(tp$, "/", "2")
'If LT(fp$, tp$) Then ' for some reason LT is not working but < is
If fp$ < tp$ Then ' for some reason LT is not working but < is
b$ = b$ + "0"
Else
b$ = b$ + "1"
fp$ = mr$(fp$, "-", tp$)
If LTE(fp$, "0") Then Exit While
End If
c = c + 1
Wend
Dec2Bin$ = sgn$ + b$ ' b$ = build of 0,1 and .
End Function
' 2022-09-25 Use BigSQR$ it's way faster, no estimating!
' == String Math 2021-06-14 Procedure start here (aprox 412 LOC for copy/paste into your app) ==
Function sqrRoot$ (nmbr$)
Dim n$, guess$, lastGuess$, other$, sum$, imaginary$, loopcnt
If Left$(nmbr$, 1) = "-" Then 'handle neg numbers
imaginary$ = "*i": n$ = Mid$(nmbr$, 2)
Else
imaginary$ = "": n$ = nmbr$
End If
guess$ = mr$(n$, "/", "2")
other$ = n$
Do
loopcnt = loopcnt + 1
If (Mid$(guess$, 1, 105) = Mid$(lastGuess$, 1, 105)) Then
' go past 100 matching digits for 100 digit precision
sqrRoot$ = Mid$(other$, 1, 101) + imaginary$
' try other factor for guess$ sometimes it nails answer without all digits
Exit Function
Else
lastGuess$ = guess$
sum$ = mr$(guess$, "+", other$)
guess$ = mr$(sum$, "/", "2")
other$ = mr$(n$, "/", guess$)
End If
Loop
End Function
Function add$ (a$, b$) 'add 2 positive integers assume a and b are just numbers no - signs
'set a and b numbers to same length and multiple of 18 so can take 18 digits at a time
Dim As Long la, lb, m, g
Dim sa As _Unsigned _Integer64, sb As _Unsigned _Integer64, co As _Unsigned _Integer64
Dim fa$, fb$, t$, new$, result$
la = Len(a$): lb = Len(b$)
If la > lb Then m = Int(la / 18) + 1 Else m = Int(lb / 18) + 1
fa$ = Right$(String$(m * 18, "0") + a$, m * 18)
fb$ = Right$(String$(m * 18, "0") + b$, m * 18)
'now taking 18 digits at a time Thanks Steve McNeill
For g = 1 To m
sa = Val(Mid$(fa$, (m - g) * 18 + 1, 18))
sb = Val(Mid$(fb$, (m - g) * 18 + 1, 18))
t$ = Right$(String$(36, "0") + _Trim$(Str$(sa + sb + co)), 36)
co = Val(Mid$(t$, 1, 18))
new$ = Mid$(t$, 19)
result$ = new$ + result$
Next
If co Then result$ = Str$(co) + result$
add$ = result$
End Function
' This is used in nInverse$ not by Mr$ because there it saves time!
Function subtr1$ (a$, b$)
Dim As Long la, lb, lResult, i, ca, cb, w
Dim result$, fa$, fb$
la = Len(a$): lb = Len(b$)
If la > lb Then lResult = la Else lResult = lb
result$ = Space$(lResult)
fa$ = result$: fb$ = result$
Mid$(fa$, lResult - la + 1) = a$
Mid$(fb$, lResult - lb + 1) = b$
For i = lResult To 1 Step -1
ca = Val(Mid$(fa$, i, 1))
cb = Val(Mid$(fb$, i, 1))
If cb > ca Then ' borrow 10
Mid$(result$, i, 1) = Right$(Str$(10 + ca - cb), 1)
w = i - 1
While w > 0 And Mid$(fa$, w, 1) = "0"
Mid$(fa$, w, 1) = "9"
w = w - 1
Wend
Mid$(fa$, w, 1) = Right$(Str$(Val(Mid$(fa$, w, 1)) - 1), 1)
Else
Mid$(result$, i, 1) = Right$(Str$(ca - cb), 1)
End If
Next
subtr1$ = result$
End Function
' 2021-06-08 fix up with new mr call that decides the sign and puts the greater number first
Function subtr$ (sum$, minus$) ' assume both numbers are positive all digits
Dim As Long m, g, p
Dim VB As _Unsigned _Integer64, vs As _Unsigned _Integer64, tenE18 As _Unsigned _Integer64
Dim ts$, tm$, sign$, LG$, sm$, t$, result$
ts$ = _Trim$(sum$): tm$ = _Trim$(minus$) ' fixed subtr$ 2021-06-05
If trim0(ts$) = trim0$(tm$) Then subtr$ = "0": Exit Function 'proceed knowing not equal
tenE18 = 1000000000000000000 'yes!!! no dang E's
sign$ = ""
m = Int(Len(ts$) / 18) + 1
LG$ = Right$(String$(m * 18, "0") + ts$, m * 18)
sm$ = Right$(String$(m * 18, "0") + tm$, m * 18)
'now taking 18 digits at a time From Steve I learned we can do more than 1 digit at a time
For g = 1 To m
VB = Val(Mid$(LG$, m * 18 - g * 18 + 1, 18))
vs = Val(Mid$(sm$, m * 18 - g * 18 + 1, 18))
If vs > VB Then
t$ = Right$(String$(18, "0") + _Trim$(Str$(tenE18 - vs + VB)), 18)
p = (m - g) * 18
While p > 0 And Mid$(LG$, p, 1) = "0"
Mid$(LG$, p, 1) = "9"
p = p - 1
Wend
If p > 0 Then Mid$(LG$, p, 1) = _Trim$(Str$(Val(Mid$(LG$, p, 1)) - 1))
Else
t$ = Right$(String$(18, "0") + _Trim$(Str$(VB - vs)), 18)
End If
result$ = t$ + result$
Next
subtr$ = result$
End Function
Function TrimLead0$ (s$) 'for treating strings as number (pos integers)
Dim copys$
Dim As Long i, find
copys$ = _Trim$(s$) 'might as well remove spaces too
i = 1: find = 0
While i < Len(copys$) And Mid$(copys$, i, 1) = "0"
i = i + 1: find = 1
Wend
If find = 1 Then copys$ = Mid$(copys$, i)
If copys$ = "" Then TrimLead0$ = "0" Else TrimLead0$ = copys$
End Function
' catchy? mr$ for math regulator cop$ = " + - * / " 1 of 4 basic arithmetics
' Fixed so that add and subtract have signs calc'd in Mr and correct call to add or subtract made
' with bigger minus smaller in subtr$() call
Function mr$ (a$, cop$, b$)
Dim op$, ca$, cb$, aSgn$, bSgn$, postOp$, sgn$, rtn$
Dim As Long adp, bdp, dp, lpop, aLTb
op$ = _Trim$(cop$) 'save fixing each time
ca$ = _Trim$(a$): cb$ = _Trim$(b$) 'make copies in case we change
'strip signs and decimals
If Left$(ca$, 1) = "-" Then
aSgn$ = "-": ca$ = Mid$(ca$, 2)
Else
aSgn$ = ""
End If
dp = InStr(ca$, ".")
If dp > 0 Then
adp = Len(ca$) - dp
ca$ = Mid$(ca$, 1, dp - 1) + Mid$(ca$, dp + 1)
Else
adp = 0
End If
If Left$(cb$, 1) = "-" Then
bSgn$ = "-": cb$ = Mid$(cb$, 2)
Else
bSgn$ = ""
End If
dp = InStr(cb$, ".")
If dp > 0 Then
bdp = Len(cb$) - dp
cb$ = Mid$(cb$, 1, dp - 1) + Mid$(cb$, dp + 1)
Else
bdp = 0
End If
If op$ = "+" Or op$ = "-" Or op$ = "/" Then 'add or subtr even up strings on right of decimal
'even up the right sides of decimals if any
If adp > bdp Then dp = adp Else dp = bdp
If adp < dp Then ca$ = ca$ + String$(dp - adp, "0")
If bdp < dp Then cb$ = cb$ + String$(dp - bdp, "0")
ElseIf op$ = "*" Then
dp = adp + bdp
End If
If op$ = "*" Or op$ = "/" Then
If aSgn$ = bSgn$ Then sgn$ = "" Else sgn$ = "-"
End If
'now according to signs and op$ call add$ or subtr$
If op$ = "-" Then ' make it adding according to signs because that is done for + next!
If bSgn$ = "-" Then bSgn$ = "" Else bSgn$ = "-" ' flip bSgn$ with op$
op$ = "+" ' turn this over to + op already done! below
End If
If op$ = "+" Then
If aSgn$ = bSgn$ Then 'really add
postOp$ = add$(ca$, cb$)
sgn$ = aSgn$
ElseIf aSgn$ <> bSgn$ Then 'have a case of subtraction
'but which is first and which is 2nd and should final sign be pos or neg
If TrimLead0$(ca$) = TrimLead0(cb$) Then 'remove case a = b
mr$ = "0": Exit Function
Else
aLTb = LTE(ca$, cb$)
If aSgn$ = "-" Then
If aLTb Then ' b - a = pos
postOp$ = subtr$(cb$, ca$)
sgn$ = ""
Else ' a > b so a - sgn wins - (a - b)
postOp$ = subtr$(ca$, cb$)
sgn$ = "-"
End If
Else ' b has the - sgn
If aLTb Then ' result is -
postOp$ = subtr$(cb$, ca$)
sgn$ = "-"
Else ' result is pos
postOp$ = subtr$(ca$, cb$)
sgn$ = ""
End If
End If
End If
End If
ElseIf op$ = "*" Then
postOp$ = mult$(ca$, cb$)
ElseIf op$ = "/" Then
postOp$ = divide$(ca$, cb$)
End If ' which op
If op$ <> "/" Then 'put dp back
lpop = Len(postOp$) ' put decimal back if there is non zero stuff following it
If Len(Mid$(postOp$, lpop - dp + 1)) Then ' fix 1 extra dot appearing in 10000! ?!
If TrimLead0$(Mid$(postOp$, lpop - dp + 1)) <> "0" Then ' .0 or .00 or .000 ??
postOp$ = Mid$(postOp$, 1, lpop - dp) + "." + Mid$(postOp$, lpop - dp + 1)
End If
End If
End If
rtn$ = trim0$(postOp$) 'trim lead 0's then tack on sign
If rtn$ <> "0" Then mr$ = sgn$ + rtn$ Else mr$ = rtn$
End Function
Function divide$ (n$, d$) ' goal here is 100 digits precision not 100 digits past decimal
Dim di$, ndi$
Dim As Long nD
If n$ = "0" Then divide$ = "0": Exit Function
If d$ = "0" Then divide$ = "div 0": Exit Function
If d$ = "1" Then divide$ = n$: Exit Function
' aha! found a bug when d$ gets really huge 100 is no where near enough!!!!
' 2021-06-03 fix by adding 100 to len(d$), plus have to go a little past 100 like 200
di$ = Mid$(nInverse$(d$, Len(d$) + 200), 2) 'chop off decimal point after
nD = Len(di$)
ndi$ = mult$(n$, di$)
ndi$ = Mid$(ndi$, 1, Len(ndi$) - nD) + "." + Right$(String$(nD, "0") + Right$(ndi$, nD), nD)
divide$ = ndi$
End Function
' This uses Subtr1$ is Positive Integer only!
' DP = Decimal places = says when to quit if don't find perfect divisor before
Function nInverse$ (n$, DP As Long) 'assume decimal at very start of the string of digits returned
Dim m$(1 To 9), si$, r$, outstr$, d$
Dim i As Long
For i = 1 To 9
si$ = _Trim$(Str$(i))
m$(i) = mult$(si$, n$)
Next
outstr$ = ""
If n$ = "0" Then nInverse$ = "Div 0": Exit Function
If n$ = "1" Then nInverse$ = "1": Exit Function
outstr$ = "." 'everything else n > 1 is decimal 8/17
r$ = "10"
Do
While LT(r$, n$) ' 2021-06-08 this should be strictly Less Than
outstr$ = outstr$ + "0" ' add 0 to the output string
If Len(outstr$) = DP + 1 Then nInverse$ = outstr$: Exit Function 'DP length?
r$ = r$ + "0"
Wend
For i = 9 To 1 Step -1
If LTE(m$(i), r$) Then d$ = _Trim$(Str$(i)): Exit For
Next
outstr$ = outstr$ + d$
If Len(outstr$) = DP + 1 Then nInverse$ = outstr$: Exit Function
r$ = subtr1$(r$, mult$(d$, n$)) 'r = r -d*n ' 2021-06-08 subtr1 works faster
If TrimLead0$(r$) = "0" Then nInverse$ = outstr$: Exit Function ' add trimlead0$ 6/08
r$ = r$ + "0" 'add another place
Loop
End Function
Function mult$ (a$, b$) 'assume both positive integers prechecked as all digits strings
Dim As Long la, lb, m, g, dp
Dim As _Unsigned _Integer64 v18, sd, co
Dim f18$, f1$, t$, build$, accum$
If a$ = "0" Then mult$ = "0": Exit Function
If b$ = "0" Then mult$ = "0": Exit Function
If a$ = "1" Then mult$ = b$: Exit Function
If b$ = "1" Then mult$ = a$: Exit Function
'find the longer number and make it a mult of 18 to take 18 digits at a time from it
la = Len(a$): lb = Len(b$)
If la > lb Then
m = Int(la / 18) + 1
f18$ = Right$(String$(m * 18, "0") + a$, m * 18)
f1$ = b$
Else
m = Int(lb / 18) + 1
f18$ = Right$(String$(m * 18, "0") + b$, m * 18)
f1$ = a$
End If
For dp = Len(f1$) To 1 Step -1 'dp = digit position of the f1$
build$ = "" 'line builder
co = 0
'now taking 18 digits at a time Thanks Steve McNeill
For g = 1 To m
v18 = Val(Mid$(f18$, (m - g) * 18 + 1, 18))
sd = Val(Mid$(f1$, dp, 1))
t$ = Right$(String$(19, "0") + _Trim$(Str$(v18 * sd + co)), 19)
co = Val(Mid$(t$, 1, 1))
build$ = Mid$(t$, 2) + build$
Next g
If co Then build$ = _Trim$(Str$(co)) + build$
If dp = Len(f1$) Then
accum$ = build$
Else
accum$ = add$(accum$, build$ + String$(Len(f1$) - dp, "0"))
End If
Next dp
mult$ = accum$
End Function
'this function needs TrimLead0$(s$) ' dang I can't remember if a$ and b$ can have decimals or not
Function LTE (a$, b$) ' a$ Less Than or Equal b$ comparison of 2 strings
Dim ca$, cb$
Dim As Long la, lb, i
ca$ = TrimLead0$(a$): cb$ = TrimLead0(b$)
la = Len(ca$): lb = Len(cb$)
If ca$ = cb$ Then
LTE = -1
ElseIf la < lb Then ' a is smaller
LTE = -1
ElseIf la > lb Then ' a is bigger
LTE = 0
ElseIf la = lb Then ' equal lengths
For i = 1 To Len(ca$)
If Val(Mid$(ca$, i, 1)) > Val(Mid$(cb$, i, 1)) Then
LTE = 0: Exit Function
ElseIf Val(Mid$(ca$, i, 1)) < Val(Mid$(cb$, i, 1)) Then
LTE = -1: Exit Function
End If
Next
End If
End Function
'need this for ninverse faster than subtr$ for sign
Function LT (a$, b$) ' a$ Less Than or Equal b$ comparison of 2 strings
Dim ca$, cb$
Dim As Long la, lb, i
ca$ = TrimLead0$(a$): cb$ = TrimLead0(b$)
la = Len(ca$): lb = Len(cb$)
If la < lb Then ' a is smaller
LT = -1
ElseIf la > lb Then ' a is bigger
LT = 0
ElseIf la = lb Then ' equal lengths
For i = 1 To Len(ca$)
If Val(Mid$(ca$, i, 1)) > Val(Mid$(cb$, i, 1)) Then
LT = 0: Exit Function
ElseIf Val(Mid$(ca$, i, 1)) < Val(Mid$(cb$, i, 1)) Then
LT = -1: Exit Function
End If
Next
End If
End Function
Function TrimTail0$ (s$)
Dim copys$
Dim As Long dp, i, find
copys$ = _Trim$(s$) 'might as well remove spaces too
TrimTail0$ = copys$
dp = InStr(copys$, ".")
If dp > 0 Then
i = Len(copys$): find = 0
While i > dp And Mid$(copys$, i, 1) = "0"
i = i - 1: find = 1
Wend
If find = 1 Then
If i = dp Then
TrimTail0$ = Mid$(copys$, 1, dp - 1)
Else
TrimTail0$ = Mid$(copys$, 1, i)
End If
End If
End If
End Function
Function trim0$ (s$)
Dim cs$, si$
cs$ = s$
si$ = Left$(cs$, 1)
If si$ = "-" Then cs$ = Mid$(cs$, 2)
cs$ = TrimLead0$(cs$)
cs$ = TrimTail0$(cs$)
If Right$(cs$, 1) = "." Then cs$ = Mid$(cs$, 1, Len(cs$) - 1)
If si$ = "-" Then trim0$ = si$ + cs$ Else trim0$ = cs$
End Function
' for displaying truncated numbers say to 60 digits
Function showDP$ (num$, nDP As Long)
Dim cNum$
Dim As Long dp, d, i
cNum$ = num$ 'since num$ could get changed
showDP$ = num$
dp = InStr(num$, ".")
If dp > 0 Then
If Len(Mid$(cNum$, dp + 1)) > nDP Then
d = Val(Mid$(cNum$, dp + nDP + 1, 1))
If d > 4 Then
cNum$ = "0" + cNum$ ' tack on another 0 just in case 9's all the way to left
dp = dp + 1
i = dp + nDP
While Mid$(cNum$, i, 1) = "9" Or Mid$(cNum$, i, 1) = "."
If Mid$(cNum$, i, 1) = "9" Then
Mid$(cNum$, i, 1) = "0"
End If
i = i - 1
Wend
Mid$(cNum$, i, 1) = _Trim$(Str$(Val(Mid$(cNum$, i, 1)) + 1)) 'last non 9 digit
cNum$ = Mid$(cNum$, 1, dp + nDP) 'chop it
showDP$ = trim0$(cNum$)
Else
showDP$ = Mid$(cNum$, 1, dp + nDP)
End If
End If
End If
End Function
Wandering In The Cave
A simple cave escape game. Navigate to the exit to escape and win. Watch out for lava, exposure, and toxic slime.
EDIT added functionality to game, see latest post.
Code: (Select All)
'wandering in the cave
'By James D. Jarvis sept 26,2022
_Title "Wandering In The Cave v0.4"
'use the number keys of W,S,A,D to find the exit
'press 5 or . to rest briefly
'
' this is a work in progress and may generate an impossible starting position
'
_Define K As _UNSIGNED LONG
Dim Shared kk, kblack, kfloor, krock, kwater, kslime, klava, krubble, kcrystal, kexit
Dim Shared cave(24, 6), caverunlimit, lightradius
Dim Shared phealth, pstamina, pwounds, ptemp, ppx, ppy, lastx, lasty
Dim cmap As _Unsigned Long
Dim ms As _Unsigned Long
cmap = _NewImage(800, 800, 32)
ms = _NewImage(800, 500, 32)
Screen ms
Print "Wandering In The Cave v0.4"
Print "By James D. Jarvis"
Print
Print "You must escape the cave."
Print
Print "Navigate with the numberpad or WASD"
Print "press any key to start and get a preview of the cave map"
Print "press spacebar after that to start your wandering."
any$ = Input$(1)
Screen cmap
_FullScreen _SquarePixels
Const csx = 1, csy = 2, ctx = 3, cty = 4, cmx = 5, cmy = 6
kfloor = _RGB32(200, 180, 160): kwater = _RGB32(10, 30, 240)
krock = _RGB32(40, 30, 20): kslime = _RGB32(20, 240, 100): klava = _RGB32(200, 5, 5)
krubble = _RGB32(80, 80, 80): kcrystal = _RGB32(250, 250, 0): kexit = _RGB32(255, 0, 255)
Randomize Timer
check$ = "off"
caverunlimit = 500
Do
_Limit 10
restartcaves:
Line (0, 0)-(_Width, _Height), krock, BF
cave(1, csx) = Int(100 + Rnd * 600)
cave(1, csy) = Int(100 + Rnd * 600)
Do
cave(1, ctx) = Int(100 + Rnd * 600)
cave(1, cty) = Int(100 + Rnd * 600)
dx = Abs(cave(1, csx) - cave(1, ctx))
dy = Abs(cave(1, csy) - cave(1, cty))
dl = Sqr(dx * dx + dy * dy)
Loop Until dy > 20 And dx > 20
Case 6, 7, 8
cave(c, csx) = cave(c - 1, ctx)
cave(c, csy) = cave(c - 1, cty)
End Select
cpl = 0
Do
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
cave(c, ctx) = Int(100 + Rnd * 600)
cave(c, cty) = Int(100 + Rnd * 600)
Case 4, 5, 6
If cave(c, csx) <= 400 Then
cave(c, ctx) = cave(c, csx) + Int(50 + Rnd * 200)
Else
cave(c, ctx) = cave(c, csx) - Int(50 + Rnd * 200)
End If
If cave(c, csy) <= 400 Then
cave(c, cty) = cave(c, csy) + Int(50 + Rnd * 200)
Else
cave(c, cty) = cave(c, csy) - Int(50 + Rnd * 200)
End If
End Select
dx = Abs(cave(c, csx) - cave(c, ctx))
dy = Abs(cave(c, csy) - cave(c, cty))
dl = Sqr(dx * dx + dy * dy)
cpl = cpl + 1
If cave(c, ctx) < 50 Then GoTo restartcaves
If cpl > caverunlimit Then GoTo restartcaves
Loop Until dy > 20 And dx > 20
cave(c, cmx) = Int((cave(c, csx) + cave(c, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
cave(c, cmy) = Int((cave(c, csy) + cave(c, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
' Print cave(c, csx), cave(c, csy), cave(c, ctx), cave(c, cty), dl
Next c
For c = 1 To 24
r = (1 + (1 + Rnd * 6) + (1 + Rnd * 6)) / 2
xx = cave(c, csx)
yy = cave(c, csy)
xtrend = 0: ytrend = 0
If xx < cave(c, cmx) Then xtrend = 3
If xx > cave(c, cmx) Then xtrend = -3
If yy < cave(c, cmy) Then ytrend = 3
If yy > cave(c, cmy) Then ytrend = -3
cpl = 0
Do
nx = xx + xtrend + xtrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
ny = yy + ytrend + ytrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
dx = Abs(cave(c, cmx) - nx)
dy = Abs(cave(c, cmy) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < (r * 10) Then
nx = cave(c, cmx)
ny = ny + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
If dy < (r * 10) Then
ny = cave(c, cmy)
nx = nx + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
bumpyline xx, yy, nx, ny, r, kfloor
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartcaves
If cave(c, cmx) < 50 Then GoTo restartcaves
Loop Until xx = cave(c, cmx) And yy = cave(c, cmy)
Next
For c = 1 To 24
xx = cave(c, cmx)
yy = cave(c, cmy)
xtrend = 0: ytrend = 0
If xx < cave(c, ctx) Then xtrend = 2
If xx > cave(c, ctx) Then xtrend = -2
If yy < cave(c, cty) Then ytrend = 2
If yy > cave(c, cty) Then ytrend = -2
cpl = 0
Do
nx = xx + xtrend + xtrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
ny = yy + ytrend + ytrend * Int(Rnd * (r * 2)) - Int(Rnd * (r * 2))
dx = Abs(cave(c, ctx) - nx)
dy = Abs(cave(c, cty) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < r * 7 Then
nx = cave(c, ctx)
ny = ny + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
If dy < r * 7 Then
ny = cave(c, cty)
nx = nx + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
bumpyline xx, yy, nx, ny, r, kfloor
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartcaves
If cave(c, ctx) < 50 Then GoTo restartcaves
Loop Until xx = cave(c, ctx) And yy = cave(c, cty)
Next
For c = 1 To 24
If Rnd * 6 < 3.5 Then
reps = Int(2 + Rnd * 3)
For e = 1 To reps
If Rnd * 10 < 8.5 Then bumpypoly cave(c, csx), cave(c, csy), Int(5 + Int(Rnd * (5 * e))), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
If Rnd * 10 < 8.5 Then bumpypoly cave(c, ctx), cave(c, cty), Int(5 + Int(Rnd * (5 * e))), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
Next
End If
Next c
'streams
ns = Int(1 + Rnd * 12)
If ns < 9 Then addstreams ns, kwater
'lava flows
nf = Int(1 + Rnd * 12)
If nf < 5 Then addstreams nf, klava
'slime flows
nf = Int(1 + Rnd * 30)
If nf < 9 Then addstreams nf, kslime
'add rubble
For yy = 1 To 799
For xx = 1 To 799
If Int(1 + Rnd * 10) < 4 Then
For gx = -1 To 1
For gy = -1 To 1
If Point(xx, yy) = kfloor And Point(xx + gx, yy + gy) = krock Then PSet (xx, yy), krubble
If Point(xx, yy) = klava And Point(xx + gx, yy + gy) = krock Then
Select Case Int(1 + Rnd * 100)
Case 1
PSet (xx + gx, yy + gy), kcrystal
Case 2, 3, 4, 5, 6, 7, 8, 9, 10
PSet (xx + gx, yy + gy), krubble
Case 11, 12, 13
PSet (xx + gx, yy + gy), kfloor
End Select
End If
If Point(xx, yy) = klava And Point(xx + gx, yy + gy) = kwater Then
Select Case Int(1 + Rnd * 300)
Case 1
PSet (xx + gx, yy + gy), kcrystal
Case 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25
PSet (xx + gx, yy + gy), krubble
Case 26, 27, 28, 29, 30, 31, 32, 33
PSet (xx + gx, yy + gy), kfloor
End Select
End If
Next
Next
End If
If Int(1 + Rnd * 1000) < 6 Then
If Point(xx, yy) = kfloor Then
PSet (xx, yy), krubble
For gx = -1 To 1
For gy = -1 To 1
If Int(1 + Rnd * 10) < 3 Then
PSet (xx, yy), krubble
End If
Next
Next
End If
End If
Next
Next
For puddles = 1 To 20
pl = Int(1 + Rnd * 6)
cc = Int(1 + Rnd * 24)
Select Case pl
Case 1
addwater cave(cc, csx), cave(cc, csy), 2
Case 2
addwater cave(cc, cmx), cave(cc, cmy), 1
Case 3
addwater cave(cc, ctx), cave(cc, cty), 2
Case 4, 5, 6
addwater 0, 0, 3
End Select
Next
For slimedrops = 1 To 16
pl = Int(1 + Rnd * 7)
cc = Int(1 + Rnd * 24)
Select Case pl
Case 1
addslime cave(cc, csx), cave(cc, csy), 1
Case 2
addslime cave(cc, cmx), cave(cc, cmy), 1
Case 3
addslime cave(cc, ctx), cave(cc, cty), 1
Case 4, 5, 6, 7
addslime 0, 0, 1.5
End Select
Next
For lavapools = 1 To 12
pl = Int(1 + Rnd * 8)
cc = Int(3 + Rnd * 22)
Select Case pl
Case 1, 2, 3
addlava cave(cc, csx), cave(cc, csy), 3
Case 4
addlava cave(cc, cmx), cave(cc, cmy), 1
Case 5, 6, 7
addlava cave(cc, ctx), cave(cc, cty), 2
Case 8
addlava 0, 0, 2
End Select
Next
If check$ = "on" Then
For c = 1 To 24
Line (cave(c, csx), cave(c, csy))-(cave(c, cmx), cave(c, cmy)), _RGB32(250, 250, 250)
Line (cave(c, cmx), cave(c, cmy))-(cave(c, ctx), cave(c, cty)), _RGB32(250, 250, 250)
_PrintString (cave(c, cmx), cave(c, cmy)), _Trim$(Str$(c))
Next c
End If
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
' Cls
Loop Until kk$ = " "
kk$ = ""
'turn based cave exploration
Screen ms
Cls
_Source cmap
_Dest ms
ppx = cave(1, csx): ppy = cave(1, csy)
lightradius = 9: pstamina = 100: phealth = 100: pwounds = 0: ptemp = 98
_PrintMode _KeepBackground
View Print 25 To 30
Do
'draw location
rsqrd = lightradius * lightradius
y = -lightradius
While y <= lightradius
x = Int(Sqr(rsqrd - y * y))
For x2 = ppx - x To ppx + x
vx = x2 - ppx + 12
kk = Point(x2, ppy + y)
Line (vx * 8, (y + 12) * 16)-(vx * 8 + 7, (y + 12) * 16 + 15), kk, BF
Next
y = y + 1
Wend
Line (598, 18)-(795, 124), krock, BF
_PrintString ((12) * 8, (12) * 16), "@"
o$ = "Stamina " + Str$(pstamina)
_PrintString (600, 20), o$
o$ = "Health " + Str$(phealth)
_PrintString (600, 40), o$
o$ = "Wounds " + Str$(pwounds)
_PrintString (600, 60), o$
o$ = "Temperature " + Str$(ptemp)
_PrintString (600, 80), o$
edd = Int(Sqr((ppx - exitX) * (ppx - exitX) + (ppy - exitY) * (ppy - exitY)))
o$ = "Distance to Exit " + Str$(edd)
_PrintString (600, 100), o$
Print "Turn", turn
Do
_Limit 60
kk$ = InKey$
Loop Until kk$ <> ""
turn = turn + 1
lastx = ppx
lasty = ppy
Select Case kk$
Case "w", "8"
If pstamina > 0 And Point(ppx, ppy - 1) <> krock Then ppy = ppy - 1
Case "s", "2"
If pstamina > 0 And Point(ppx, ppy + 1) <> krock Then ppy = ppy + 1
Case "a", "4"
If pstamina > 0 And Point(ppx - 1, ppy) <> krock Then ppx = ppx - 1
Case "d", "6"
If pstamina > 0 And Point(ppx + 1, ppy) <> krock Then ppx = ppx + 1
Case "7"
If pstamina > 0 And Point(ppx - 1, ppy - 1) <> krock Then
ppy = ppy - 1
ppx = ppx - 1
End If
Case "9"
If pstamina > 0 And Point(ppx + 1, ppy - 1) <> krock Then
ppy = ppy - 1
ppx = ppx + 1
End If
Case "1"
If pstamina > 0 And Point(ppx - 1, ppy + 1) <> krock Then
ppy = ppy + 1
ppx = ppx - 1
End If
Case "3"
If pstamina > 0 And Point(ppx + 1, ppy + 1) <> krock Then
ppy = ppy + 1
ppx = ppx + 1
End If
Case "5", "."
If Int(1 + Rnd * 50) < phealth And pstamina < 100 Then pstamina = pstamina + 1 + Int(Rnd * (phealth / 25))
End Select
If Point(ppx, ppy) = krubble Then pwounds = pwounds + checkrubble(ppx, ppy)
If Int(1 + Rnd * 80 + pwounds) > phealth Then pstamina = pstamina - 1
If Point(ppx, ppy) = kslime Then
Print "The slime is nauseating...";
If Int(Rnd * 120) > phealth Then phealth = phealth - Int(Rnd * 4)
If Int(Rnd * 120) > phealth Then
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
Print " it's making you itch."
Case 4, 5, 6
Print " it's feel's like it is burning you."
wounds = wounds + Abs(Int(Rnd * 2 - Rnd * 2))
End Select
End If
End If
If Point(ppx, ppy) = kwater Then ptemp = ptemp - Int(Abs(Rnd * 2 - Rnd * 2))
If Point(ppx, ppy) = klava Then
ptemp = ptemp + 100
dmg = 10 + Int(Rnd * 20)
pwounds = pwounds + dmg
Print "YOU ARE STANDING IN LAVA !!!"
Print "....suffering "; dmg; " points of damage !"
End If
If ptemp < 0 Then
Print "You are dangerously COLD .... brrrrr"
pstamina = pstamina - Int(Rnd * 2)
If Int(1 + Rnd * (50 + Abs(ptemp))) > pstamina Then
pwounds = pwounds + Int(1 + Rnd * 2)
phealth = phealth - Int(Rnd * 2)
End If
End If
tcheck = ptemp + Rnd * 10
If tcheck > 108 Then
pstamina = pstamina - 1
Print "You are dangerously warm!"
If Int(1 + Rnd * ptemp) > pstamina Then
pwounds = pwounds + 1
phealth = phealth - Int(Rnd * 2)
End If
End If
If Point(ppx, ppy) = kfloor Then
If ptemp < 98 Then ptemp = ptemp + 1
If ptemp > 98 Then ptemp = Int((ptemp + 98) / 2)
End If
If pstamina < 20 Then
Print "You are ";
If pstamina < 1 Then
Print "exhausted."
Else
Print "fatigued."
End If
End If
If wounds > phealth Then
Print "You are in intense pain !"
pstamina = pstamina = Int(Rnd * 2)
End If
If Point(ppx, ppy) = kexit Then
Print
Print "YOU HAVE FOUND THE EXIT"
Print
Print "it took you "; turns; " turns after starting ", start_X, " spaces away from the exit."
Print
kk$ = Chr$(27)
End If
If phealth < 1 Or pwounds > 99 Then
Print "YOU HAVE PERISHED DUE TO YOUR POOR CONDITION."
Print
Print "(press any key to continue)"
any$ = Input$(1)
kk$ = Chr$(27)
End If
Loop Until kk$ = Chr$(27)
Print "GAME OVER"
Print "play again?"
Print "Y or N?"
Do
ask$ = Input$(1)
ask$ = UCase$(ask$)
Loop Until ask$ = "Y" Or ask$ = "N"
If ask$ = "Y" Then
Screen cmap
GoTo restartcaves
End If
System
Function checkrubble (xx, yy)
stumblecheck = Int(1 + Rnd * 120)
dmg = 0
If stumblecheck > health Then
Print "whooops.... you stumbled on the rubble...";
Select Case Int(1 + Rnd * 20)
Case 1
If Point(ppx - 1, ppy - 1) <> krock Then
ppx = ppx - 1
ppy = ppy - 1
End If
Case 2
If Point(ppx, ppy - 1) <> krock Then
ppy = ppy - 1
End If
Case 3
If Point(ppx + 1, ppy + 1) <> krock Then
ppx = ppx + 1
ppy = ppy + 1
End If
Case 4
If Point(ppx - 1, ppy) <> krock Then
ppx = ppx - 1
End If
Case 6
If Point(ppx + 1, ppy) <> krock Then
ppx = ppx + 1
End If
Case 7
If Point(ppx - 1, ppy + 1) <> krock Then
ppx = ppx - 1
ppy = ppy + 1
End If
Case 8
If Point(ppx, ppy + 1) <> krock Then
ppy = ppy + 1
End If
Case 9
If Point(ppx + 1, ppy + 1) <> krock Then
ppy = ppy + 1
ppx = ppx + 1
End If
Case 10, 11, 12, 13, 14
Print " knocking the wind out of you... ";
pstamina = Int(pstamina / 4)
Case 15, 16, 17, 18, 19, 20
ppx = lastx
ppy = lasty
Print "you tumble back...";
End Select
dmg = Abs(Int((Rnd * 3) - (Rnd * 3)))
If dmg > 0 Then
Print "you suffer "; dmg; " points of damage!"
Else
Print "."
End If
End If
checkrubble = dmg
End Function
Sub circleBF (cx As Long, cy As Long, r As Long, klr As _Unsigned Long)
rsqrd = r * r
y = -r
While y <= r
x = Sqr(rsqrd - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), klr, BF
y = y + 1
Wend
End Sub
Sub rotpoly (cx, cy, rr, shapedeg, turn, klr As _Unsigned Long)
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
Line (cx + x, cy + y)-(cx + x, cy + y), klr
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
Line -(cx + x2, cy + y2), klr
Next
End Sub
Sub bumpypoly (cx, cy, rr, shapedeg, turn, thk, klr As _Unsigned Long)
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
'Line (cx + x, cy + y)-(cx + x, cy + y), klr
lx = cx + x: ly = cy + y
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
tv = (Rnd * 6 + Rnd * 6 + 3) / 10
bumpyline lx, ly, cx + x2, cy + y2, thk * tv, klr
lx = cx + x2: ly = cy + y2
Next
End Sub
Sub addwater (pcx, pcy, scale)
If pcx = 0 Then
pcx = Int(100 + Rnd * 600)
pcy = Int(100 + Rnd * 600)
End If
prr = Int(6 + Rnd * (12 * scale))
preps = (3 + Int(Rnd * prr))
For r = 1 To preps
pcx = pcx + Int(Rnd * 4) - Int(Rnd * 4)
pcy = pcy + Int(Rnd * 4) - Int(Rnd * 4)
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcx - x To pcx + x
kk = Point(x2, pcy + y)
If kk = kfloor Then
PSet (x2, pcy + y), kwater
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub addslime (pcx, pcy, scale)
If pcx = 0 Then
pcx = Int(100 + Rnd * 600)
pcy = Int(100 + Rnd * 600)
End If
prr = Int(6 + Rnd * (12 * scale))
preps = (3 + Int(Rnd * prr))
For r = 1 To preps
pcx = pcx + Int(Rnd * 4) - Int(Rnd * 4)
pcy = pcy + Int(Rnd * 4) - Int(Rnd * 4)
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcx - x To pcx + x
kk = Point(x2, pcy + y)
If kk = kfloor Then
PSet (x2, pcy + y), kslime
End If
Next
y = y + 1
Wend
prr = Int(2 + Rnd * (12 * scale))
Next
End Sub
Sub addlava (pcx, pcy, scale)
If pcx = 0 Then
pcx = Int(100 + Rnd * 600)
pcy = Int(100 + Rnd * 600)
End If
prr = Int(6 + Rnd * (12 * scale))
preps = (2 + Int(Rnd * (prr / 2)))
For r = 1 To preps
pcx = pcx + Int(Rnd * 4) - Int(Rnd * 4)
pcy = pcy + Int(Rnd * 4) - Int(Rnd * 4)
rsqrd = prr * prr
y = -prr
While y <= prr
x = Int(Sqr(rsqrd - y * y))
For x2 = pcx - x To pcx + x
kk = Point(x2, pcy + y)
If kk = kfloor Then
PSet (x2, pcy + y), klava
End If
If kk = kslime Then
PSet (x2, pcy + y), klava
End If
If kk = kwater Then
Select Case Int(Rnd * 10)
Case 1
PSet (x2, pcy + y), klava
Case 2, 3
PSet (x2, pcy + y), krock
Case 4, 5, 6, 7
PSet (x2, pcy + y), kfloor
Case 8, 9, 10
PSet (x2, pcy + y), krubble
End Select
End If
Next
y = y + 1
Wend
prr = Int((prr + Int(6 + Rnd * (12 * scale))) / 2)
Next
End Sub
Sub fatpoly (cx, cy, rr, shapedeg, turn, thk, klr As _Unsigned Long)
x = rr * Sin(0.01745329 * turn)
y = rr * Cos(0.01745329 * turn)
'Line (cx + x, cy + y)-(cx + x, cy + y), klr
lx = cx + x: ly = cy + y
For deg = turn To turn + 360 Step shapedeg
x2 = rr * Sin(0.01745329 * deg)
y2 = rr * Cos(0.01745329 * deg)
fatline lx, ly, cx + x2, cy + y2, thk, klr
lx = cx + x2: ly = cy + y2
Next
End Sub
Sub bumpyline (x0, y0, x1, y1, r, klr As _Unsigned Long)
If Abs(y1 - y0) < Abs(x1 - x0) Then
If x0 > x1 Then
bumpylineLow x1, y1, x0, y0, r, klr
Else
bumpylineLow x0, y0, x1, y1, r, klr
End If
Else
If y0 > y1 Then
bumpylineHigh x1, y1, x0, y0, r, klr
Else
bumpylineHigh x0, y0, x1, y1, r, klr
End If
End If
End Sub
Sub fatline (x0, y0, x1, y1, r, klr As _Unsigned Long)
If Abs(y1 - y0) < Abs(x1 - x0) Then
If x0 > x1 Then
lineLow x1, y1, x0, y0, r, klr
Else
lineLow x0, y0, x1, y1, r, klr
End If
Else
If y0 > y1 Then
lineHigh x1, y1, x0, y0, r, klr
Else
lineHigh x0, y0, x1, y1, r, klr
End If
End If
End Sub
Sub lineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
yi = 1
If dy < 0 Then
yi = -1
dy = -dy
End If
'D = (2 * dy) - dx
d = (dy + dy) - dx
y = y0
For x = x0 To x1
circleBF x, y, r, klr
If d > 0 Then
y = y + yi
' D = D + (2 * (dy - dx))
d = d + ((dy - dx) + (dy - dx))
Else
' D = D + 2 * dy
d = d + dy + dy
End If
Next x
End Sub
Sub lineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
xi = 1
If dx < 0 Then
xi = -1
dx = -dx
End If
' D = (2 * dx) - dy
D = (dx + dx) - dy
x = x0
For y = y0 To y1
circleBF x, y, r, klr
If D > 0 Then
x = x + xi
' D = D + (2 * (dx - dy))
D = D + ((dx - dy) + (dx - dy))
Else
' D = D + 2 * dx
D = D + dx + dx
End If
Next y
End Sub
Sub bumpylineLow (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
yi = 1
If dy < 0 Then
yi = -1
dy = -dy
End If
'D = (2 * dy) - dx
d = (dy + dy) - dx
y = y0
For x = x0 To x1
tv = (Rnd * 6 + Rnd * 6 + 3) / 10
circleBF x + Rnd * r - Rnd * r, y + Rnd * r - Rnd * 4, r * tv, klr
If d > 0 Then
y = y + yi
' D = D + (2 * (dy - dx))
d = d + ((dy - dx) + (dy - dx))
Else
' D = D + 2 * dy
d = d + dy + dy
End If
Next x
End Sub
Sub bumpylineHigh (x0, y0, x1, y1, r, klr As _Unsigned Long)
dx = x1 - x0
dy = y1 - y0
xi = 1
If dx < 0 Then
xi = -1
dx = -dx
End If
' D = (2 * dx) - dy
D = (dx + dx) - dy
x = x0
For y = y0 To y1
tv = (Rnd * 12 + Rnd * 6 + 3) / 10
circleBF x + Rnd * r - Rnd * r, y + Rnd * r - Rnd * 4, r * tv, klr
If D > 0 Then
x = x + xi
' D = D + (2 * (dx - dy))
D = D + ((dx - dy) + (dx - dy))
Else
' D = D + 2 * dx
D = D + dx + dx
End If
Next y
End Sub
Sub addstreams (numstreams, kklr)
Dim stream(numstreams, 6)
