| Welcome, Guest |
You have to register before you can post on our site.
|
| Latest Threads |
Who wants to PLAY?
Forum: QBJS, BAM, and Other BASICs
Last Post: dbox
1 hour ago
» Replies: 3
» Views: 64
|
_CONSOLEINPUT is blocking
Forum: General Discussion
Last Post: mdijkens
2 hours ago
» Replies: 6
» Views: 60
|
Most efficient way to bui...
Forum: General Discussion
Last Post: mdijkens
2 hours ago
» Replies: 7
» Views: 61
|
Fun with Ray Casting
Forum: a740g
Last Post: a740g
Today, 05:50 AM
» Replies: 10
» Views: 216
|
Very basic key mapping de...
Forum: SMcNeill
Last Post: a740g
Today, 02:33 AM
» Replies: 1
» Views: 48
|
Methods in types
Forum: General Discussion
Last Post: bobalooie
Today, 01:02 AM
» Replies: 0
» Views: 45
|
QBJS - ANSI Draw
Forum: QBJS, BAM, and Other BASICs
Last Post: dbox
Yesterday, 04:09 PM
» Replies: 3
» Views: 99
|
Cautionary tale of open, ...
Forum: General Discussion
Last Post: doppler
Yesterday, 10:23 AM
» Replies: 3
» Views: 105
|
Extended KotD #23 and #24...
Forum: Keyword of the Day!
Last Post: SMcNeill
Yesterday, 09:51 AM
» Replies: 0
» Views: 52
|
Big problem for me.
Forum: General Discussion
Last Post: JRace
Yesterday, 05:11 AM
» Replies: 11
» Views: 201
|
|
|
| QB64TUTORIAL.COM is ready |
|
Posted by: TerryRitchie - 09-28-2022, 03:56 AM - Forum: Learning Resources and Archives
- Replies (28)
|
 |
The new tutorial is ready for use:
https://www.qb64tutorial.com
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.
Terry
|
|
|
| Roots and powers playing nicely together... |
|
Posted by: Pete - 09-28-2022, 01:00 AM - Forum: General Discussion
- Replies (28)
|
 |
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
a$ = stringmatha$: b$ = stringmathb$: op$ = operator$
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
z$ = MID$(z$, 0, LEN(z$) - (dec_a&& + dec_b&& - 1)) + "." + MID$(z$, LEN(z$) - (dec_a&& + dec_b&&) + 1)
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.
Pete
EDIT: Screwy forum didn't register post contents.
|
|
|
|
| b+ String Math Update |
|
Posted by: bplus - 09-26-2022, 06:01 PM - Forum: Works in Progress
- Replies (11)
|
 |
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
$Console:Only
Randomize Timer
'Dim As Double i ' testing Dec2Bin$
'Dim p2$, x$, sum$
'p2$ = "1"
'For i = 1 To 50
' p2$ = mr$(p2$, "/", "2")
' x$ = mr$(x$, "+", "1")
' sum$ = mr$(x$, "+", p2$)
' Print sum$, Dec2Bin$(sum$)
' 'Sleep
'Next
'Print: Print " Square Roots:"
'Dim b$, intger$
'For i = 1 To 50
' b$ = Str$(i + 1 / (2 ^ i))
' Print b$, bigSQR$(b$)
'Next
'intger$ = "10000000000000000000000000000000000000000000000000000000000000000"
'Print: Print "Bonus SQR of "; intger$; " Len = "; Len(intger$); " is:"
'b$ = bigSQR$(intger$)
'Print b$, " Len Integer Part ="; Len(Mid$(b$, 1, InStr(b$, ".") - 1))
'intger$ = "100000000000000000000000000000000000000000000000000000000000000000"
'Print: Print "Bonus SQR of "; intger$; " Len = "; Len(intger$); " is:"
'b$ = bigSQR$(intger$)
'Print b$, " Len Integer Part ="; Len(Mid$(b$, 1, InStr(b$, ".") - 1))
'Print: Print " Square Roots:"
' ============ 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 |
|
Posted by: James D Jarvis - 09-26-2022, 05:08 PM - Forum: Works in Progress
- Replies (14)
|
 |
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
cave(1, cmx) = Int((cave(1, csx) + cave(1, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
cave(1, cmy) = Int((cave(1, csy) + cave(1, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
For c = 2 To 24
Select Case Int(1 + Rnd * 8)
Case 1, 2, 3
cave(c, csx) = cave(c - 1, csx)
cave(c, csy) = cave(c - 1, csy)
Case 4, 5
cave(c, csx) = cave(c - 1, cmx)
cave(c, csy) = cave(c - 1, cmy)
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$ = " "
'Do
ecave = Int(6 + Rnd * 16)
exitX = cave(ecave, ctx)
exitY = cave(excave, cty)
'Loop Until Point(exitX, exitY) <> krock
PSet (exitX, exitY), kexit
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)
restartstreams:
stream(1, csx) = Int(100 + Rnd * 600)
stream(1, csy) = Int(100 + Rnd * 600)
Do
stream(1, ctx) = Int(100 + Rnd * 600)
stream(1, cty) = Int(100 + Rnd * 600)
dx = Abs(stream(1, csx) - stream(1, ctx))
dy = Abs(stream(1, csy) - stream(1, cty))
dl = Sqr(dx * dx + dy * dy)
Loop Until dy > 20 And dx > 20
stream(1, cmx) = Int((stream(1, csx) + stream(1, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
stream(1, cmy) = Int((stream(1, csy) + stream(1, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
For c = 2 To numstreams
Select Case Int(1 + Rnd * 8)
Case 1, 2, 3
stream(c, csx) = stream(c - 1, csx)
stream(c, csy) = stream(c - 1, csy)
Case 4, 5
stream(c, csx) = stream(c - 1, cmx)
stream(c, csy) = stream(c - 1, cmy)
Case 6, 7, 8
stream(c, csx) = stream(c - 1, ctx)
stream(c, csy) = stream(c - 1, cty)
End Select
cpl = 0
Do
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
stream(c, ctx) = Int(100 + Rnd * 600)
stream(c, cty) = Int(100 + Rnd * 600)
Case 4, 5, 6
If stream(c, csx) <= 400 Then
stream(c, ctx) = stream(c, csx) + Int(50 + Rnd * 200)
Else
stream(c, ctx) = stream(c, csx) - Int(50 + Rnd * 200)
End If
If stream(c, csy) <= 400 Then
stream(c, cty) = stream(c, csy) + Int(50 + Rnd * 200)
Else
stream(c, cty) = stream(c, csy) - Int(50 + Rnd * 200)
End If
End Select
dx = Abs(stream(c, csx) - stream(c, ctx))
dy = Abs(stream(c, csy) - stream(c, cty))
dl = Sqr(dx * dx + dy * dy)
cpl = cpl + 1
If stream(c, ctx) < 50 Then GoTo restartstreams
If cpl > caverunlimit Then GoTo restartstreams
Loop Until dy > 20 And dx > 20
stream(c, cmx) = Int((stream(c, csx) + stream(c, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
stream(c, cmy) = Int((stream(c, csy) + stream(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 numstreams
r = (3 + (1 + Rnd * 6) + (1 + Rnd * 6)) / 4
xx = stream(c, csx)
yy = stream(c, csy)
If Point(xx, yy) = krock Then
bumpypoly xx, yy, Int(r / 2 + Int(Rnd * (r * 3))), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
End If
xtrend = 0: ytrend = 0
If xx < stream(c, cmx) Then xtrend = 3
If xx > stream(c, cmx) Then xtrend = -3
If yy < stream(c, cmy) Then ytrend = 3
If yy > stream(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(stream(c, cmx) - nx)
dy = Abs(stream(c, cmy) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < (r * 10) Then
nx = stream(c, cmx)
ny = ny + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
If dy < (r * 10) Then
ny = stream(c, cmy)
nx = nx + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
bumpyline xx, yy, nx, ny, r, kklr
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartstreams
If stream(c, cmx) < 50 Then GoTo restartstreams
Loop Until xx = stream(c, cmx) And yy = stream(c, cmy)
Next
If Point(nx, ny) = krock Then
bumpypoly nx, ny, Int(r / 2 + Int(Rnd * r)), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
End If
For c = 1 To numstreams
xx = stream(c, cmx)
yy = stream(c, cmy)
xtrend = 0: ytrend = 0
If xx < stream(c, ctx) Then xtrend = 2
If xx > stream(c, ctx) Then xtrend = -2
If yy < stream(c, cty) Then ytrend = 2
If yy > stream(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(stream(c, ctx) - nx)
dy = Abs(stream(c, cty) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < r * 7 Then
nx = stream(c, ctx)
ny = ny + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
If dy < r * 7 Then
ny = stream(c, cty)
nx = nx + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
bumpyline xx, yy, nx, ny, r, kklr
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartstreams
If stream(c, ctx) < 50 Then GoTo restartstreams
Loop Until xx = stream(c, ctx) And yy = stream(c, cty)
If Point(nx, ny) = krock Then
bumpypoly nx, ny, Int(r / 2 + Int(Rnd * r)), Int(20 + Rnd * 100), Rnd * 30, 2 + Rnd * 4, kfloor
End If
Next
End Sub
Sub addlavaflows (numstreams)
Dim stream(numstreams, 6)
restartflows:
stream(1, csx) = Int(100 + Rnd * 600)
stream(1, csy) = Int(100 + Rnd * 600)
Do
stream(1, ctx) = Int(100 + Rnd * 600)
stream(1, cty) = Int(100 + Rnd * 600)
dx = Abs(stream(1, csx) - stream(1, ctx))
dy = Abs(stream(1, csy) - stream(1, cty))
dl = Sqr(dx * dx + dy * dy)
Loop Until dy > 20 And dx > 20
stream(1, cmx) = Int((stream(1, csx) + stream(1, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
stream(1, cmy) = Int((stream(1, csy) + stream(1, cty)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
For c = 2 To numstreams
Select Case Int(1 + Rnd * 8)
Case 1, 2, 3
stream(c, csx) = stream(c - 1, csx)
stream(c, csy) = stream(c - 1, csy)
Case 4, 5
stream(c, csx) = stream(c - 1, cmx)
stream(c, csy) = stream(c - 1, cmy)
Case 6, 7, 8
stream(c, csx) = stream(c - 1, ctx)
stream(c, csy) = stream(c - 1, cty)
End Select
cpl = 0
Do
Select Case Int(1 + Rnd * 6)
Case 1, 2, 3
stream(c, ctx) = Int(100 + Rnd * 600)
stream(c, cty) = Int(100 + Rnd * 600)
Case 4, 5, 6
If stream(c, csx) <= 400 Then
stream(c, ctx) = stream(c, csx) + Int(50 + Rnd * 200)
Else
stream(c, ctx) = stream(c, csx) - Int(50 + Rnd * 200)
End If
If stream(c, csy) <= 400 Then
stream(c, cty) = stream(c, csy) + Int(50 + Rnd * 200)
Else
stream(c, cty) = stream(c, csy) - Int(50 + Rnd * 200)
End If
End Select
dx = Abs(stream(c, csx) - stream(c, ctx))
dy = Abs(stream(c, csy) - stream(c, cty))
dl = Sqr(dx * dx + dy * dy)
cpl = cpl + 1
If stream(c, ctx) < 50 Then GoTo restartflows
If cpl > caverunlimit Then GoTo restartflows
Loop Until dy > 20 And dx > 20
stream(c, cmx) = Int((stream(c, csx) + stream(c, ctx)) / 2 + (10 + Rnd * 50) - (10 + Rnd * 50))
stream(c, cmy) = Int((stream(c, csy) + stream(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 numstreams
r = (3 + (1 + Rnd * 6) + (1 + Rnd * 6)) / 4
xx = stream(c, csx)
yy = stream(c, csy)
xtrend = 0: ytrend = 0
If xx < stream(c, cmx) Then xtrend = 3
If xx > stream(c, cmx) Then xtrend = -3
If yy < stream(c, cmy) Then ytrend = 3
If yy > stream(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(stream(c, cmx) - nx)
dy = Abs(stream(c, cmy) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < (r * 10) Then
nx = stream(c, cmx)
ny = ny + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
If dy < (r * 10) Then
ny = stream(c, cmy)
nx = nx + Int(r + Rnd * (r * 2)) - Int(r + Rnd * (r * 2))
End If
bumpyline xx, yy, nx, ny, r, klava
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartflows
If stream(c, cmx) < 50 Then GoTo restartflows
Loop Until xx = stream(c, cmx) And yy = stream(c, cmy)
Next
For c = 1 To numstreams
xx = stream(c, cmx)
yy = stream(c, cmy)
xtrend = 0: ytrend = 0
If xx < stream(c, ctx) Then xtrend = 2
If xx > stream(c, ctx) Then xtrend = -2
If yy < stream(c, cty) Then ytrend = 2
If yy > stream(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(stream(c, ctx) - nx)
dy = Abs(stream(c, cty) - ny)
dd = Sqr(dx * dx + dy * dy)
If dx < r * 7 Then
nx = stream(c, ctx)
ny = ny + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
If dy < r * 7 Then
ny = stream(c, cty)
nx = nx + Int(r / 4 + Rnd * (r / 2)) - Int(r / 4 + Rnd * (r / 2))
End If
bumpyline xx, yy, nx, ny, r, klava
xx = nx
yy = ny
cpl = cpl + 1
If cpl > caverunlimit Then GoTo restartflows
If stream(c, ctx) < 50 Then GoTo restartflows
Loop Until xx = stream(c, ctx) And yy = stream(c, cty)
Next
End Sub
|
|
|
|
| Idea similar to _exit |
|
Posted by: eoredson - 09-26-2022, 04:26 AM - Forum: Help Me!
- Replies (12)
|
 |
Hi,
I had an idea..
Since _exit traps Control-Break which is int x1B
then why not trap _print with PrintScreen which is int x05
Erik.
|
|
|
|
| Pascal's Triangle and nth roots. |
|
Posted by: Pete - 09-25-2022, 06:26 PM - Forum: General Discussion
- Replies (2)
|
|
So to finish off my nth root calculator with long division, I needed to incorporate Pascal's Triangle in the binominal expansion algorithm.
Code: (Select All) DIM AS DOUBLE i, j, r, z
INPUT "root: "; r
FOR i = 1 TO r + 1
z = 1
FOR j = 1 TO i
PRINT z;
z = z * (i - j) \ j
NEXT
PRINT
NEXT
WORKING MODEL FOR NON-DECIMAL ROOTS. NOTE: NO DECIMAL POINT YET in output. I will be adding that later...
Code: (Select All) $CONSOLE:ONLY
LINE INPUT "Whole number: "; n$
LINE INPUT "Root: "; r$
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
LOOP
sm_rt$ = d$
PRINT "Answer: "; sm_rt$: PRINT
RUN
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
a$ = stringmatha$: b$ = stringmathb$: op$ = operator$
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
z$ = MID$(z$, 0, LEN(z$) - (dec_a&& + dec_b&& - 1)) + "." + MID$(z$, LEN(z$) - (dec_a&& + dec_b&&) + 1)
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
Pete
|
|
|
|
| Cannot convert expression type to symbol |
|
Posted by: eoredson - 09-25-2022, 06:10 AM - Forum: Help Me!
- Replies (4)
|
|
I have this sample code:
Common Shared Test() As String * 260
which in the status area displays
Cannot convert expression type to symbol
and I had to drill down to the function declaration using process of elimination to find.
Problem: the error does not state the line number it is in!
could this be fixed in a future mod of Qb64??
Thanks, Erik.
|
|
|
|
| Tvaders |
|
Posted by: James D Jarvis - 09-23-2022, 07:57 PM - Forum: Works in Progress
- Replies (15)
|
|
A text-mode space invaders-style game.
It's still got a few rough edges and there's a planned game feature not yet coded (shields) but there's enough of a game to share here as a work in progress.
move left with "a" or "<"
move right with "d" or ">"
to fire press the spacebar
It plays to level 16 currently.
Code: (Select All) 'Tvaders 1-d01
'by James D. Jarvis , you are of course free to modify and share this code as you like
'
'a text-mode qb64 retro-shooter
'
'$dynamic
Screen _NewImage(100, 35, 0)
_Title "Tvaders 1"
Type spritetype
s As String
w As Integer 'i wanted to make this a byte but i want to be a tiny bit backwards compatible for folks with different versions
sx As Integer
sy As Integer
hdg As Integer
End Type
Dim Shared a(16) As spritetype
Dim Shared ps As spritetype
Dim Shared ss(10) As spritetype
Dim Shared b(100) As spritetype
Dim Shared aspace(100, 35)
Dim Shared a$, gflag$
Dim Shared shotmax, shotspeed, shottimer, aliencount, aliendelay, alientimer, alive, level, score
Dim Shared boltmax, bolttimer, boltspeed, alienfire, shields
_ControlChr Off
Randomize Timer
Read a$
Read ship$
Read bolt$
Read shot$
ps.s = ship$
ps.w = 8
ps.sx = 32
ps.sy = 31
a(1).s = a$
a(1).w = 8
a(1).sx = 1
a(1).sy = 3
a(1).hdg = 1
For n = 1 To 100
b(n).s = bolt$
b(n).w = 1
b(n).sx = 0
b(n).sy = 0
Next n
For n = 1 To 10
ss(n).s = shot$
ss(n).w = 2
ss(n).sx = 0
ss(n).sy = 0
Next n
gflag$ = "GAMEON"
shotmax = 3
shotspeed = 10
shottimer = 0
aliencount = 1
aliendelay = 20
alientimer = 0
alive = aliencounter
level = 1
boltmax = 100
bolttimer = 0
boltspeed = 9
startlevel level
Do
_Limit 60
handleshots
handlealiens
handlezaps
Cls
Locate 1, 1
Print "LEVEL : "; level
Locate 1, 40
Print "Shields : "; shields
Locate 1, 70
Print "SCORE : "; score
Locate 2, 1
Print "ALive "; alive
If gflag$ = "BOOM" Then doboom
For bc = 1 To 100
If b(bc).sx > 0 Then splat b(bc).s, b(bc).w, b(bc).sx, b(bc).sy
Next bc
For ac = 1 To aliencount
If a(ac).sx > 0 Then
splat a(ac).s, a(ac).w, a(ac).sx, a(ac).sy
End If
Next ac
splat ps.s, ps.w, ps.sx, ps.sy
For s = 1 To shotmax
If ss(s).sx <> 0 Then splat ss(s).s, ss(s).w, ss(s).sx, ss(s).sy
Next s
kk$ = InKey$
If LCase$(kk$) = "a" Or kk$ = "," Or kk$ = "<" Then ps.sx = ps.sx - 1
If LCase$(kk$) = "d" Or kk$ = "." Or kk$ = ">" Then ps.sx = ps.sx + 1
If kk$ = " " Then fire ps.sx + 3
If ps.sx < 1 Then ps.sx = 1
If ps.sx > 92 Then ps.sx = 92
If alive < 1 Then nextlevel level
_Display
Loop Until kk$ = Chr$(27) Or gflag$ = "GAMEOVER"
System
'sprites were orignally drawn in ascii tilemaker and stripped out of the data file without the color data for use here
Data "ÛÛÛÛÛÛÛÛ Û0 0Û ÛÛÛÛÛÛÛÛ ^ ^^ ^ "
Data " ²² ÎÎ ²²²² ²²^²²^²²"
Data "/\/"
Data "##^^"
Sub fire (fx)
shotfound = 0
noshots = 0
Do
noshots = noshots + 1
If ss(noshots).sx = 0 Then shotfound = noshots
Loop Until shotfound > 0 Or noshots = shotmax
If shotfound > 0 Then
ss(shotfound).sx = fx
ss(shotfound).sy = ps.sy - 2
End If
End Sub
Sub zap (zx, zy)
zapfound = 0
zapcount = 0
Do
zapcount = zapcount + 1
If b(zapcount).sx = 0 Then zapfound = zapcount
Loop Until zapfound > 1 Or zapcount = boltmax
If zapcount > 0 Then
b(zapcount).sx = zx + 4
b(zapcount).sy = zy + 3
End If
End Sub
Sub handlezaps
bolttimer = bolttimer + 1
If bolttimer = boltspeed Then
bolttimer = 0
For n = 1 To 100
If b(n).sx > 0 Then
b(n).sy = b(n).sy + 1
If b(n).sy = 33 Then
b(n).sx = 0
b(n).sy = 0
End If
If b(n).sy = 31 Then
For xx = ps.sx To ps.sx + 7
If b(n).sx = xx Then playerhit$ = "BOOM"
If playerhit$ = "BOOM" Then
For rr = 1 To 20
_Limit 150
For d = 1 To 300
_PrintString (2 + Int(Rnd * 98), 5 + Int(Rnd * 30)), "*"
Next d
_PrintString (b(n).sx + Int(Rnd * 3), b(n).sy + Int(Rnd * 3)), "BOOM!"
gflag$ = "BOOM"
_Display
Next rr
End If
Next xx
End If
End If
Next n
End If
End Sub
Sub handleshots
shottimer = shottimer + 1
If shottimer = shotspeed Then
hittag$ = "miss"
For s = 1 To shotmax
For aa = 1 To aliencount
If a(aa).sx > 0 Then
sl = Len(a(aa).s)
sh = sl / a(aa).w
For y = 1 To sh
For x = 1 To a(aa).w
If a(aa).sx + x - 1 = ss(s).sx And a(aa).sy + y - 1 = ss(s).sy And hittag$ = "miss" Then hittag$ = "hit"
Next x
Next
End If
If hittag$ = "hit" Then
ss(s).sx = 0
a(aa).sx = 0
alive = alive - 1
hittag$ = "miss"
score = score + 100
Beep
End If
Next aa
ss(s).sy = ss(s).sy - 2
If ss(s).sy < 1 Then
ss(s).sx = 0
ss(s).sy = 0
End If
Next s
shottimer = 0
End If
End Sub
Sub handlealiens
alientimer = alientimer + 1
If alientimer > 32000 Then alientimer = 1
For n = 1 To aliencount
If a(n).sx > 0 And (alientimer Mod aliendelay = 0) Then
a(n).sx = a(n).sx + a(n).hdg
If a(n).sx > 92 Then
a(n).sx = 92
a(n).sy = a(n).sy + 2
a(n).hdg = a(n).hdg * -1
End If
If a(n).sx < 1 Then
a(n).sx = 1
a(n).sy = a(n).sy + 2
a(n).hdg = a(n).hdg * -1
End If
If 1 + Int(Rnd * 100) <= alienfire Then zap a(n).sx, a(n).sy
If a(n).sy = 31 Then
For xx = ps.sx To ps.sx + 7
If a(n).sx = xx Then playerhit$ = "BOOM"
If playerhit$ = "BOOM" Then
For rr = 1 To 20
_Limit 150
For d = 1 To 300
_PrintString (2 + Int(Rnd * 98), 5 + Int(Rnd * 30)), "*"
Next d
_PrintString (a(n).sx + Int(Rnd * 3), a(n).sy + Int(Rnd * 3)), "BOOM!"
gflag$ = "BOOM"
_Display
Next rr
End If
Next xx
End If
End If
Next
End Sub
Sub splat (SA$, ww As Integer, sx As Integer, sy As Integer)
sl = Len(SA$)
sh = sl / ww
For y = 1 To sh
_PrintString (sx, sy - 1 + y), Mid$(SA$, (y - 1) * ww + 1, ww)
Next
End Sub
Sub startlevel (level)
For bb = 1 To 100
b(bb).sx = 0
b(bb).sy = 0
Next bb
Select Case level
Case 1
aliencount = 1
alive = 1
aliendelay = 20
a(1).s = a$
a(1).w = 8
a(1).sx = 46
a(1).sy = 3
a(1).hdg = 1
shields = 0
score = 0
alienfire = 0
Case 2
aliencount = 3
alive = 3
aliendelay = 20
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).sx = n * 12 + 30
a(n).sy = 3
a(n).hdg = 1
Next n
shields = 3
alienfire = 2
Case 3
aliencount = 5
alive = 5
aliendelay = 19
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).sx = n * 11 + 20
a(n).sy = 4
a(n).hdg = 1
Next n
shields = shields + 2
alienfire = 4
Case 4
aliencount = 6
alive = 6
aliendelay = 19
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).sx = n * 15
a(n).sy = 5
a(n).hdg = 1
Next n
shields = shields + 2
alienfire = 6
Case 5
aliencount = 7
alive = 7
aliendelay = 18
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).hdg = 1
Next n
For n = 1 To 5
a(n).sx = n * 15
a(n).sy = 1
Next n
For n = 6 To 7
a(n).sx = (n - 5) * 35
a(n).sy = 5
Next n
shields = shields + 2
alienfire = 6
Case 6
aliencount = 8
alive = 8
aliendelay = 18
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).hdg = 1
Next n
For n = 1 To 3
a(n).sx = n * 25
a(n).sy = 3
Next n
For n = 4 To aliencount
a(n).sx = (n - 3) * 12
a(n).sy = 7
Next n
shields = shields + 2
alienfire = 8
Case 7
aliencount = 9
alive = 9
aliendelay = 17
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).hdg = 1
Next n
For n = 1 To 3
a(n).sx = n * 12
a(n).sy = 3
Next n
For n = 4 To 6
a(n).sx = (n - 3) * 12 + 30
a(n).sy = 7
a(n).hdg = -1
Next n
For n = 7 To 9
a(n).sx = (n - 6) * 12
a(n).sy = 11
Next n
shields = shields + 2
alienfire = 8
Case 8
aliencount = 10
alive = 10
aliendelay = 17
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).hdg = Int(Rnd * 2) - 1
If a(n).hdg = 0 Then a(n).hdg = 1
a(n).sx = 12 + Int(Rnd * 8) * 8
a(n).sy = 1 + Int(Rnd * 3) * 4
Next n
shields = shields + 2
alienfire = 9
Case 9
aliencount = 11
alive = 11
aliendelay = 16
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).hdg = -2
Next n
For n = 1 To 5
a(n).sx = n * 12 + 12
a(n).sy = 3
Next n
For n = 6 To aliencount
a(n).sx = (n - 5) * 8
a(n).sy = 7
Next n
shields = shields + 2
alienfire = 9
Case 10
aliencount = 12
alive = 12
aliendelay = 16
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).hdg = Int(Rnd * 4) - 2
If a(n).hdg = 0 Then a(n).hdg = 1
a(n).sx = 12 + Int(Rnd * 8) * 8
a(n).sy = 1 + Int(Rnd * 3) * 4
Next n
shields = shields + 1
alienfire = 10
Case 11
aliencount = 13
alive = 13
aliendelay = 15
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).hdg = -2
Next n
For n = 1 To 7
a(n).sx = n * 12
a(n).sy = 1 + Int(Rnd * 3) * 4
Next n
For n = 8 To aliencount
a(n).sx = (n - 7) * 12
a(n).sy = 13
Next n
shields = shields + 1
alienfire = 1
Case 12
aliencount = 14
alive = 14
aliendelay = 14
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
Next n
For n = 1 To 7
a(n).sx = n * 9
a(n).sy = 1
a(n).hdg = -2
Next n
For n = 8 To aliencount
a(n).sx = (n - 7) * 9
a(n).sy = 11
a(n).hdg = 2
Next n
shields = shields + 1
alienfire = 11
Case 13
aliencount = 15
alive = 15
aliendelay = 13
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
Next n
For n = 1 To 10
a(n).sx = (n * 9) - 8
a(n).sy = 2
a(n).hdg = -2
Next n
For n = 11 To aliencount
a(n).sx = (n - 10) * 9
a(n).sy = 9
a(n).hdg = 3
Next n
shields = shields + 1
alienfire = 12
Case 14
aliencount = 16
alive = 16
aliendelay = 12
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
Next n
For n = 1 To 8
a(n).sx = (n * 9) - 8
a(n).sy = 2
a(n).hdg = -3
Next n
For n = 9 To aliencount
a(n).sx = (n - 8) * 9
a(n).sy = 11
a(n).hdg = 3
Next n
shields = shields + 1
alienfire = 13
Case 15
aliencount = 16
alive = 16
aliendelay = 10
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
Next n
For n = 1 To 9
a(n).sx = (n * 9) - 8
a(n).sy = 4
a(n).hdg = -3
Next n
For n = 10 To 14
a(n).sx = (n - 9) * 9 + 4
a(n).sy = 9
a(n).hdg = 3
Next n
For n = 15 To aliencount
a(n).sx = (n - 14) * 20 + 40
a(n).sy = 13
a(n).hdg = 4
Next n
shields = shields + 1
alienfire = 14
Case 16
aliencount = 16
alive = 16
aliendelay = 8
For n = 1 To aliencount
a(n).s = a$
a(n).w = 8
a(n).hdg = Int(Rnd * 8) - 4
If a(n).hdg = 0 Then a(n).hdg = 4
Next n
For x = 0 To 3
For y = 1 To 4
a(x * 4 + y).sx = x * 20
a(x * 4 + y).sy = y * 5
Next y
Next x
shields = shields + 1
alienfire = 15
End Select
End Sub
Sub nextlevel (level)
If level < 17 Then
score = score + level * 1000
Locate 10, 10
Cls
_KeyClear
Print "*********************************************************"
Print "* *"
Print "* COMPLETED LEVEL *"
Print "* *"
Print "* PRESS ANY KEY *"
Print "* *"
Print "* TO START NEXT LEVEL *"
Print "* *"
Print "* *"
Print "*********************************************************"
_Display
any$ = Input$(1)
level = level + 1
If level < 17 Then startlevel level
If level = 17 Then gameflag$ = "GAMEOVER"
End If
If level = 17 Or gameflag$ = "GAMEOVER" Then
Cls
Locate 10, 10
_KeyClear
Print "*********************************************************"
Print "* *"
Print " CONGRATULATIONS ! "
Print "* *"
Print " You Have Defeated the ALIENs! "
Print "* *"
Print
Print " FINAL SCORE : "; score
Print
Print "* PRESS Y to Play again *"
Print " "
Print "* *"
Print "*********************************************************"
_Display
any$ = Input$(1)
If any$ = "y" Or any$ = "Y" Then
gfla$ = "GAMEON"
startlevel 1
Else
Cls
gflag$ = "GAMEOVER"
End If
End If
End Sub
Sub doboom
_KeyClear
Locate 10, 10: Print "*********************************************************"
Locate 11, 10: Print "* ÛÛÛÛÛÛÛÛ *"
Locate 12, 10: Print " Û0 0Û B O O M ! "
Locate 13, 10: Print "* ÛÛÛÛÛÛÛÛ *"
Locate 14, 10: Print " ^ ^^ ^ You Were Defeated by the ALIENs! "
Locate 15, 10: Print "* *"
Locate 16, 10: Print
Locate 17, 10: Print " FINAL SCORE : "; score
Locate 18, 10: Print
Locate 19, 10: Print "* PRESS Y to Play again ÛÛÛÛÛÛÛÛ *"
Locate 20, 10: Print " ÛÛÛÛÛÛÛÛ Û0 0Û "
Locate 21, 10: Print "* Û0 0Û ÛÛÛÛÛÛÛÛ *"
Locate 22, 10: Print "*********************************************************"
_Display
any$ = Input$(1)
If any$ = "y" Or any$ = "Y" Then
gflag$ = "GAMEON"
startlevel 1
Else
Cls
gflag$ = "GAMEOVER"
End If
End Sub
|
|
|
|
| my kid and the microbit |
|
Posted by: James D Jarvis - 09-23-2022, 01:53 PM - Forum: General Discussion
- No Replies
|
|
My youngest kid just got to fiddle with a microbit in school this week in STEM lab class and rushed home and wrote a space invaders game in smalltalk and javascript in an emulator to try in class. They are a nifty little gadget. The kid liked it so much we ordered one online last night (with a fancy power supply so it can work without being plugged into another device, well....a battery attachment.)
I of course looked into it and sure enough some folks are programming for them in BASIC. Anyone here know anything else about microbits and BASIC?
|
|
|
|
|
